source: gsdl/trunk/bin/script/expand_macros.pl@ 19175

Last change on this file since 19175 was 19175, checked in by kjdon, 13 years ago

added httpweb to the regex that includes httpimg

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 37.0 KB
Line 
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
73use strict;
74use warnings;
75
76use Getopt::Long qw(GetOptions);
77
78use File::Basename qw(basename dirname);
79use File::Spec::Functions qw(catdir catfile curdir);
80
81use IO::Handle qw(autoflush);
82STDOUT->autoflush(1);
83
84use Term::ReadLine;
85
86
87### progname and version
88
89my $NAME = basename $0;
90my $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)
105my $MACRO_PATTERN = '[[:alpha:]][[:alnum:]]*';
106
107# package names: letters
108my $PACKAGE_NAME = '[[:alpha:]]+';
109
110# package specification: package name followed by a colon (':')
111my $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!)
116my $MACRO_AFFIX = '(?<!\\\)_';
117
118# beginning of macro definition: opening curly bracket ('{')
119my $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!)
124my $DEFINITION_END = '(?<!\\\)\}';
125
126# package declaration: 'package' (plus package name)
127my $PACKAGE_DECLARATION = 'package';
128
129
130### command line arguments
131
132# variable initialisation and default values
133my %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
150my $TERM = '';
151my $CURRENT_FILE = '';
152
153# usage information and help text
154my $USAGE = <<HERE_USAGE;
155usage:
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>]
161HERE_USAGE
162
163my $HELP = <<HERE_HELP;
164$NAME: recursively expand greenstone macros (v$VERSION)
165
166$USAGE
167
168generic 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
187batch 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
217interactive 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
234NOTE: for this script to run your greenstone environment needs to be set up (GSDLHOME set)
235HERE_HELP
236
237my $HELP_INTERACTIVE = <<HERE_HELP;
238$NAME: expand greenstone macros in ***interactive browse mode*** (v$VERSION)
239
240
241usage 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
255commands:
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
280HERE_HELP
281
282# allow for bundling of options
283Getopt::Long::Configure ("bundling");
284
285# parse arguments
286GetOptions( '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)
307unless (@{$ARG{'args'}} || $ARG{'interactive'}) {
308 warn "$USAGE";
309
310 warn <<HERE_WARN unless $ENV{'GSDLHOME'};
311
312GSDLHOME not set!
313
314for this script to run your greenstone environment needs to be set up. please
315change into the directory where greenstone has been installed and run/source
316the appropriate setup script.
317HERE_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)
324die "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
336my %macro_db = build_db();
337die "macro db empty!\n"
338 unless %macro_db;
339
340unless ($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}
389else {
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;
412entered '$NAME' in ***interactive browse mode*** (v$VERSION)
413[you can get help at any time by typing '.h', '.?', or '.help']
414
415HERE_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
435END {
436 if ($ARG{'interactive'}) {
437 # save history
438 savehist();
439 }
440}
441
442
443### that's it ;-)
444
445exit 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#
466sub 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'};
518duplicate 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'})
520HERE_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#
635sub 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#
697sub 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#
744sub 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#
789sub 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#
868sub 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#
940sub 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#
988sub 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#
1028sub 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#
1058sub 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#
1074sub 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;
1163current configuration for '$NAME - interactive browse mode':
1164
1165'version': $ARG{'version'}
1166'short' output: $short
1167'paged' output: $paged
1168'pager': $ARG{'pager'}
1169current file: $CURRENT_FILE
1170HERE_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#
1197sub 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#
1229sub 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#
1284sub 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>
Note: See TracBrowser for help on using the repository browser.