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