source: gsdl/trunk/perllib/printusage.pm@ 20723

Last change on this file since 20723 was 20723, checked in by kjdon, 12 years ago

changed print_txt_usage to output the description if its defined in options. no longer needs an extra parameter to be set.

  • Property svn:keywords set to Author Date Id Revision
File size: 10.7 KB
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 my $optionname = $option->{'name'};
74 my $displayname = $option->{'disp'};
75
76 my $optiondesc = &gsprintf::lookup_string($option->{'desc'});
77
78 # Escape '<' and '>' characters
79 $optiondesc =~ s/</&amp;lt;/g; # doubly escaped
80 $optiondesc =~ s/>/&amp;gt;/g;
81
82 # Display option name, description and type
83 &gsprintf(STDERR, " <Option>\n");
84 &gsprintf(STDERR, " <Name>$optionname</Name>\n");
85 if (defined($option->{'disp'})) {
86 my $displayname = &gsprintf::lookup_string($option->{'disp'});
87 # Escape '<' and '>' characters
88 $displayname =~ s/</&amp;lt;/g; # doubly escaped
89 $displayname =~ s/>/&amp;gt;/g;
90 &gsprintf(STDERR, " <DisplayName>$displayname</DisplayName>\n");
91 }
92 &gsprintf(STDERR, " <Desc>$optiondesc</Desc>\n");
93 &gsprintf(STDERR, " <Type>$option->{'type'}</Type>\n");
94
95 # If the option has a required field, display this
96 if (defined($option->{'reqd'})) {
97 &gsprintf(STDERR, " <Required>$option->{'reqd'}</Required>\n");
98 }
99
100 # If the option has a charactor length field, display this
101 if (defined($option->{'char_length'})) {
102 &gsprintf(STDERR, " <CharactorLength>$option->{'char_length'}</CharactorLength>\n");
103 }
104
105 # If the option has a range field, display this
106 if (defined($option->{'range'})) {
107 &gsprintf(STDERR, " <Range>$option->{'range'}</Range>\n");
108 }
109
110 # If the option has a list of possible values, display these
111 if (defined $option->{'list'}) {
112 &gsprintf(STDERR, " <List>\n");
113 my $optionvalueslist = $option->{'list'};
114 foreach my $optionvalue (@$optionvalueslist) {
115 &gsprintf(STDERR, " <Value>\n");
116 &gsprintf(STDERR, " <Name>$optionvalue->{'name'}</Name>\n");
117 if (defined $optionvalue->{'desc'}) {
118 my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});
119
120 # Escape '<' and '>' characters
121 $optionvaluedesc =~ s/</&amp;lt;/g; #doubly escaped
122 $optionvaluedesc =~ s/>/&amp;gt;/g;
123
124 &gsprintf(STDERR, " <Desc>$optionvaluedesc</Desc>\n");
125 }
126 &gsprintf(STDERR, " </Value>\n");
127 }
128
129# # Special case for 'input_encoding'
130# if ($optionname =~ m/^input_encoding$/i) {
131# my $e = $encodings::encodings;
132# foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
133# &gsprintf(STDERR, " <Value>\n");
134# &gsprintf(STDERR, " <Name>$enc</Name>\n");
135# &gsprintf(STDERR, " <Desc>$e->{$enc}->{'name'}</Desc>\n");
136# &gsprintf(STDERR, " </Value>\n");
137# }
138# }
139
140 &gsprintf(STDERR, " </List>\n");
141 }
142
143 # Show the default value for the option, if there is one
144 if (defined $option->{'deft'}) {
145 my $optiondeftvalue = $option->{'deft'};
146
147 # Escape '<' and '>' characters
148 $optiondeftvalue =~ s/</&lt;/g;
149 $optiondeftvalue =~ s/>/&gt;/g;
150
151 &gsprintf(STDERR, " <Default>$optiondeftvalue</Default>\n");
152 }
153
154 # If the option is noted as being hidden in GLI, add that to the printout
155 if (defined($option->{'hiddengli'})) {
156 &gsprintf(STDERR, " <HiddenGLI>$option->{'hiddengli'}</HiddenGLI>\n");
157 }
158 # If the argument is not hidden then print out the lowest detail mode it is visible in
159 if (defined($option->{'modegli'})) {
160 &gsprintf(STDERR, " <ModeGLI>$option->{'modegli'}</ModeGLI>\n");
161 }
162
163 &gsprintf(STDERR, " </Option>\n");
164 }
165}
166
167
168sub print_txt_usage
169{
170 my $options = shift(@_);
171 my $params = shift(@_);
172
173 # this causes us to automatically send output to a pager, if one is
174 # set, AND our output is going to a terminal
175 # active state perl on windows doesn't do open(handle, "-|");
176 if ($ENV{'GSDLOS'} !~ /windows/ && -t STDOUT) {
177 my $pager = $ENV{"PAGER"};
178 if (! $pager) {$pager="(less || more)"}
179 my $pid = open(STDIN, "-|"); # this does a fork... see man perlipc(1)
180 if (!defined $pid) {
181 gsprintf(STDERR, "pluginfo.pl - can't fork: $!");
182 } else {
183 if ($pid != 0) { # parent (ie forking) process. child gets 0
184 exec ($pager);
185 }
186 }
187 open(STDERR,">&STDOUT"); # so it's easier to pipe output
188 }
189
190
191
192 my $programname = $options->{'name'};
193 my $programargs = $options->{'args'};
194 my $programdesc = $options->{'desc'};
195
196 # Find the length of the longest option string
197 my $descoffset = 0;
198 if (defined($programargs)) {
199 $descoffset = &find_longest_option_string($programargs);
200 }
201
202 # Produce the usage information using the data structure above
203 if (defined($programdesc)) {
204 &gsprintf(STDERR, $programname . ": $options->{'desc'}\n\n");
205 }
206
207 &gsprintf(STDERR, " {common.usage}: $programname $params\n\n");
208
209 # Display the program options, if there are some
210 if (defined($programargs)) {
211 # Calculate the column offset of the option descriptions
212 my $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
213
214 &gsprintf(STDERR, " {common.options}:\n");
215
216 # Display the program options
217 &print_options_txt($programargs, $optiondescoffset);
218 }
219}
220
221
222sub print_options_txt
223{
224 my $options = shift(@_);
225 my $optiondescoffset = shift(@_);
226
227 foreach my $option (@$options) {
228 # Display option name
229 my $optionname = $option->{'name'};
230 &gsprintf(STDERR, " -$optionname");
231 my $optionstringlength = length(" -$optionname");
232
233 # Display option type, if the option is not a flag
234 my $optiontype = $option->{'type'};
235 if ($optiontype ne "flag") {
236 &gsprintf(STDERR, " <$optiontype>");
237 $optionstringlength = $optionstringlength + length(" <$optiontype>");
238 }
239
240 # Display the option description
241 if (defined($option->{'disp'})) {
242 my $optiondisp = &gsprintf::lookup_string($option->{'disp'});
243 &display_text_in_column($optiondisp, $optiondescoffset, $optionstringlength, 80);
244 &gsprintf(STDERR, " " x $optionstringlength);
245 }
246 my $optiondesc = &gsprintf::lookup_string($option->{'desc'});
247 my $optionreqd = $option->{'reqd'};
248 if (defined($optionreqd) && $optionreqd eq "yes") {
249 $optiondesc = "(" . &gsprintf::lookup_string("{PrintUsage.required}") . ") " . $optiondesc;
250 }
251 &display_text_in_column($optiondesc, $optiondescoffset, $optionstringlength, 80);
252
253 # Show the default value for the option, if there is one
254 my $optiondefault = $option->{'deft'};
255 if (defined($optiondefault)) {
256 &gsprintf(STDERR, " " x $optiondescoffset);
257 &gsprintf(STDERR, "{PrintUsage.default}: $optiondefault\n");
258 }
259
260 # If the option has a list of possible values, display these
261 my $optionvalueslist = $option->{'list'};
262 if (defined($optionvalueslist)) {
263 &gsprintf(STDERR, "\n");
264 foreach my $optionvalue (@$optionvalueslist) {
265 my $optionvaluename = $optionvalue->{'name'};
266 &gsprintf(STDERR, " " x $optiondescoffset);
267 &gsprintf(STDERR, "$optionvaluename:");
268
269 my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});
270 &display_text_in_column($optionvaluedesc, $optiondescoffset + 2,
271 $optiondescoffset + length($optionvaluename), 80);
272 }
273 }
274
275# # Special case for 'input_encoding'
276# if ($optionname =~ m/^input_encoding$/i) {
277# my $e = $encodings::encodings;
278# foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
279# &gsprintf(STDERR, " " x $optiondescoffset);
280# &gsprintf(STDERR, "$enc:");
281#
282# my $encodingdesc = $e->{$enc}->{'name'};
283# &display_text_in_column($encodingdesc, $optiondescoffset + 2,
284# $optiondescoffset + length("$enc:"), 80);
285# }
286# }
287
288 # Add a blank line to separate options
289 &gsprintf(STDERR, "\n");
290 }
291}
292
293
294sub display_text_in_column
295{
296 my ($text, $columnbeg, $firstlineoffset, $columnend) = @_;
297
298 # Spaces are put *before* words, so treat the column beginning as 1 smaller than it is
299 $columnbeg = $columnbeg - 1;
300
301 # Add some padding (if needed) for the first line
302 my $linelength = $columnbeg;
303 if ($firstlineoffset < $columnbeg) {
304 &gsprintf(STDERR, " " x ($columnbeg - $firstlineoffset));
305 }
306 else {
307 $linelength = $firstlineoffset;
308 }
309
310 # Break the text into words, and display one at a time
311 my @words = split(/ /, $text);
312
313 foreach my $word (@words) {
314 # If printing this word would exceed the column end, start a new line
315 if (($linelength + length($word)) >= $columnend) {
316 &gsprintf(STDERR, "\n");
317 &gsprintf(STDERR, " " x $columnbeg);
318 $linelength = $columnbeg;
319 }
320
321 # Write the word
322 &gsprintf(STDERR, " $word");
323 $linelength = $linelength + length(" $word");
324 }
325
326 &gsprintf(STDERR, "\n");
327}
328
329
330sub find_longest_option_string
331{
332 my $options = shift(@_);
333
334 my $maxlength = 0;
335 foreach my $option (@$options) {
336 my $optionname = $option->{'name'};
337 my $optiontype = $option->{'type'};
338
339 my $optionlength = length(" -$optionname");
340 if ($optiontype ne "flag") {
341 $optionlength = $optionlength + length(" <$optiontype>");
342 }
343
344 # Remember the longest
345 if ($optionlength > $maxlength) {
346 $maxlength = $optionlength;
347 }
348 }
349 return $maxlength;
350}
351
352
3531;
Note: See TracBrowser for help on using the repository browser.