root/main/trunk/greenstone2/perllib/printusage.pm @ 29095

Revision 29095, 10.8 KB (checked in by kjdon, 5 years ago)

new argument to print_txt_usage. Pass 1 if you don't want the output paged. We use this when there has been an error and we are outputing the options before quitting the import/build. If the output is paged, then the die doesn't end up getting through to the top level program. So for full-rebuild, if the import died because of a parsing error, if the output had been paged, then the import was stopped but the system return value was 0, and then it would go on to the next stage, trying to build. So now, if we are stopping because of an error, then don't page the output.

  • Property svn:keywords set to Author Date Id Revision
Line 
1###########################################################################
2#
3# printusage.pm --
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26
27package PrintUsage;
28
29
30use gsprintf;
31use strict;
32no strict 'subs'; # allow barewords (eg STDERR) as function arguments
33
34
35sub gsprintf
36{
37    return &gsprintf::gsprintf(@_);
38}
39
40# this is not called by plugins or classifiers, just by scripts
41sub print_xml_usage
42{
43    my $options = shift(@_);
44
45    # XML output is always in UTF-8
46    &gsprintf::output_strings_in_UTF8;
47
48    &print_xml_header("script");
49
50    &gsprintf(STDERR, "<Info>\n");
51    &gsprintf(STDERR, "  <Name>$options->{'name'}</Name>\n");
52    &gsprintf(STDERR, "  <Desc>$options->{'desc'}</Desc>\n");
53    &gsprintf(STDERR, "  <Arguments>\n");
54    if (defined($options->{'args'})) {
55    &print_options_xml($options->{'args'});
56    }
57    &gsprintf(STDERR, "  </Arguments>\n");
58    &gsprintf(STDERR, "</Info>\n");
59}
60
61
62sub print_xml_header
63{
64    &gsprintf(STDERR, "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
65}
66
67
68sub print_options_xml
69{
70    my $options = shift(@_);
71
72    foreach my $option (@$options) {
73    next if defined($option->{'internal'});
74   
75    my $optionname = $option->{'name'};
76    my $displayname = $option->{'disp'};
77   
78    my $optiondesc = &gsprintf::lookup_string($option->{'desc'});
79
80    # Escape '<' and '>' characters
81    $optiondesc =~ s/</&amp;lt;/g; # doubly escaped
82    $optiondesc =~ s/>/&amp;gt;/g;
83
84    # Display option name, description and type
85    &gsprintf(STDERR, "    <Option>\n");
86    &gsprintf(STDERR, "      <Name>$optionname</Name>\n");
87    if (defined($option->{'disp'})) {
88        my $displayname = &gsprintf::lookup_string($option->{'disp'});
89        # Escape '<' and '>' characters
90        $displayname =~ s/</&amp;lt;/g; # doubly escaped
91        $displayname =~ s/>/&amp;gt;/g;
92        &gsprintf(STDERR, "      <DisplayName>$displayname</DisplayName>\n");
93    }
94    &gsprintf(STDERR, "      <Desc>$optiondesc</Desc>\n");
95    &gsprintf(STDERR, "      <Type>$option->{'type'}</Type>\n");
96
97    # If the option has a required field, display this
98    if (defined($option->{'reqd'})) {
99        &gsprintf(STDERR, "      <Required>$option->{'reqd'}</Required>\n");
100    }
101
102    # If the option has a charactor length field, display this
103    if (defined($option->{'char_length'})) {
104        &gsprintf(STDERR, "      <CharactorLength>$option->{'char_length'}</CharactorLength>\n");
105    }
106
107    # If the option has a range field, display this
108    if (defined($option->{'range'})) {
109        &gsprintf(STDERR, "      <Range>$option->{'range'}</Range>\n");
110    }
111
112    # If the option has a list of possible values, display these
113    if (defined $option->{'list'}) {
114        &gsprintf(STDERR, "      <List>\n");
115        my $optionvalueslist = $option->{'list'};
116        foreach my $optionvalue (@$optionvalueslist) {
117        &gsprintf(STDERR, "        <Value>\n");
118        &gsprintf(STDERR, "          <Name>$optionvalue->{'name'}</Name>\n");
119        if (defined $optionvalue->{'desc'}) {
120            my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});
121
122            # Escape '<' and '>' characters
123            $optionvaluedesc =~ s/</&amp;lt;/g; #doubly escaped
124            $optionvaluedesc =~ s/>/&amp;gt;/g;
125
126            &gsprintf(STDERR, "          <Desc>$optionvaluedesc</Desc>\n");
127        }
128        &gsprintf(STDERR, "        </Value>\n");
129        }
130
131#       # Special case for 'input_encoding'
132#       if ($optionname =~ m/^input_encoding$/i) {
133#       my $e = $encodings::encodings;
134#       foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
135#           &gsprintf(STDERR, "        <Value>\n");
136#           &gsprintf(STDERR, "          <Name>$enc</Name>\n");
137#           &gsprintf(STDERR, "          <Desc>$e->{$enc}->{'name'}</Desc>\n");
138#           &gsprintf(STDERR, "        </Value>\n");
139#       }
140#       }
141
142        &gsprintf(STDERR, "      </List>\n");
143    }
144
145    # Show the default value for the option, if there is one
146    if (defined $option->{'deft'}) {
147        my $optiondeftvalue = $option->{'deft'};
148
149        # Escape '<' and '>' characters
150        $optiondeftvalue =~ s/</&lt;/g;
151        $optiondeftvalue =~ s/>/&gt;/g;
152
153        &gsprintf(STDERR, "      <Default>$optiondeftvalue</Default>\n");
154    }
155
156    # If the option is noted as being hidden in GLI, add that to the printout
157    if (defined($option->{'hiddengli'})) {
158        &gsprintf(STDERR, "      <HiddenGLI>$option->{'hiddengli'}</HiddenGLI>\n");
159    }
160    # If the argument is not hidden then print out the lowest detail mode it is visible in
161    if (defined($option->{'modegli'})) {
162        &gsprintf(STDERR, "      <ModeGLI>$option->{'modegli'}</ModeGLI>\n");
163    }
164
165    &gsprintf(STDERR, "    </Option>\n");
166    }
167}
168
169
170sub print_txt_usage
171{
172    my $options = shift(@_);
173    my $params = shift(@_);
174    my $no_pager = shift(@_);
175
176    unless ($no_pager) {
177    # this causes us to automatically send output to a pager, if one is
178    # set, AND our output is going to a terminal
179    # active state perl on windows doesn't do open(handle, "-|");
180    if ($ENV{'GSDLOS'} !~ /windows/ && -t STDOUT) {
181        my $pager = $ENV{"PAGER"};
182    if (! $pager) {$pager="(less || more)"}
183    my $pid = open(STDIN, "-|"); # this does a fork... see man perlipc(1)
184    if (!defined $pid) {
185        gsprintf(STDERR, "pluginfo.pl - can't fork: $!");
186    } else {
187        if ($pid != 0) { # parent (ie forking) process. child gets 0
188        exec ($pager);
189        }
190    }
191    open(STDERR,">&STDOUT"); # so it's easier to pipe output
192    }
193    }
194
195
196    my $programname = $options->{'name'};
197    my $programargs = $options->{'args'};
198    my $programdesc = $options->{'desc'};
199
200    # Find the length of the longest option string
201    my $descoffset = 0;
202    if (defined($programargs)) {
203    $descoffset = &find_longest_option_string($programargs);
204    }
205
206    # Produce the usage information using the data structure above
207    if (defined($programdesc)) {
208    &gsprintf(STDERR, $programname . ": $options->{'desc'}\n\n");
209    }
210
211    &gsprintf(STDERR, " {common.usage}: $programname $params\n\n");
212
213    # Display the program options, if there are some
214    if (defined($programargs)) {
215    # Calculate the column offset of the option descriptions
216    my $optiondescoffset = $descoffset + 2;  # 2 spaces between options & descriptions
217
218    &gsprintf(STDERR, " {common.options}:\n");
219
220    # Display the program options
221    &print_options_txt($programargs, $optiondescoffset);
222    }
223}
224
225
226sub print_options_txt
227{
228    my $options = shift(@_);
229    my $optiondescoffset = shift(@_);
230
231    foreach my $option (@$options) {
232    next if defined($option->{'internal'});
233
234    # Display option name
235    my $optionname = $option->{'name'};
236    &gsprintf(STDERR, "  -$optionname");
237    my $optionstringlength = length("  -$optionname");
238
239    # Display option type, if the option is not a flag
240    my $optiontype = $option->{'type'};
241    if ($optiontype ne "flag") {
242        &gsprintf(STDERR, " <$optiontype>");
243        $optionstringlength = $optionstringlength + length(" <$optiontype>");
244    }
245
246    # Display the option description   
247    if (defined($option->{'disp'})) {
248        my $optiondisp = &gsprintf::lookup_string($option->{'disp'});
249        &display_text_in_column($optiondisp, $optiondescoffset, $optionstringlength, 80);
250        &gsprintf(STDERR, " " x $optionstringlength);
251    }
252    my $optiondesc = &gsprintf::lookup_string($option->{'desc'});
253    my $optionreqd = $option->{'reqd'};
254    if (defined($optionreqd) && $optionreqd eq "yes") {
255        $optiondesc = "(" . &gsprintf::lookup_string("{PrintUsage.required}") . ") " . $optiondesc;
256    }
257    &display_text_in_column($optiondesc, $optiondescoffset, $optionstringlength, 80);
258
259    # Show the default value for the option, if there is one
260    my $optiondefault = $option->{'deft'};
261    if (defined($optiondefault)) {
262        &gsprintf(STDERR, " " x $optiondescoffset);
263        &gsprintf(STDERR, "{PrintUsage.default}: $optiondefault\n");
264    }
265
266    # If the option has a list of possible values, display these
267    my $optionvalueslist = $option->{'list'};
268    if (defined($optionvalueslist)) {
269        &gsprintf(STDERR, "\n");
270        foreach my $optionvalue (@$optionvalueslist) {
271        my $optionvaluename = $optionvalue->{'name'};
272        &gsprintf(STDERR, " " x $optiondescoffset);
273        &gsprintf(STDERR, "$optionvaluename:");
274
275        my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});
276        &display_text_in_column($optionvaluedesc, $optiondescoffset + 2,
277                    $optiondescoffset + length($optionvaluename), 80);
278        }
279    }
280
281#   # Special case for 'input_encoding'
282#   if ($optionname =~ m/^input_encoding$/i) {
283#       my $e = $encodings::encodings;
284#       foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
285#       &gsprintf(STDERR, " " x $optiondescoffset);
286#       &gsprintf(STDERR, "$enc:");
287#
288#       my $encodingdesc = $e->{$enc}->{'name'};
289#       &display_text_in_column($encodingdesc, $optiondescoffset + 2,
290#                   $optiondescoffset + length("$enc:"), 80);
291#       }
292#   }
293
294    # Add a blank line to separate options
295    &gsprintf(STDERR, "\n");
296    }
297}
298
299
300sub display_text_in_column
301{
302    my ($text, $columnbeg, $firstlineoffset, $columnend) = @_;
303
304    # Spaces are put *before* words, so treat the column beginning as 1 smaller than it is
305    $columnbeg = $columnbeg - 1;
306
307    # Add some padding (if needed) for the first line
308    my $linelength = $columnbeg;
309    if ($firstlineoffset < $columnbeg) {
310    &gsprintf(STDERR, " " x ($columnbeg - $firstlineoffset));
311    }
312    else {
313    $linelength = $firstlineoffset;
314    }
315
316    # Break the text into words, and display one at a time
317    my @words = split(/ /, $text);
318
319    foreach my $word (@words) {
320    # If printing this word would exceed the column end, start a new line
321    if (($linelength + length($word)) >= $columnend) {
322        &gsprintf(STDERR, "\n");
323        &gsprintf(STDERR, " " x $columnbeg);
324        $linelength = $columnbeg;
325    }
326
327    # Write the word
328    &gsprintf(STDERR, " $word");
329    $linelength = $linelength + length(" $word");
330    }
331
332    &gsprintf(STDERR, "\n");
333}
334
335
336sub find_longest_option_string
337{
338    my $options = shift(@_);
339
340    my $maxlength = 0;
341    foreach my $option (@$options) {
342    my $optionname = $option->{'name'};
343    my $optiontype = $option->{'type'};
344
345    my $optionlength = length("  -$optionname");
346    if ($optiontype ne "flag") {
347        $optionlength = $optionlength + length(" <$optiontype>");
348    }
349
350    # Remember the longest
351    if ($optionlength > $maxlength) {
352        $maxlength = $optionlength;
353    }
354    }
355    return $maxlength;
356}
357
358
3591;
Note: See TracBrowser for help on using the browser.