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

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

can add internal => 'true' to plugin/classifier option, and it won't get printed out with pluginfo. use for internal options

  • 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 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
175 # this causes us to automatically send output to a pager, if one is
176 # set, AND our output is going to a terminal
177 # active state perl on windows doesn't do open(handle, "-|");
178 if ($ENV{'GSDLOS'} !~ /windows/ && -t STDOUT) {
179 my $pager = $ENV{"PAGER"};
180 if (! $pager) {$pager="(less || more)"}
181 my $pid = open(STDIN, "-|"); # this does a fork... see man perlipc(1)
182 if (!defined $pid) {
183 gsprintf(STDERR, "pluginfo.pl - can't fork: $!");
184 } else {
185 if ($pid != 0) { # parent (ie forking) process. child gets 0
186 exec ($pager);
187 }
188 }
189 open(STDERR,">&STDOUT"); # so it's easier to pipe output
190 }
191
192
193
194 my $programname = $options->{'name'};
195 my $programargs = $options->{'args'};
196 my $programdesc = $options->{'desc'};
197
198 # Find the length of the longest option string
199 my $descoffset = 0;
200 if (defined($programargs)) {
201 $descoffset = &find_longest_option_string($programargs);
202 }
203
204 # Produce the usage information using the data structure above
205 if (defined($programdesc)) {
206 &gsprintf(STDERR, $programname . ": $options->{'desc'}\n\n");
207 }
208
209 &gsprintf(STDERR, " {common.usage}: $programname $params\n\n");
210
211 # Display the program options, if there are some
212 if (defined($programargs)) {
213 # Calculate the column offset of the option descriptions
214 my $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
215
216 &gsprintf(STDERR, " {common.options}:\n");
217
218 # Display the program options
219 &print_options_txt($programargs, $optiondescoffset);
220 }
221}
222
223
224sub print_options_txt
225{
226 my $options = shift(@_);
227 my $optiondescoffset = shift(@_);
228
229 foreach my $option (@$options) {
230 next if defined($option->{'internal'});
231
232 # Display option name
233 my $optionname = $option->{'name'};
234 &gsprintf(STDERR, " -$optionname");
235 my $optionstringlength = length(" -$optionname");
236
237 # Display option type, if the option is not a flag
238 my $optiontype = $option->{'type'};
239 if ($optiontype ne "flag") {
240 &gsprintf(STDERR, " <$optiontype>");
241 $optionstringlength = $optionstringlength + length(" <$optiontype>");
242 }
243
244 # Display the option description
245 if (defined($option->{'disp'})) {
246 my $optiondisp = &gsprintf::lookup_string($option->{'disp'});
247 &display_text_in_column($optiondisp, $optiondescoffset, $optionstringlength, 80);
248 &gsprintf(STDERR, " " x $optionstringlength);
249 }
250 my $optiondesc = &gsprintf::lookup_string($option->{'desc'});
251 my $optionreqd = $option->{'reqd'};
252 if (defined($optionreqd) && $optionreqd eq "yes") {
253 $optiondesc = "(" . &gsprintf::lookup_string("{PrintUsage.required}") . ") " . $optiondesc;
254 }
255 &display_text_in_column($optiondesc, $optiondescoffset, $optionstringlength, 80);
256
257 # Show the default value for the option, if there is one
258 my $optiondefault = $option->{'deft'};
259 if (defined($optiondefault)) {
260 &gsprintf(STDERR, " " x $optiondescoffset);
261 &gsprintf(STDERR, "{PrintUsage.default}: $optiondefault\n");
262 }
263
264 # If the option has a list of possible values, display these
265 my $optionvalueslist = $option->{'list'};
266 if (defined($optionvalueslist)) {
267 &gsprintf(STDERR, "\n");
268 foreach my $optionvalue (@$optionvalueslist) {
269 my $optionvaluename = $optionvalue->{'name'};
270 &gsprintf(STDERR, " " x $optiondescoffset);
271 &gsprintf(STDERR, "$optionvaluename:");
272
273 my $optionvaluedesc = &gsprintf::lookup_string($optionvalue->{'desc'});
274 &display_text_in_column($optionvaluedesc, $optiondescoffset + 2,
275 $optiondescoffset + length($optionvaluename), 80);
276 }
277 }
278
279# # Special case for 'input_encoding'
280# if ($optionname =~ m/^input_encoding$/i) {
281# my $e = $encodings::encodings;
282# foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e)) {
283# &gsprintf(STDERR, " " x $optiondescoffset);
284# &gsprintf(STDERR, "$enc:");
285#
286# my $encodingdesc = $e->{$enc}->{'name'};
287# &display_text_in_column($encodingdesc, $optiondescoffset + 2,
288# $optiondescoffset + length("$enc:"), 80);
289# }
290# }
291
292 # Add a blank line to separate options
293 &gsprintf(STDERR, "\n");
294 }
295}
296
297
298sub display_text_in_column
299{
300 my ($text, $columnbeg, $firstlineoffset, $columnend) = @_;
301
302 # Spaces are put *before* words, so treat the column beginning as 1 smaller than it is
303 $columnbeg = $columnbeg - 1;
304
305 # Add some padding (if needed) for the first line
306 my $linelength = $columnbeg;
307 if ($firstlineoffset < $columnbeg) {
308 &gsprintf(STDERR, " " x ($columnbeg - $firstlineoffset));
309 }
310 else {
311 $linelength = $firstlineoffset;
312 }
313
314 # Break the text into words, and display one at a time
315 my @words = split(/ /, $text);
316
317 foreach my $word (@words) {
318 # If printing this word would exceed the column end, start a new line
319 if (($linelength + length($word)) >= $columnend) {
320 &gsprintf(STDERR, "\n");
321 &gsprintf(STDERR, " " x $columnbeg);
322 $linelength = $columnbeg;
323 }
324
325 # Write the word
326 &gsprintf(STDERR, " $word");
327 $linelength = $linelength + length(" $word");
328 }
329
330 &gsprintf(STDERR, "\n");
331}
332
333
334sub find_longest_option_string
335{
336 my $options = shift(@_);
337
338 my $maxlength = 0;
339 foreach my $option (@$options) {
340 my $optionname = $option->{'name'};
341 my $optiontype = $option->{'type'};
342
343 my $optionlength = length(" -$optionname");
344 if ($optiontype ne "flag") {
345 $optionlength = $optionlength + length(" <$optiontype>");
346 }
347
348 # Remember the longest
349 if ($optionlength > $maxlength) {
350 $maxlength = $optionlength;
351 }
352 }
353 return $maxlength;
354}
355
356
3571;
Note: See TracBrowser for help on using the repository browser.