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