| 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>
|
|---|
