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

Last change on this file since 12626 was 12626, checked in by mdewsnip, 16 years ago

Removed all the DTD stuff from XML output... it's just one more unnecessary thing to maintain.

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