source: main/trunk/greenstone2/perllib/printusage.pm@ 21341

###########################################################################
#
# printusage.pm --
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################


package PrintUsage;


use gsprintf;
use strict;
no strict 'subs'; # allow barewords (eg STDERR) as function arguments


sub gsprintf
{
    return &gsprintf::gsprintf(@_);
}

# this is not called by plugins or classifiers, just by scripts
sub print_xml_usage
{
    my $options = shift(@_);

    # XML output is always in UTF-8
    &gsprintf::output_strings_in_UTF8;

    &print_xml_header("script");

    &gsprintf(STDERR, "<Info>\n");
    &gsprintf(STDERR, "  <Name>$options->{'name'}</Name>\n");
    &gsprintf(STDERR, "  <Desc>$options->{'desc'}</Desc>\n");
    &gsprintf(STDERR, "  <Arguments>\n");
    if (defined($options->{'args'})) {
    &print_options_xml($options->{'args'});
    }
    &gsprintf(STDERR, "  </Arguments>\n");
    &gsprintf(STDERR, "</Info>\n");
}


sub print_xml_header
{
    &gsprintf(STDERR, "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
}


sub print_options_xml
{
    my $options = shift(@_);

    foreach my $option (@$options) {
    next if defined($option->{'internal'});
    
    my $optionname = $option->{'name'};
    my $displayname = $option->{'disp'};
    
    my $optiondesc = &gsprintf::lookup_string($option->{'desc'});

    # Escape '<' and '>' characters
    $optiondesc =~ s/</&amp;lt;/g; # doubly escaped
    $optiondesc =~ s/>/&amp;gt;/g;

    # Display option name, description and type
    &gsprintf(STDERR, "    <Option>\n");
    &gsprintf(STDERR, "      <Name>$optionname</Name>\n");
    if (defined($option->{'disp'})) {
        my $displayname = &gsprintf::lookup_string($option->{'disp'});
        # Escape '<' and '>' characters
        $displayname =~ s/</&amp;lt;/g; # doubly escaped
        $displayname =~ s/>/&amp;gt;/g;
        &gsprintf(STDERR, "      <DisplayName>$displayname</DisplayName>\n");
    }
    &gsprintf(STDERR, "      <Desc>$optiondesc</Desc>\n");
    &gsprintf(STDERR, "      <Type>$option->{'type'}</Type>\n");

    # If the option has a required field, display this
    if (defined($option->{'reqd'})) {
        &gsprintf(STDERR, "      <Required>$option->{'reqd'}</Required>\n");
    }

    # If the option has a charactor length field, display this
    if (defined($option->{'char_length'})) {
        &gsprintf(STDERR, "      <CharactorLength>$option->{'char_length'}</CharactorLength>\n");
    }

    # If the option has a range field, display this
    if (defined($option->{'range'})) {
        &gsprintf(STDERR, "      <Range>$option->{'range'}</Range>\n");
    }

    # If the option has a list of possible values, display these
    if (defined $option->{'list'}) {
        &gsprintf(STDERR, "      <List>\n");
        my $optionvalueslist = $option->{'list'};
        foreach my $optionvalue (@$optionvalueslist) {
        &gsprintf(STDERR, "        <Value>\n");
        &gsprintf(STDERR, "          <Name>$optionvalue->{'name'}</Name>\n");
        if (defined $optionvalue->{'desc'}) {
            my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});

            # Escape '<' and '>' characters
            $optionvaluedesc =~ s/</&amp;lt;/g; #doubly escaped
            $optionvaluedesc =~ s/>/&amp;gt;/g;

            &gsprintf(STDERR, "          <Desc>$optionvaluedesc</Desc>\n");
        }
        &gsprintf(STDERR, "        </Value>\n");
        }

#       # Special case for 'input_encoding'
#       if ($optionname =~ m/^input_encoding$/i) {
#       my $e = $encodings::encodings;
#       foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
#           &gsprintf(STDERR, "        <Value>\n");
#           &gsprintf(STDERR, "          <Name>$enc</Name>\n");
#           &gsprintf(STDERR, "          <Desc>$e->{$enc}->{'name'}</Desc>\n");
#           &gsprintf(STDERR, "        </Value>\n");
#       }
#       }

        &gsprintf(STDERR, "      </List>\n");
    }

    # Show the default value for the option, if there is one
    if (defined $option->{'deft'}) {
        my $optiondeftvalue = $option->{'deft'};

        # Escape '<' and '>' characters
        $optiondeftvalue =~ s/</&lt;/g;
        $optiondeftvalue =~ s/>/&gt;/g;

        &gsprintf(STDERR, "      <Default>$optiondeftvalue</Default>\n");
    }

    # If the option is noted as being hidden in GLI, add that to the printout
    if (defined($option->{'hiddengli'})) {
        &gsprintf(STDERR, "      <HiddenGLI>$option->{'hiddengli'}</HiddenGLI>\n");
    }
    # If the argument is not hidden then print out the lowest detail mode it is visible in
    if (defined($option->{'modegli'})) {
        &gsprintf(STDERR, "      <ModeGLI>$option->{'modegli'}</ModeGLI>\n");
    }

    &gsprintf(STDERR, "    </Option>\n");
    }
}


