1 | #! /usr/bin/perl
|
---|
2 |
|
---|
3 | ##################################################################################
|
---|
4 | # #
|
---|
5 | # expand_macros.pl -- recursively expand greenstone macros / 1080805 - 1230106 #
|
---|
6 | # #
|
---|
7 | # Copyright (C) 2005,2006 Jens Wille <j_wille at gmx.net> #
|
---|
8 | # #
|
---|
9 | # This program is free software; you can redistribute it and/or #
|
---|
10 | # modify it under the terms of the GNU General Public License #
|
---|
11 | # as published by the Free Software Foundation; either version 2 #
|
---|
12 | # of the License, or (at your option) any later version. #
|
---|
13 | # #
|
---|
14 | # This program is distributed in the hope that it will be useful, #
|
---|
15 | # but WITHOUT ANY WARRANTY; without even the implied warranty of #
|
---|
16 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the #
|
---|
17 | # GNU General Public License for more details. #
|
---|
18 | # #
|
---|
19 | # You should have received a copy of the GNU General Public License #
|
---|
20 | # along with this program; if not, write to the Free Software #
|
---|
21 | # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. #
|
---|
22 | # #
|
---|
23 | ##################################################################################
|
---|
24 |
|
---|
25 | #
|
---|
26 | # expand_macros.pl reads in specified greenstone macro files and prints the
|
---|
27 | # definitions of requested macros and recursively the definitions of macros
|
---|
28 | # used within these definitions.
|
---|
29 | #
|
---|
30 | #
|
---|
31 | # FEATURES:
|
---|
32 | #
|
---|
33 | # - generic:
|
---|
34 | #
|
---|
35 | # - additional/collection-specific macro files can be included
|
---|
36 | #
|
---|
37 | # - macros set within the server can be included (though this might not be
|
---|
38 | # of much help without reading the respective source file)
|
---|
39 | #
|
---|
40 | # - "interactive browse mode" where you can select which macro (and from which
|
---|
41 | # package) to display next.
|
---|
42 | #
|
---|
43 | # - readline support and persistent history
|
---|
44 | #
|
---|
45 | # - interactive commands
|
---|
46 | #
|
---|
47 | # - read files from within interactive browse mode
|
---|
48 | #
|
---|
49 | # - batch mode only:
|
---|
50 | #
|
---|
51 | # - search for macros that use certain macros ("reverse" search)
|
---|
52 | #
|
---|
53 | # - search for strings (regular expressions) in macro definitions
|
---|
54 | #
|
---|
55 | #
|
---|
56 | # TODO:
|
---|
57 | #
|
---|
58 | # - add "reverse search" and "string search" for browse mode
|
---|
59 | #
|
---|
60 | # - handle macro options better (v, c, l, ...?)
|
---|
61 | #
|
---|
62 | # - implement some kind of "persistent" macro db (so that it doesn't need to be
|
---|
63 | # built each and every time)
|
---|
64 | #
|
---|
65 | #
|
---|
66 | # KNOWN ISSUES:
|
---|
67 | #
|
---|
68 | # - for a sufficiently large file (> 12288 bytes == 12 k) (paged-)read will quit
|
---|
69 | # the program if not scrolled until the end of the file => SIGPIPE: broken pipe!
|
---|
70 | # SOLVED: the PIPE signal will simply be IGNOREd
|
---|
71 | #
|
---|
72 |
|
---|
73 | use strict;
|
---|
74 | use warnings;
|
---|
75 |
|
---|
76 | use Getopt::Long qw(GetOptions);
|
---|
77 |
|
---|
78 | use File::Basename qw(basename dirname);
|
---|
79 | use File::Spec::Functions qw(catdir catfile curdir);
|
---|
80 |
|
---|
81 | use IO::Handle qw(autoflush);
|
---|
82 | STDOUT->autoflush(1);
|
---|
83 |
|
---|
84 | use Term::ReadLine;
|
---|
85 |
|
---|
86 |
|
---|
87 | ### progname and version
|
---|
88 |
|
---|
89 | my $NAME = basename $0;
|
---|
90 | my $VERSION = '0.22';
|
---|
91 |
|
---|
92 |
|
---|
93 | ### global patterns
|
---|
94 |
|
---|
95 | # my understanding of greenstone macro names:
|
---|
96 | # - enclosed in underscores ('_')
|
---|
97 | # - starts with a letter ([:alpha:])
|
---|
98 | # - followed by alphanumeric characters ([:alnum:])
|
---|
99 | # (consequently, it doesn't start with a number and
|
---|
100 | # particularly isn't a macro parameter, i.e. something like _1_)
|
---|
101 | # - also we might need to take care of escaped underscores ('\_')
|
---|
102 | #
|
---|
103 | # => does this fit??? (see '<gsdl-source>/src/lib/display.cpp' for details,
|
---|
104 | # in particular the 'displayclass::loadparammacros' method)
|
---|
105 | my $MACRO_PATTERN = '[[:alpha:]][[:alnum:]]*';
|
---|
106 |
|
---|
107 | # package names: letters
|
---|
108 | my $PACKAGE_NAME = '[[:alpha:]]+';
|
---|
109 |
|
---|
110 | # package specification: package name followed by a colon (':')
|
---|
111 | my $PACKAGE_PATTERN = $PACKAGE_NAME . ':';
|
---|
112 |
|
---|
113 | # beginning/end of macro specification: underscore ('_'), not escaped,
|
---|
114 | # i.e. not preceded by a backslash ('\')
|
---|
115 | # (need to double-escape backslash here!)
|
---|
116 | my $MACRO_AFFIX = '(?<!\\\)_';
|
---|
117 |
|
---|
118 | # beginning of macro definition: opening curly bracket ('{')
|
---|
119 | my $DEFINITION_START = '\{';
|
---|
120 |
|
---|
121 | # end of macro definition: closing curly bracket ('}'), not escaped,
|
---|
122 | # i.e. not preceded by a backslash ('\')
|
---|
123 | # (need to double-escape backslash here!)
|
---|
124 | my $DEFINITION_END = '(?<!\\\)\}';
|
---|
125 |
|
---|
126 | # package declaration: 'package' (plus package name)
|
---|
127 | my $PACKAGE_DECLARATION = 'package';
|
---|
128 |
|
---|
129 |
|
---|
130 | ### command line arguments
|
---|
131 |
|
---|
132 | # variable initialisation and default values
|
---|
133 | my %ARG = (
|
---|
134 | 'verbose' => 0,
|
---|
135 | 'version' => 0,
|
---|
136 | 'depth' => 0,
|
---|
137 | 'short' => 0,
|
---|
138 | 'reverse' => 0,
|
---|
139 | 'interactive' => 0,
|
---|
140 | 'paged' => 0,
|
---|
141 | 'pager' => $ENV{'PAGER'} || 'less',
|
---|
142 | 'histfile' => catfile($ENV{'HOME'} || curdir, '.expand_macros.history'),
|
---|
143 | 'histsize' => 100,
|
---|
144 | 'macro_dirs' => [catdir($ENV{'GSDLHOME'}, 'macros')],
|
---|
145 | 'source_dir' => $ENV{'GSDLSOURCE'} || '',
|
---|
146 | 'args' => []
|
---|
147 | );
|
---|
148 |
|
---|
149 | # global vars
|
---|
150 | my $TERM = '';
|
---|
151 | my $CURRENT_FILE = '';
|
---|
152 |
|
---|
153 | # usage information and help text
|
---|
154 | my $USAGE = <<HERE_USAGE;
|
---|
155 | usage:
|
---|
156 | $NAME [generic-options] [-s] [-d <depth>] [-r] {_[<package>:]<macro>_|<query>} ...
|
---|
157 | $NAME [generic-options] {-b|-i} [-p]
|
---|
158 | $NAME [-h|-?|--help]
|
---|
159 |
|
---|
160 | generic options are: [-v] [-e <directory>,...] [-n <version>]
|
---|
161 | HERE_USAGE
|
---|
162 |
|
---|
163 | my $HELP = <<HERE_HELP;
|
---|
164 | $NAME: recursively expand greenstone macros (v$VERSION)
|
---|
165 |
|
---|
166 | $USAGE
|
---|
167 |
|
---|
168 | generic options:
|
---|
169 |
|
---|
170 | -h, -?, --help display this help and exit
|
---|
171 | -v, --verbose output some extra information/warnings
|
---|
172 |
|
---|
173 | {-e|--extra} <directory>,... paths to extra macro directories, comma-separated list
|
---|
174 | [default directory: '$ARG{'macro_dirs'}[0]']
|
---|
175 |
|
---|
176 | --source <directory> path to greenstone source directory, so that macros which are
|
---|
177 | set within the server will be included
|
---|
178 | [default: '$ARG{'source_dir'}']
|
---|
179 | NOTE: you can set an environment variable GSDLSOURCE instead
|
---|
180 |
|
---|
181 | {-n|--show-version} <version> print only macro definitions for specified version (0=graphic/1=text)
|
---|
182 | [default: '$ARG{'version'}', set to '-1' for 'all']
|
---|
183 |
|
---|
184 | -s, --short short output, i.e. only macro names, no content
|
---|
185 |
|
---|
186 |
|
---|
187 | batch mode:
|
---|
188 |
|
---|
189 | {-d|--depth} <depth> how deep to recurse through macros
|
---|
190 | [default: '$ARG{'depth'}', set to '-1' for 'unlimited']
|
---|
191 |
|
---|
192 | -r, --reverse reverse search, recursively outputs the macros which use the specified macro
|
---|
193 |
|
---|
194 | all non-option arguments will be treated as
|
---|
195 | - macro names (denoted by surrounding underscores '_')
|
---|
196 | or
|
---|
197 | - regular expressions to search for in macro definitions (otherwise)
|
---|
198 |
|
---|
199 | (you can restrict your macro name query to a certain package by prepending the macro name with '<package-name>:')
|
---|
200 |
|
---|
201 | EXAMPLES:
|
---|
202 |
|
---|
203 | get definition of the 'pagescriptextra' macro
|
---|
204 | > $NAME _pagescriptextra_
|
---|
205 |
|
---|
206 | get definition of the 'pagescriptextra' macro, package 'query' only
|
---|
207 | > $NAME _query:pagescriptextra_
|
---|
208 |
|
---|
209 | get definition of the 'pagescriptextra' macro, package 'query' only -- and recursively get definitions of
|
---|
210 | macros used within that definition (up to level 2)
|
---|
211 | > $NAME -d 2 _query:pagescriptextra_
|
---|
212 |
|
---|
213 | get all the macros that use the 'pagescriptextra' macro (names only)
|
---|
214 | > $NAME -r -s _pagescriptextra_
|
---|
215 |
|
---|
216 |
|
---|
217 | interactive browse mode:
|
---|
218 |
|
---|
219 | -b, -i, --browse interactive browse mode, allows you to select what to display next
|
---|
220 |
|
---|
221 | -p, --paged data output will be passed to a pager
|
---|
222 | [default: '$ARG{'pager'}']
|
---|
223 | --pager <pager> pass paged output to specified pager instead of above named default
|
---|
224 |
|
---|
225 | --histfile <file> path to history file to keep history between sessions
|
---|
226 | [default: '$ARG{'histfile'}']
|
---|
227 | --histsize <num> maximum number of lines to keep in histfile
|
---|
228 | [default: '$ARG{'histsize'}']
|
---|
229 | NOTE: in case you don\'t want the history to be stored you may set
|
---|
230 | <histfile> to '' or <histsize> to '0'
|
---|
231 | (however, this does not remove any existing history files)
|
---|
232 |
|
---|
233 |
|
---|
234 | NOTE: for this script to run your greenstone environment needs to be set up (GSDLHOME set)
|
---|
235 | HERE_HELP
|
---|
236 |
|
---|
237 | my $HELP_INTERACTIVE = <<HERE_HELP;
|
---|
238 | $NAME: expand greenstone macros in ***interactive browse mode*** (v$VERSION)
|
---|
239 |
|
---|
240 |
|
---|
241 | usage instructions:
|
---|
242 |
|
---|
243 | - commands are equal to command line options, except that they start with a dot '.'
|
---|
244 | (NOTE: not all command line options are available as commands, see list below)
|
---|
245 |
|
---|
246 | - commands that take an optional argument ([...]) will print their current value if
|
---|
247 | that argument is omitted (you can also use '.c' or '.config' to get a full overview)
|
---|
248 |
|
---|
249 | - you can run several commands at once by separating them with semicolons
|
---|
250 |
|
---|
251 | - you can quit the program at any time by hitting <ctrl>+d (<ctrl>+z on windows), or
|
---|
252 | by typing '.q', or '.quit'
|
---|
253 |
|
---|
254 |
|
---|
255 | commands:
|
---|
256 |
|
---|
257 | .h, .?, .help display this help
|
---|
258 |
|
---|
259 | .q, .quit exit program
|
---|
260 |
|
---|
261 | . redisplay current stage
|
---|
262 |
|
---|
263 | .. return to previous stage (same as leaving empty)
|
---|
264 |
|
---|
265 | ..., .t, .top return to top to enter new macro name
|
---|
266 |
|
---|
267 | {.n|.show-version} [<version>] print only macro definitions for specified version (0=graphic/1=text)
|
---|
268 | [default: '0', set to '-1' for 'all']
|
---|
269 |
|
---|
270 | .s, .short short output, i.e. only macro names, no content
|
---|
271 |
|
---|
272 | .p, .paged data output will be passed to a pager
|
---|
273 | [default: '$ARG{'pager'}']
|
---|
274 | .pager [<pager>] pass paged output to specified pager instead of above named default
|
---|
275 |
|
---|
276 | .r, .read [<file>] display the contents of the specified file (by default the last file we came across)
|
---|
277 | .pr, .paged-read [<file>] same, but paged (without turning on paged mode permanently)
|
---|
278 |
|
---|
279 | .c, .config display current configuration
|
---|
280 | HERE_HELP
|
---|
281 |
|
---|
282 | # allow for bundling of options
|
---|
283 | Getopt::Long::Configure ("bundling");
|
---|
284 |
|
---|
285 | # parse arguments
|
---|
286 | GetOptions( 'help|h|?' => sub { print "$HELP\n"; exit 0 },
|
---|
287 | 'verbose|v' => \$ARG{'verbose'},
|
---|
288 | 'only-version|n=i' => \$ARG{'version'},
|
---|
289 | 'extra|e=s' => \@{$ARG{'macro_dirs'}},
|
---|
290 | 'source=s' => \$ARG{'source_dir'},
|
---|
291 | 'depth|d=i' => \$ARG{'depth'},
|
---|
292 | 'short|s' => \$ARG{'short'},
|
---|
293 | 'reverse|r' => \$ARG{'reverse'},
|
---|
294 | 'browse|b|i' => \$ARG{'interactive'},
|
---|
295 | 'paged|p' => \$ARG{'paged'},
|
---|
296 | 'pager=s' => \$ARG{'pager'},
|
---|
297 | 'histfile=s' => \$ARG{'histfile'},
|
---|
298 | 'histsize=i' => \$ARG{'histsize'},
|
---|
299 | '<>' => sub { push(@{$ARG{'args'}} => @_) } )
|
---|
300 | or die "$USAGE\n";
|
---|
301 |
|
---|
302 |
|
---|
303 | ### some sanity checks (dunno which one to check first ;-)
|
---|
304 |
|
---|
305 | # need one of our "actions": batch, query or interactive
|
---|
306 | # ("batch" requiring at least one macro name or regexp specified)
|
---|
307 | unless (@{$ARG{'args'}} || $ARG{'interactive'}) {
|
---|
308 | warn "$USAGE";
|
---|
309 |
|
---|
310 | warn <<HERE_WARN unless $ENV{'GSDLHOME'};
|
---|
311 |
|
---|
312 | GSDLHOME not set!
|
---|
313 |
|
---|
314 | for this script to run your greenstone environment needs to be set up. please
|
---|
315 | change into the directory where greenstone has been installed and run/source
|
---|
316 | the appropriate setup script.
|
---|
317 | HERE_WARN
|
---|
318 |
|
---|
319 | die "\n";
|
---|
320 | }
|
---|
321 |
|
---|
322 | # need GSDLHOME for default macro directory
|
---|
323 | # (does also allow to have the script in gsdl bin path)
|
---|
324 | die "GSDLHOME not set! please change into the directory where greenstone has been installed and run/source the appropriate setup script.\n"
|
---|
325 | unless $ENV{'GSDLHOME'};
|
---|
326 |
|
---|
327 | ## need one of our "actions": batch, query or interactive
|
---|
328 | # ("batch" requiring at least one macro name or regexp specified)
|
---|
329 | #die "$USAGE\n"
|
---|
330 | # unless @{$ARG{'args'}} || $ARG{'interactive'};
|
---|
331 |
|
---|
332 |
|
---|
333 | ### action!
|
---|
334 |
|
---|
335 | # build hash of macro information
|
---|
336 | my %macro_db = build_db();
|
---|
337 | die "macro db empty!\n"
|
---|
338 | unless %macro_db;
|
---|
339 |
|
---|
340 | unless ($ARG{'interactive'}) {
|
---|
341 | # batch mode
|
---|
342 |
|
---|
343 | my $n = 0;
|
---|
344 | foreach my $arg (@{$ARG{'args'}}) {
|
---|
345 | if ($arg =~ s/^$MACRO_AFFIX((?:$PACKAGE_PATTERN)?$MACRO_PATTERN)$MACRO_AFFIX$/$1/) {
|
---|
346 | # macro
|
---|
347 |
|
---|
348 | print "*** macro: $arg", ($ARG{'reverse'} ? ' (reverse) ' : ' '), "***\n\n";
|
---|
349 |
|
---|
350 | unless ($ARG{'reverse'}) {
|
---|
351 | # "normal" search
|
---|
352 |
|
---|
353 | get_macro($arg);
|
---|
354 | }
|
---|
355 | else {
|
---|
356 | # "reverse" search
|
---|
357 |
|
---|
358 | # get the macros that use the specified macro
|
---|
359 | my @refs = get_r_macros($arg);
|
---|
360 | print "no macro referencing '$arg'\n\n"
|
---|
361 | unless @refs;
|
---|
362 |
|
---|
363 | # now recurse those macros
|
---|
364 | get_macro($_)
|
---|
365 | foreach @refs;
|
---|
366 | }
|
---|
367 | }
|
---|
368 | else {
|
---|
369 | # query
|
---|
370 |
|
---|
371 | print "*** query: $arg", ($ARG{'reverse'} ? ' (reverse) ' : ' '), "***\n\n";
|
---|
372 |
|
---|
373 | # get the macros that match the specified query
|
---|
374 | my @macros = get_r_macros($arg, 1);
|
---|
375 | print "no matches for '$arg'\n", ($ARG{'short'} ? '' : "\n")
|
---|
376 | unless @macros;
|
---|
377 |
|
---|
378 | # now print those macros
|
---|
379 | get_macro($_)
|
---|
380 | foreach @macros;
|
---|
381 | }
|
---|
382 |
|
---|
383 | # print separator _between_ requested macros (i.e. everytime but the last time)
|
---|
384 | # (need to add extra newline for short display)
|
---|
385 | print(($ARG{'short'} ? "\n" : ''), '-' x 80, "\n\n")
|
---|
386 | unless ++$n >= @{$ARG{'args'}};
|
---|
387 | }
|
---|
388 | }
|
---|
389 | else {
|
---|
390 | # interactive browse mode
|
---|
391 |
|
---|
392 | # ignore 'broken pipe' error
|
---|
393 | $SIG{'PIPE'} = 'IGNORE';
|
---|
394 |
|
---|
395 | # get the pager executable (no need to test if not in "paged" mode)
|
---|
396 | get_pager()
|
---|
397 | if $ARG{'paged'};
|
---|
398 |
|
---|
399 | # create new Term::ReadLine object
|
---|
400 | $TERM = Term::ReadLine->new($NAME);
|
---|
401 |
|
---|
402 | # don't want the prompt underlined
|
---|
403 | $TERM->ornaments(0);
|
---|
404 | # don't want autohistory (can't set autohistory explicitly, so use this "workaround")
|
---|
405 | $TERM->MinLine(undef);
|
---|
406 |
|
---|
407 | # restore history
|
---|
408 | readhist();
|
---|
409 |
|
---|
410 | # print help hint
|
---|
411 | print <<HERE_HINT;
|
---|
412 | entered '$NAME' in ***interactive browse mode*** (v$VERSION)
|
---|
413 | [you can get help at any time by typing '.h', '.?', or '.help']
|
---|
414 |
|
---|
415 | HERE_HINT
|
---|
416 |
|
---|
417 | # repeat until explicit exit
|
---|
418 | while (1) {
|
---|
419 | my $macro = prompt("enter macro name (without package specification) [leave empty to quit]\n> ");
|
---|
420 |
|
---|
421 | # remove surrounding '_'
|
---|
422 | $macro =~ s/^_//;
|
---|
423 | $macro =~ s/_$//;
|
---|
424 |
|
---|
425 | exit 0 unless length $macro; # normal exit
|
---|
426 | next if $macro eq '0' || $macro eq '-1'; # a command was executed
|
---|
427 |
|
---|
428 | # now get all packages for given macro, and begin recursion...
|
---|
429 | recurse_packages($macro);
|
---|
430 | }
|
---|
431 |
|
---|
432 | # can't expect anything down here to be executed
|
---|
433 | }
|
---|
434 |
|
---|
435 | END {
|
---|
436 | if ($ARG{'interactive'}) {
|
---|
437 | # save history
|
---|
438 | savehist();
|
---|
439 | }
|
---|
440 | }
|
---|
441 |
|
---|
442 |
|
---|
443 | ### that's it ;-)
|
---|
444 |
|
---|
445 | exit 0;
|
---|
446 |
|
---|
447 |
|
---|
448 | ### subroutines
|
---|
449 |
|
---|
450 | # <sub build_db>
|
---|
451 | # build hash of macro information ("macro db")
|
---|
452 | #
|
---|
453 | # hash structure:
|
---|
454 | # macro
|
---|
455 | # -> package
|
---|
456 | # -> {'0=graphic'|'1=text'}
|
---|
457 | # -> 'file'
|
---|
458 | # -> 'line'
|
---|
459 | # -> 'content'
|
---|
460 | #
|
---|
461 | # usage:
|
---|
462 | # %macro_db = build_db()
|
---|
463 | #
|
---|
464 | # => macro_db: returned hash ("macro db")
|
---|
465 | #
|
---|
466 | sub build_db {
|
---|
467 | my %macro_db = ();
|
---|
468 | my @dm_list = ();
|
---|
469 | my ($n, $m) = (0, 0);
|
---|
470 |
|
---|
471 | # get all macro files (*.dm) from specified directories
|
---|
472 | foreach my $dir (@{$ARG{'macro_dirs'}}) {
|
---|
473 | opendir(DIR, "$dir")
|
---|
474 | or die "can't read macro directory '$dir': $!\n";
|
---|
475 |
|
---|
476 | push(@dm_list => map { $_ = catfile($dir, $_) } grep { /\.dm$/ } readdir(DIR));
|
---|
477 |
|
---|
478 | closedir DIR;
|
---|
479 | }
|
---|
480 |
|
---|
481 | # now parse each macro file and build hash
|
---|
482 | foreach my $dm (sort @dm_list) {
|
---|
483 | open(DM, "< $dm")
|
---|
484 | or die "can't open macro file '$dm': $!\n";
|
---|
485 |
|
---|
486 | my ($name, $content, $version, $curpkg, $contd)
|
---|
487 | = ('', '', '0', '', 0);
|
---|
488 |
|
---|
489 | while (my $line = <DM>) {
|
---|
490 | chomp($line);
|
---|
491 | next unless length $line; # skip empty lines
|
---|
492 | next if $line =~ /^\s*$/; # skip "empty" lines
|
---|
493 | next if $line =~ /^\s*#/; # skip comments (hope this doesn't affect
|
---|
494 | # cases we actually wanted to keep)
|
---|
495 |
|
---|
496 | if ($line =~ /^$PACKAGE_DECLARATION\s*($PACKAGE_NAME)/) {
|
---|
497 | # remember the current package we are in
|
---|
498 | $curpkg = $1;
|
---|
499 | }
|
---|
500 | elsif ($line =~ /$MACRO_AFFIX($MACRO_PATTERN)$MACRO_AFFIX\s*(\[v=1\])?\s*$DEFINITION_START\s*(.*)/) {
|
---|
501 | # start of macro definition
|
---|
502 | $n++;
|
---|
503 |
|
---|
504 | $name = $1;
|
---|
505 | $version = (defined $2 && $2 eq '[v=1]') ? '1' : '0';
|
---|
506 | $content = $3 || '';
|
---|
507 |
|
---|
508 | # don't include unnecessary version, unless we're interactive (where version may change during session)
|
---|
509 | next if $ARG{'version'} ne '-1' && $version ne $ARG{'version'} && ! $ARG{'interactive'};
|
---|
510 |
|
---|
511 | if (exists $macro_db{$name}->{$curpkg}->{$version}) {
|
---|
512 | # everytime a macro definition already exists, it's simply
|
---|
513 | # overwritten - but we can give a warning
|
---|
514 | # (this might also serve debugging purposes)
|
---|
515 | $m++;
|
---|
516 |
|
---|
517 | warn <<HERE_WARN if $ARG{'verbose'};
|
---|
518 | duplicate definition of macro '$curpkg:$name' [v=$version] at '$dm', line $.
|
---|
519 | (previously defined at $macro_db{$name}->{$curpkg}->{$version}->{'file'}, line $macro_db{$name}->{$curpkg}->{$version}->{'line'})
|
---|
520 | HERE_WARN
|
---|
521 | }
|
---|
522 |
|
---|
523 | # store the information we got so far
|
---|
524 | $macro_db{$name}->{$curpkg}->{$version}->{'file'} = $dm;
|
---|
525 | $macro_db{$name}->{$curpkg}->{$version}->{'line'} = $.;
|
---|
526 | $macro_db{$name}->{$curpkg}->{$version}->{'content'} = [$content] if length $content;
|
---|
527 |
|
---|
528 | # is the macro definition already finished?
|
---|
529 | $contd = ($content =~ s/\s*$DEFINITION_END.*//) ? 0 : 1;
|
---|
530 | }
|
---|
531 | elsif ($contd) {
|
---|
532 | # continuation of macro definition
|
---|
533 |
|
---|
534 | # store additional content
|
---|
535 | push(@{$macro_db{$name}->{$curpkg}->{$version}->{'content'}} => $line);
|
---|
536 |
|
---|
537 | # is the macro definition already finished?
|
---|
538 | $contd = ($line =~ s/\s*$DEFINITION_END.*//) ? 0 : 1;
|
---|
539 | }
|
---|
540 | else {
|
---|
541 | # something else...
|
---|
542 |
|
---|
543 | ($name, $content) = ('', '');
|
---|
544 | }
|
---|
545 | }
|
---|
546 |
|
---|
547 | close DM;
|
---|
548 | }
|
---|
549 |
|
---|
550 | # get server macros (overwriting already read macros)
|
---|
551 | if (length $ARG{'source_dir'}) {
|
---|
552 | if (-r $ARG{'source_dir'}) {
|
---|
553 | my $recpt_dir = catdir($ARG{'source_dir'}, 'src', 'src', 'recpt');
|
---|
554 | my @cpp_list = ();
|
---|
555 |
|
---|
556 | opendir(DIR, "$recpt_dir")
|
---|
557 | or die "can't read receptionist's source directory '$recpt_dir': $!\n";
|
---|
558 |
|
---|
559 | push(@cpp_list => map { $_ = catfile($recpt_dir, $_) } grep { /\.cpp$/ } readdir(DIR));
|
---|
560 |
|
---|
561 | close DIR;
|
---|
562 |
|
---|
563 | foreach my $cpp (@cpp_list) {
|
---|
564 | open(CPP, "< $cpp")
|
---|
565 | or die "can't open source file '$cpp': $!\n";
|
---|
566 |
|
---|
567 | my $args = '';
|
---|
568 | my $contd = 0;
|
---|
569 | while (my $line = <CPP>) {
|
---|
570 | next unless $line =~ /disp\.setmacro\s*\((.*)/ || $contd;
|
---|
571 |
|
---|
572 | unless (defined $1) {
|
---|
573 | $contd = 1;
|
---|
574 | next;
|
---|
575 | }
|
---|
576 |
|
---|
577 | my $string = $1;
|
---|
578 |
|
---|
579 | if ($string =~ s/\);\s*$//) {
|
---|
580 | $args .= $string;
|
---|
581 | my ($name, $package, $value) = split(/\s*,\s*/ => $args, 3);
|
---|
582 |
|
---|
583 | $name =~ s/^\s*["']?//;
|
---|
584 | $name =~ s/["']?\s*$//;
|
---|
585 | $package =~ s/^\s*["']?//;
|
---|
586 | $package =~ s/["']?\s*$//;
|
---|
587 |
|
---|
588 | $package = 'Global'
|
---|
589 | if $package eq 'displayclass::defaultpackage';
|
---|
590 |
|
---|
591 | $macro_db{$name}->{$package}->{'0'}->{'file'} = 'SERVER: ' . $cpp;
|
---|
592 | $macro_db{$name}->{$package}->{'0'}->{'line'} = $.;
|
---|
593 | $macro_db{$name}->{$package}->{'0'}->{'content'} = [$value];
|
---|
594 |
|
---|
595 | $args = '';
|
---|
596 | ++$n;
|
---|
597 | $contd = 0;
|
---|
598 | }
|
---|
599 | elsif ($contd) {
|
---|
600 | $args .= ' ' . $string;
|
---|
601 | }
|
---|
602 | else {
|
---|
603 | $contd = 1;
|
---|
604 | }
|
---|
605 | }
|
---|
606 |
|
---|
607 | close CPP;
|
---|
608 | }
|
---|
609 | }
|
---|
610 | else {
|
---|
611 | warn "can't find source directory '$ARG{'source_dir'}'! server macros will not be included\n";
|
---|
612 | }
|
---|
613 | }
|
---|
614 |
|
---|
615 | # print some statistics
|
---|
616 | print "$n total macro definitions, $m duplicates\n"
|
---|
617 | if $ARG{'verbose'};
|
---|
618 |
|
---|
619 | # we stored all information there is so we can return it
|
---|
620 | return %macro_db;
|
---|
621 | }
|
---|
622 | # </sub build_db>
|
---|
623 |
|
---|
624 | # <sub get_macro>
|
---|
625 | # recursively print macro information
|
---|
626 | #
|
---|
627 | # usage:
|
---|
628 | # get_macro($macro[, $level])
|
---|
629 | #
|
---|
630 | # macro: macro name (optionally including package specification)
|
---|
631 | # level: recursion level (optional)
|
---|
632 | #
|
---|
633 | # => VOID CONTEXT
|
---|
634 | #
|
---|
635 | sub get_macro {
|
---|
636 | my ($macro, $level) = @_;
|
---|
637 | $level ||= 0;
|
---|
638 |
|
---|
639 | # indent output according to recursion level
|
---|
640 | my $indent = ' ' x $level;
|
---|
641 |
|
---|
642 | # get all the packages which our macro is defined in
|
---|
643 | ($macro, my @packages) = get_packages($macro, $indent);
|
---|
644 | return unless @packages;
|
---|
645 |
|
---|
646 | # macro definitions may occur in several packages so we display them all
|
---|
647 | # (unless a certain package was explicitly specified)
|
---|
648 | foreach my $pkg (@packages) {
|
---|
649 | foreach my $version (sort keys %{$macro_db{$macro}->{$pkg}}) {
|
---|
650 | print "$indent* $pkg:$macro [v=$version] ($macro_db{$macro}->{$pkg}->{$version}->{'file'}, line $macro_db{$macro}->{$pkg}->{$version}->{'line'})\n";
|
---|
651 |
|
---|
652 | my $content = '';
|
---|
653 | # some macros are defined, but don't have any content
|
---|
654 | if (defined $macro_db{$macro}->{$pkg}->{$version}->{'content'}) {
|
---|
655 | # for batch display we condense the output a little bit...
|
---|
656 | map { s/^\s*//; s/\s*$// } @{$macro_db{$macro}->{$pkg}->{$version}->{'content'}};
|
---|
657 | # ...and put it on a single line
|
---|
658 | $content = join(' ' => @{$macro_db{$macro}->{$pkg}->{$version}->{'content'}});
|
---|
659 | }
|
---|
660 | print "$indent { $content }\n\n"
|
---|
661 | unless $ARG{'short'};
|
---|
662 | # short display only, i.e. no content
|
---|
663 | # of the macro's definition
|
---|
664 |
|
---|
665 | # only go (deeper) into referenced macros if we
|
---|
666 | # haven't reached the specified recursion level
|
---|
667 | if ($ARG{'depth'} eq '-1' || $level < $ARG{'depth'}) {
|
---|
668 | # get (referencing|referenced) macros...
|
---|
669 | my @refs = $ARG{'reverse'}
|
---|
670 | ? get_r_macros($macro)
|
---|
671 | : get_macros($content);
|
---|
672 |
|
---|
673 | # ...and recurse above them (with increased recursion level)
|
---|
674 | foreach my $ref (@refs) {
|
---|
675 | get_macro($ref, $level + 1);
|
---|
676 | }
|
---|
677 | }
|
---|
678 | }
|
---|
679 | }
|
---|
680 | }
|
---|
681 | # </sub get_macro>
|
---|
682 |
|
---|
683 | # <sub get_macros>
|
---|
684 | # returns a list of macros extracted from a content string
|
---|
685 | # or a boolean value if a macro name was specified
|
---|
686 | #
|
---|
687 | # usage:
|
---|
688 | # @macros = get_macros($content)
|
---|
689 | # $boolean = get_macros($content, $macro)
|
---|
690 | #
|
---|
691 | # content: content string
|
---|
692 | # macro: macro name
|
---|
693 | #
|
---|
694 | # => macros: list of macros
|
---|
695 | # => boolean: boolean value (true = 1 / false = empty list)
|
---|
696 | #
|
---|
697 | sub get_macros {
|
---|
698 | my ($content, $macro) = @_;
|
---|
699 | my @macro_list = ();
|
---|
700 | my %seen = ();
|
---|
701 |
|
---|
702 | # get each macro reference in the string
|
---|
703 | # (for macro name considerations see above)
|
---|
704 | while ($content =~ /$MACRO_AFFIX((?:$PACKAGE_PATTERN)?$MACRO_PATTERN)$MACRO_AFFIX/g) {
|
---|
705 | my $m = $1;
|
---|
706 |
|
---|
707 | # we want to skip some macros that have no content anyway (defined
|
---|
708 | # from within the server) - unless we're doing a "reverse" search
|
---|
709 | next if $seen{$m}++ || ($m =~ /^(cgiarg.*|histvalue\d+|if|httpimg|httpweb|gwcgi|(decoded)?compressedoptions)$/i
|
---|
710 | && ! $ARG{'reverse'});
|
---|
711 |
|
---|
712 | if (defined $macro) {
|
---|
713 | # is this the macro we wanted? then the current
|
---|
714 | # macro uses it => return true
|
---|
715 | return 1 if $m =~ /^(?:$PACKAGE_PATTERN)?$macro$/;
|
---|
716 | }
|
---|
717 | else {
|
---|
718 | # add macro to our list
|
---|
719 | push(@macro_list => $m);
|
---|
720 | }
|
---|
721 | }
|
---|
722 |
|
---|
723 | # return the list of used macros
|
---|
724 | # (this evaluates to false (empty list) if there are no further
|
---|
725 | # macro calls or if this macro doesn't use the sought-after macro)
|
---|
726 | return sort @macro_list;
|
---|
727 | }
|
---|
728 | # </sub get_macros>
|
---|
729 |
|
---|
730 | # <sub get_r_macros>
|
---|
731 | # returns a list of macro names which reference ("use") the
|
---|
732 | # specified macro or match the query
|
---|
733 | #
|
---|
734 | # usage:
|
---|
735 | # @macros = get_r_macros($macro)
|
---|
736 | # @macros = get_r_macros($query, $is_query)
|
---|
737 | #
|
---|
738 | # macro: macro name
|
---|
739 | # query: query string (regular expression)
|
---|
740 | # is_query: boolean value to indicate whether arg is a query or a macro
|
---|
741 | #
|
---|
742 | # => macros: list of macros
|
---|
743 | #
|
---|
744 | sub get_r_macros {
|
---|
745 | my ($arg, $query) = @_;
|
---|
746 | $query ||= 0;
|
---|
747 | my %refs = ();
|
---|
748 |
|
---|
749 | # need to test each single macro's...
|
---|
750 | foreach my $m (sort keys %macro_db) {
|
---|
751 | # ...each single package
|
---|
752 | foreach my $p (sort keys %{$macro_db{$m}}) {
|
---|
753 | foreach my $v (sort keys %{$macro_db{$m}->{$p}}) {
|
---|
754 | my $pm = "$p:$m"; # include package information in the macro name!
|
---|
755 |
|
---|
756 | # does this macro have any content?
|
---|
757 | if (defined $macro_db{$m}->{$p}->{$v}->{'content'}) {
|
---|
758 | # stringify content!
|
---|
759 | my $content = join(' ' => @{$macro_db{$m}->{$p}->{$v}->{'content'}});
|
---|
760 |
|
---|
761 | if ($query) {
|
---|
762 | # search regexp
|
---|
763 | $refs{$pm}++ if $content =~ /$arg/;
|
---|
764 | }
|
---|
765 | else {
|
---|
766 | # search macro
|
---|
767 | $refs{$pm}++ if get_macros($content, $arg);
|
---|
768 | }
|
---|
769 | }
|
---|
770 | }
|
---|
771 | }
|
---|
772 | }
|
---|
773 |
|
---|
774 | # now we have all the macros which use our sought-after
|
---|
775 | return sort keys %refs;
|
---|
776 | }
|
---|
777 | # </sub get_r_macros>
|
---|
778 |
|
---|
779 | # <sub recurse_packages>
|
---|
780 | # recurse all packages for a given macro
|
---|
781 | #
|
---|
782 | # usage:
|
---|
783 | # recurse_packages($macro)
|
---|
784 | #
|
---|
785 | # macro: macro name (any package specification will be dropped)
|
---|
786 | #
|
---|
787 | # => VOID CONTEXT
|
---|
788 | #
|
---|
789 | sub recurse_packages {
|
---|
790 | my ($macro) = @_;
|
---|
791 |
|
---|
792 | # repeat until explicit break/exit
|
---|
793 | while (1) {
|
---|
794 | # get all the packages which our macro is defined in
|
---|
795 | #($macro, my @packages) = get_packages($macro);
|
---|
796 | #return unless @packages;
|
---|
797 | my @packages = ();
|
---|
798 |
|
---|
799 | my $n = 0;
|
---|
800 | my $package = '';
|
---|
801 | # ask for user's selection...
|
---|
802 | do {
|
---|
803 | # get all the packages which our macro is defined in
|
---|
804 | ($macro, @packages) = get_packages($macro);
|
---|
805 | return unless @packages;
|
---|
806 |
|
---|
807 | # ask for user's selection...
|
---|
808 | print "select package for macro '$macro' [leave empty to return]\n";
|
---|
809 | foreach my $pkg (@packages) {
|
---|
810 | printf " [%d]%s %s\n", ++$n, " " x (4 - length $n), $pkg;
|
---|
811 | }
|
---|
812 | $package = prompt();
|
---|
813 | $n = 0;
|
---|
814 | # ...until we return...
|
---|
815 | } until ($package eq '' || $package eq '-1'
|
---|
816 | # ...or a valid number is provided
|
---|
817 | || ($package =~ /^\d+$/ && $package > 0 && $package <= @packages));
|
---|
818 |
|
---|
819 | return unless length $package; # return to previous stage
|
---|
820 | return '-1' if $package eq '-1'; # return to top
|
---|
821 |
|
---|
822 | # set selected package
|
---|
823 | $package = $packages[$package - 1];
|
---|
824 |
|
---|
825 | foreach my $version (sort keys %{$macro_db{$macro}->{$package}}) {
|
---|
826 | # all versions
|
---|
827 | next unless $ARG{'version'} eq '-1'
|
---|
828 | # desired version
|
---|
829 | || $version eq $ARG{'version'}
|
---|
830 | # fallback to 'graphic'
|
---|
831 | || ($version eq '0' && ! exists $macro_db{$macro}->{$package}->{'1'});
|
---|
832 |
|
---|
833 | # some macros are defined, but don't have any content
|
---|
834 | my $content = defined $macro_db{$macro}->{$package}->{$version}->{'content'}
|
---|
835 | # now we want to retain the original structure
|
---|
836 | ? join("\n" => @{$macro_db{$macro}->{$package}->{$version}->{'content'}})
|
---|
837 | : '';
|
---|
838 |
|
---|
839 | ($CURRENT_FILE = $macro_db{$macro}->{$package}->{$version}->{'file'}) =~ s/^SERVER: //;
|
---|
840 |
|
---|
841 | my $content_string = "* $package:$macro [v=$version] ($macro_db{$macro}->{$package}->{$version}->{'file'}, line $macro_db{$macro}->{$package}->{$version}->{'line'})\n";
|
---|
842 | $content_string .= "{ $content }\n"
|
---|
843 | unless $ARG{'short'};
|
---|
844 |
|
---|
845 | print_output($content_string);
|
---|
846 |
|
---|
847 | # now on to the macros referenced within this one
|
---|
848 | my $return = recurse_macros($content);
|
---|
849 |
|
---|
850 | return $return if defined $return;
|
---|
851 | }
|
---|
852 | }
|
---|
853 | }
|
---|
854 | # </sub recurse_packages>
|
---|
855 |
|
---|
856 | # <sub get_packages>
|
---|
857 | # returns list of packages for specified macro, also returns
|
---|
858 | # modified macro name (without surrounding '_' and package specification)
|
---|
859 | #
|
---|
860 | # usage:
|
---|
861 | # ($macro, @packages) = get_packages($macro)
|
---|
862 | #
|
---|
863 | # macro: macro name
|
---|
864 | #
|
---|
865 | # => macro: modified macro name
|
---|
866 | # => packages: list of packages
|
---|
867 | #
|
---|
868 | sub get_packages {
|
---|
869 | my ($macro, $indent) = @_;
|
---|
870 | $indent ||= '';
|
---|
871 |
|
---|
872 | # save original macro name (including package specification)
|
---|
873 | my $omacro = $macro;
|
---|
874 |
|
---|
875 | my @packages = ();
|
---|
876 |
|
---|
877 | if ($macro =~ /^($PACKAGE_PATTERN)?$MACRO_PATTERN$/) {
|
---|
878 | # valid macro name
|
---|
879 |
|
---|
880 | # strip off package specification
|
---|
881 | my $package = ($macro =~ s/^($PACKAGE_NAME)://) ? $1 : '';
|
---|
882 |
|
---|
883 | if (exists $macro_db{$macro}) {
|
---|
884 | # valid/existing macro
|
---|
885 |
|
---|
886 | unless ($ARG{'interactive'}) {
|
---|
887 | if (length $package) {
|
---|
888 | # account for package specification
|
---|
889 |
|
---|
890 | @packages = ($package)
|
---|
891 | if exists $macro_db{$macro}->{$package};
|
---|
892 | }
|
---|
893 | else {
|
---|
894 | # get all packages otherwise
|
---|
895 |
|
---|
896 | @packages = sort keys %{$macro_db{$macro}};
|
---|
897 | }
|
---|
898 | }
|
---|
899 | else {
|
---|
900 | foreach my $pkg (sort keys %{$macro_db{$macro}}) {
|
---|
901 | push(@packages => $pkg)
|
---|
902 | # all versions
|
---|
903 | if $ARG{'version'} eq '-1'
|
---|
904 | # desired version
|
---|
905 | || exists $macro_db{$macro}->{$pkg}->{$ARG{'version'}}
|
---|
906 | # fallback to 'graphic'
|
---|
907 | || exists $macro_db{$macro}->{$pkg}->{'0'};
|
---|
908 | }
|
---|
909 | }
|
---|
910 | }
|
---|
911 | }
|
---|
912 | else {
|
---|
913 | # invalid macro name
|
---|
914 |
|
---|
915 | warn "invalid macro name '$macro'!\n";
|
---|
916 | return; # skip it
|
---|
917 | }
|
---|
918 |
|
---|
919 | # no packages - no definition
|
---|
920 | unless (@packages) {
|
---|
921 | print "$indent- $omacro\n$indent no definition for macro!\n\n";
|
---|
922 | return; # skip it
|
---|
923 | }
|
---|
924 |
|
---|
925 | # return modified macro name and packages found
|
---|
926 | return $macro, sort @packages;
|
---|
927 | }
|
---|
928 | # </sub get_packages>
|
---|
929 |
|
---|
930 | # <sub recurse_macros>
|
---|
931 | # recurse all macros for a given content string
|
---|
932 | #
|
---|
933 | # usage:
|
---|
934 | # recurse_macros($content)
|
---|
935 | #
|
---|
936 | # content: content string
|
---|
937 | #
|
---|
938 | # => VOID CONTEXT
|
---|
939 | #
|
---|
940 | sub recurse_macros {
|
---|
941 | my ($content) = @_;
|
---|
942 |
|
---|
943 | # repeat until explicit break/exit
|
---|
944 | while (1) {
|
---|
945 | # get all the macros referenced within the current one
|
---|
946 | my @macros = get_macros($content);
|
---|
947 | return unless @macros;
|
---|
948 |
|
---|
949 | my $n = 0;
|
---|
950 | my $macro = '';
|
---|
951 | # ask for user's selection...
|
---|
952 | do {
|
---|
953 | print "select macro [leave empty to return]\n";
|
---|
954 | foreach my $m (@macros) {
|
---|
955 | printf " [%d]%s %s\n", ++$n, " " x (4 - length $n), $m;
|
---|
956 | }
|
---|
957 | $macro = prompt();
|
---|
958 | $n = 0;
|
---|
959 | # ...until we return...
|
---|
960 | } until ($macro eq '' || $macro eq '-1'
|
---|
961 | # ...or a valid number is provided
|
---|
962 | || ($macro =~ /^\d+$/ && $macro > 0 && $macro <= @macros));
|
---|
963 |
|
---|
964 | return unless length $macro; # return to previous stage
|
---|
965 | return '-1' if $macro eq '-1'; # return to top
|
---|
966 |
|
---|
967 | # set selected macro
|
---|
968 | $macro = $macros[$macro - 1];
|
---|
969 |
|
---|
970 | # now we want all the macro's packages again
|
---|
971 | my $return = recurse_packages($macro);
|
---|
972 |
|
---|
973 | return $return if defined $return;
|
---|
974 | }
|
---|
975 | }
|
---|
976 | # </sub recurse_macros>
|
---|
977 |
|
---|
978 | # <sub prompt>
|
---|
979 | # prompt for user input
|
---|
980 | #
|
---|
981 | # usage:
|
---|
982 | # $reply = prompt([$prompt])
|
---|
983 | #
|
---|
984 | # prompt: optional prompt (default: '> ')
|
---|
985 | #
|
---|
986 | # => reply: user input
|
---|
987 | #
|
---|
988 | sub prompt {
|
---|
989 | my $prompt = shift || '> ';
|
---|
990 | my $term = $TERM;
|
---|
991 |
|
---|
992 | # read user input
|
---|
993 | my $reply = $term->readline($prompt);
|
---|
994 |
|
---|
995 | if (defined $reply) {
|
---|
996 | # add input to history, unless it's just a number
|
---|
997 | $term->addhistory($reply)
|
---|
998 | if $reply =~ /[[:alpha:]]/;
|
---|
999 |
|
---|
1000 | if ($reply =~ s/^\s*["']*\s*\././) {
|
---|
1001 | # execute command
|
---|
1002 | my $return = parse_command($reply);
|
---|
1003 |
|
---|
1004 | return $return if defined $return;
|
---|
1005 | }
|
---|
1006 | else {
|
---|
1007 | return $reply;
|
---|
1008 | }
|
---|
1009 | }
|
---|
1010 |
|
---|
1011 | # allow for exiting by hitting <ctrl>+d,
|
---|
1012 | # or quitting by command (.q, .quit)
|
---|
1013 | die "\n";
|
---|
1014 | }
|
---|
1015 | # </sub prompt>
|
---|
1016 |
|
---|
1017 | # <sub print_output>
|
---|
1018 | # print output, paged or not
|
---|
1019 | #
|
---|
1020 | # usage:
|
---|
1021 | # print_output($output)
|
---|
1022 | # print_output(@output)
|
---|
1023 | #
|
---|
1024 | # output: text to print
|
---|
1025 | #
|
---|
1026 | # => VOID CONTEXT
|
---|
1027 | #
|
---|
1028 | sub print_output {
|
---|
1029 | my $output = join('' => @_);
|
---|
1030 |
|
---|
1031 | if ($ARG{'paged'}) {
|
---|
1032 | # pass output to pager
|
---|
1033 | open(PAGER, "| $ARG{'pager'}")
|
---|
1034 | or die "can't open pipe to '$ARG{'pager'}': $!";
|
---|
1035 |
|
---|
1036 | print PAGER "$output";
|
---|
1037 |
|
---|
1038 | close PAGER;
|
---|
1039 | }
|
---|
1040 | else {
|
---|
1041 | # print to standard out...
|
---|
1042 | print "\n$output\n";
|
---|
1043 |
|
---|
1044 | # ...and wait for user reaction to continue
|
---|
1045 | wait_for_user();
|
---|
1046 | }
|
---|
1047 | }
|
---|
1048 | # </sub print_output>
|
---|
1049 |
|
---|
1050 | # <sub wait_for_user>
|
---|
1051 | # wait for user reaction to continue
|
---|
1052 | #
|
---|
1053 | # usage:
|
---|
1054 | # wait_for_user()
|
---|
1055 | #
|
---|
1056 | # => VOID CONTEXT
|
---|
1057 | #
|
---|
1058 | sub wait_for_user {
|
---|
1059 | print "[press key to continue]";
|
---|
1060 | print "\n" if <STDIN>;
|
---|
1061 | }
|
---|
1062 | # </sub wait_for_user>
|
---|
1063 |
|
---|
1064 | # <sub parse_command>
|
---|
1065 | # prompt for user input
|
---|
1066 | #
|
---|
1067 | # usage:
|
---|
1068 | # parse_command($command_line)
|
---|
1069 | #
|
---|
1070 | # command_line: command string
|
---|
1071 | #
|
---|
1072 | # => VOID CONTEXT
|
---|
1073 | #
|
---|
1074 | sub parse_command {
|
---|
1075 | my $command_line = shift;
|
---|
1076 | my @commands = split(/\s*;\s*/ => $command_line);
|
---|
1077 |
|
---|
1078 | my $return = 0;
|
---|
1079 |
|
---|
1080 | foreach my $command (@commands) {
|
---|
1081 | my $msg = "command executed: '$command'";
|
---|
1082 |
|
---|
1083 | $command =~ s/^\.//;
|
---|
1084 | $command =~ s/^(\w+)["']*/$1/;
|
---|
1085 | $command =~ s/\s*$//;
|
---|
1086 |
|
---|
1087 | if ($command =~ /^(h|\?|help)$/) {
|
---|
1088 | print "$HELP_INTERACTIVE\n";
|
---|
1089 |
|
---|
1090 | # wait for user reaction to continue
|
---|
1091 | wait_for_user();
|
---|
1092 |
|
---|
1093 | next;
|
---|
1094 | }
|
---|
1095 | elsif ($command =~ /^(q|quit)$/) {
|
---|
1096 | return undef;
|
---|
1097 | }
|
---|
1098 | elsif ($command =~ /^(\.)$/) {
|
---|
1099 | $return = '';
|
---|
1100 |
|
---|
1101 | next;
|
---|
1102 | }
|
---|
1103 | elsif ($command =~ /^(\..|t|top)$/) {
|
---|
1104 | $return = '-1';
|
---|
1105 |
|
---|
1106 | next;
|
---|
1107 | }
|
---|
1108 | elsif ($command =~ /^(n|show-version)(?:\s+["']*(0|1|-1)["']*)?$/) {
|
---|
1109 | $ARG{'version'} = $2
|
---|
1110 | if defined $2;
|
---|
1111 |
|
---|
1112 | $msg = "'version' " . (defined $2 ? '' : 'is currently ') . "set to: '$ARG{'version'}'";
|
---|
1113 | }
|
---|
1114 | elsif ($command =~ /^(s|short)$/) {
|
---|
1115 | $ARG{'short'} = ! $ARG{'short'};
|
---|
1116 |
|
---|
1117 | $msg = "'short' output " . ($ARG{'short'} ? 'en' : 'dis') . "abled";
|
---|
1118 | }
|
---|
1119 | elsif ($command =~ /^(p|paged)$/) {
|
---|
1120 | $ARG{'pager'} = get_pager();
|
---|
1121 | $ARG{'paged'} = ! $ARG{'paged'}
|
---|
1122 | if -x $ARG{'pager'};
|
---|
1123 |
|
---|
1124 | $msg = "'paged' output " . ($ARG{'paged'} ? 'en' : 'dis') . "abled";
|
---|
1125 | }
|
---|
1126 | elsif ($command =~ /^(pager)(?:\s+["']*(\w+)["']*)?$/) {
|
---|
1127 | $ARG{'pager'} = get_pager($2)
|
---|
1128 | if defined $2;
|
---|
1129 |
|
---|
1130 | $msg = "'pager' " . (defined $2 ? '' : 'is currently ') . "set to: '$ARG{'pager'}'";
|
---|
1131 | }
|
---|
1132 | elsif ($command =~ /^(p|paged-)?(r|read)(?:\s+(["']?.+["']?))?$/) {
|
---|
1133 | my $paged = $1 || '';
|
---|
1134 | my $file = $3 || $CURRENT_FILE;
|
---|
1135 | $CURRENT_FILE = $file;
|
---|
1136 |
|
---|
1137 | if (-r $file) {
|
---|
1138 | open(FILE, "< $file")
|
---|
1139 | or die "can't open file '$file': $!\n";
|
---|
1140 |
|
---|
1141 | my @lines = <FILE>;
|
---|
1142 |
|
---|
1143 | close FILE;
|
---|
1144 |
|
---|
1145 | my $previous_paged = $ARG{'paged'};
|
---|
1146 | $ARG{'paged'} = 1 if $paged;
|
---|
1147 |
|
---|
1148 | #print_output("$file:\n\n", @lines);
|
---|
1149 | print_output(@lines);
|
---|
1150 |
|
---|
1151 | $ARG{'paged'} = $previous_paged;
|
---|
1152 |
|
---|
1153 | next;
|
---|
1154 | }
|
---|
1155 |
|
---|
1156 | $msg = "can't find file '$file'";
|
---|
1157 | }
|
---|
1158 | elsif ($command =~ /^(c|config)$/) {
|
---|
1159 | my $short = $ARG{'short'} ? 'enabled' : 'disabled';
|
---|
1160 | my $paged = $ARG{'paged'} ? 'enabled' : 'disabled';
|
---|
1161 |
|
---|
1162 | $msg = <<HERE_MSG;
|
---|
1163 | current configuration for '$NAME - interactive browse mode':
|
---|
1164 |
|
---|
1165 | 'version': $ARG{'version'}
|
---|
1166 | 'short' output: $short
|
---|
1167 | 'paged' output: $paged
|
---|
1168 | 'pager': $ARG{'pager'}
|
---|
1169 | current file: $CURRENT_FILE
|
---|
1170 | HERE_MSG
|
---|
1171 | }
|
---|
1172 | elsif (length $command) {
|
---|
1173 | $msg = "invalid command: .$command";
|
---|
1174 | }
|
---|
1175 | else {
|
---|
1176 | # probably the '.' command
|
---|
1177 | $return = 0;
|
---|
1178 |
|
---|
1179 | next;
|
---|
1180 | }
|
---|
1181 |
|
---|
1182 | print "% $msg\n";
|
---|
1183 | }
|
---|
1184 |
|
---|
1185 | return $return;
|
---|
1186 | }
|
---|
1187 | # </sub parse_command>
|
---|
1188 |
|
---|
1189 | # <sub readhist>
|
---|
1190 | # read history from histfile
|
---|
1191 | #
|
---|
1192 | # usage:
|
---|
1193 | # readhist();
|
---|
1194 | #
|
---|
1195 | # => VOID CONTEXT
|
---|
1196 | #
|
---|
1197 | sub readhist {
|
---|
1198 | my $term = $TERM;
|
---|
1199 |
|
---|
1200 | if (-r $ARG{'histfile'}) {
|
---|
1201 | open(HIST, "< $ARG{'histfile'}")
|
---|
1202 | or die "can't open histfile '$ARG{'histfile'}': $!\n";
|
---|
1203 |
|
---|
1204 | while (<HIST>) {
|
---|
1205 | chomp;
|
---|
1206 | $term->AddHistory($_);
|
---|
1207 | }
|
---|
1208 |
|
---|
1209 | close HIST;
|
---|
1210 |
|
---|
1211 | warn "history restored from '$ARG{'histfile'}'\n"
|
---|
1212 | if $ARG{'verbose'};
|
---|
1213 | }
|
---|
1214 | else {
|
---|
1215 | warn "history could not be restored (maybe no/wrong history file specified)\n"
|
---|
1216 | if $ARG{'verbose'};
|
---|
1217 | }
|
---|
1218 | }
|
---|
1219 | # </sub readhist>
|
---|
1220 |
|
---|
1221 | # <sub savehist>
|
---|
1222 | # save history to histfile
|
---|
1223 | #
|
---|
1224 | # usage:
|
---|
1225 | # savehist();
|
---|
1226 | #
|
---|
1227 | # => VOID CONTEXT
|
---|
1228 | #
|
---|
1229 | sub savehist {
|
---|
1230 | return unless length $ARG{'histfile'} && $ARG{'histsize'};
|
---|
1231 |
|
---|
1232 | my $term = $TERM;
|
---|
1233 |
|
---|
1234 | return unless length $term;
|
---|
1235 |
|
---|
1236 | if (-w $ARG{'histfile'} || (! -e $ARG{'histfile'} && -w dirname $ARG{'histfile'})) {
|
---|
1237 | my @history = $term->GetHistory;
|
---|
1238 |
|
---|
1239 | # drop (consecutive) duplicate entries
|
---|
1240 | my @unified = ();
|
---|
1241 | my $previous = '';
|
---|
1242 | foreach my $element (@history) {
|
---|
1243 | push(@unified => $element)
|
---|
1244 | unless $element eq $previous;
|
---|
1245 | $previous = $element;
|
---|
1246 | }
|
---|
1247 | @history = @unified;
|
---|
1248 |
|
---|
1249 | # cut history to specified maximum number of entries
|
---|
1250 | splice(@history, 0, @history - $ARG{'histsize'})
|
---|
1251 | if @history > $ARG{'histsize'};
|
---|
1252 |
|
---|
1253 | open(HIST, "> $ARG{'histfile'}")
|
---|
1254 | or die "can't open history file '$ARG{'histfile'}' for writing: $!\n";
|
---|
1255 |
|
---|
1256 | {
|
---|
1257 | local $, = "\n";
|
---|
1258 |
|
---|
1259 | print HIST @history, "";
|
---|
1260 | }
|
---|
1261 |
|
---|
1262 | close HIST;
|
---|
1263 |
|
---|
1264 | warn "history written to '$ARG{'histfile'}'\n"
|
---|
1265 | if $ARG{'verbose'};
|
---|
1266 | }
|
---|
1267 | else {
|
---|
1268 | warn "history could not be written (maybe no history file specified, or history file not writable)\n"
|
---|
1269 | if $ARG{'verbose'};
|
---|
1270 | }
|
---|
1271 | }
|
---|
1272 | # </sub savehist>
|
---|
1273 |
|
---|
1274 | # <sub get_pager>
|
---|
1275 | # get pager executable
|
---|
1276 | #
|
---|
1277 | # usage:
|
---|
1278 | # $pager = get_pager([$candidate]);
|
---|
1279 | #
|
---|
1280 | # canidate: candidate for pager executable (defaulting to $ARG{'pager'})
|
---|
1281 | #
|
---|
1282 | # => pager: pager executable
|
---|
1283 | #
|
---|
1284 | sub get_pager {
|
---|
1285 | my $candidate = shift || $ARG{'pager'};
|
---|
1286 |
|
---|
1287 | return $candidate if -x $candidate;
|
---|
1288 |
|
---|
1289 | # get first pager executable in PATH
|
---|
1290 | foreach my $path (split(':' => $ENV{'PATH'})) {
|
---|
1291 | return catfile($path, $candidate) if -x catfile($path, $candidate);
|
---|
1292 | }
|
---|
1293 |
|
---|
1294 | # still no executable!
|
---|
1295 | warn "can't find pager '$candidate'! disabling 'paged' output\n";
|
---|
1296 | $ARG{'paged'} = 0;
|
---|
1297 |
|
---|
1298 | return '-1';
|
---|
1299 | }
|
---|
1300 | # </sub get_pager>
|
---|