sub print_txt_usage
{
    my $options = shift(@_);
    my $params = shift(@_);

    # this causes us to automatically send output to a pager, if one is
    # set, AND our output is going to a terminal
    # active state perl on windows doesn't do open(handle, "-|");
    if ($ENV{'GSDLOS'} !~ /windows/ && -t STDOUT) {
        my $pager = $ENV{"PAGER"};
    if (! $pager) {$pager="(less || more)"}
    my $pid = open(STDIN, "-|"); # this does a fork... see man perlipc(1)
    if (!defined $pid) {
        gsprintf(STDERR, "pluginfo.pl - can't fork: $!");
    } else {
        if ($pid != 0) { # parent (ie forking) process. child gets 0
        exec ($pager);
        }
    }
    open(STDERR,">&STDOUT"); # so it's easier to pipe output
    }



    my $programname = $options->{'name'};
    my $programargs = $options->{'args'};
    my $programdesc = $options->{'desc'};

    # Find the length of the longest option string
    my $descoffset = 0;
    if (defined($programargs)) {
    $descoffset = &find_longest_option_string($programargs);
    }

    # Produce the usage information using the data structure above
    if (defined($programdesc)) {
    &gsprintf(STDERR, $programname . ": $options->{'desc'}\n\n");
    }

    &gsprintf(STDERR, " {common.usage}: $programname $params\n\n");

    # Display the program options, if there are some
    if (defined($programargs)) {
    # Calculate the column offset of the option descriptions
    my $optiondescoffset = $descoffset + 2;  # 2 spaces between options & descriptions

    &gsprintf(STDERR, " {common.options}:\n");

    # Display the program options
    &print_options_txt($programargs, $optiondescoffset);
    }
}


sub print_options_txt
{
    my $options = shift(@_);
    my $optiondescoffset = shift(@_);

    foreach my $option (@$options) {
    next if defined($option->{'internal'});

    # Display option name
    my $optionname = $option->{'name'};
    &gsprintf(STDERR, "  -$optionname");
    my $optionstringlength = length("  -$optionname");

    # Display option type, if the option is not a flag
    my $optiontype = $option->{'type'};
    if ($optiontype ne "flag") {
        &gsprintf(STDERR, " <$optiontype>");
        $optionstringlength = $optionstringlength + length(" <$optiontype>");
    }

    # Display the option description    
    if (defined($option->{'disp'})) {
        my $optiondisp = &gsprintf::lookup_string($option->{'disp'});
        &display_text_in_column($optiondisp, $optiondescoffset, $optionstringlength, 80);
        &gsprintf(STDERR, " " x $optionstringlength);
    }
    my $optiondesc = &gsprintf::lookup_string($option->{'desc'});
    my $optionreqd = $option->{'reqd'};
    if (defined($optionreqd) && $optionreqd eq "yes") {
        $optiondesc = "(" . &gsprintf::lookup_string("{PrintUsage.required}") . ") " . $optiondesc;
    }
    &display_text_in_column($optiondesc, $optiondescoffset, $optionstringlength, 80);

    # Show the default value for the option, if there is one
    my $optiondefault = $option->{'deft'};
    if (defined($optiondefault)) {
        &gsprintf(STDERR, " " x $optiondescoffset);
        &gsprintf(STDERR, "{PrintUsage.default}: $optiondefault\n");
    }

    # If the option has a list of possible values, display these
    my $optionvalueslist = $option->{'list'};
    if (defined($optionvalueslist)) {
        &gsprintf(STDERR, "\n");
        foreach my $optionvalue (@$optionvalueslist) {
        my $optionvaluename = $optionvalue->{'name'};
        &gsprintf(STDERR, " " x $optiondescoffset);
        &gsprintf(STDERR, "$optionvaluename:");

        my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});
        &display_text_in_column($optionvaluedesc, $optiondescoffset + 2,
                    $optiondescoffset + length($optionvaluename), 80);
        }
    }

#   # Special case for 'input_encoding'
#   if ($optionname =~ m/^input_encoding$/i) {
#       my $e = $encodings::encodings;
#       foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
#       &gsprintf(STDERR, " " x $optiondescoffset);
#       &gsprintf(STDERR, "$enc:");
#
#       my $encodingdesc = $e->{$enc}->{'name'};
#       &display_text_in_column($encodingdesc, $optiondescoffset + 2,
#                   $optiondescoffset + length("$enc:"), 80);
#       }
#   }

    # Add a blank line to separate options
    &gsprintf(STDERR, "\n");
    }
}


sub display_text_in_column
{
    my ($text, $columnbeg, $firstlineoffset, $columnend) = @_;

    # Spaces are put *before* words, so treat the column beginning as 1 smaller than it is
    $columnbeg = $columnbeg - 1;

    # Add some padding (if needed) for the first line
    my $linelength = $columnbeg;
    if ($firstlineoffset < $columnbeg) {
    &gsprintf(STDERR, " " x ($columnbeg - $firstlineoffset));
    }
    else {
    $linelength = $firstlineoffset;
    }

    # Break the text into words, and display one at a time
    my @words = split(/ /, $text);

    foreach my $word (@words) {
    # If printing this word would exceed the column end, start a new line
    if (($linelength + length($word)) >= $columnend) {
        &gsprintf(STDERR, "\n");
        &gsprintf(STDERR, " " x $columnbeg);
        $linelength = $columnbeg;
    }

    # Write the word
    &gsprintf(STDERR, " $word");
    $linelength = $linelength + length(" $word");
    }

    &gsprintf(STDERR, "\n");
}


sub find_longest_option_string
{
    my $options = shift(@_);

    my $maxlength = 0;
    foreach my $option (@$options) {
    my $optionname = $option->{'name'};
    my $optiontype = $option->{'type'};

    my $optionlength = length("  -$optionname");
    if ($optiontype ne "flag") {
        $optionlength = $optionlength + length(" <$optiontype>");
    }

    # Remember the longest
    if ($optionlength > $maxlength) {
        $maxlength = $optionlength;
    }
    }
    return $maxlength;
}


1;