Changeset 10607


Ignore:
Timestamp:
2005-09-20T14:17:00+12:00 (19 years ago)
Author:
kjdon
Message:

new version from jens

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/gsdl/bin/script/expand_macros.pl

    r10510 r10607  
    33##################################################################################
    44#                                                                                #
    5 # expand_macros.pl -- recursively expand greenstone macros / 1080805 - 7140805   #
     5# expand_macros.pl -- recursively expand greenstone macros / 1080805 - 4010905   #
    66#                                                                                #
    77# Copyright (C) 2005 Jens Wille <j_wille at gmx.net>                             #
     
    2828# used within these definitions.
    2929#
    30 # it also has an "interactive browse mode" where you can select which macro
    31 # (and from which package) to display next.
    32 #
    33 # you can even search for macros that use certain macros ("reverse" search)
    34 # - recursively!
     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
    3567#
    3668
     
    4072use Getopt::Long          qw(GetOptions);
    4173
    42 use File::Basename        qw(basename);
    43 use File::Spec::Functions qw(catdir catfile);
     74use File::Basename        qw(basename dirname);
     75use File::Spec::Functions qw(catdir catfile tmpdir);
    4476
    4577use IO::Handle            qw(autoflush);
    4678STDOUT->autoflush(1);
    4779
     80use Term::ReadLine;
     81
    4882
    4983### progname and version
    5084
    5185my $NAME    = basename $0;
    52 my $VERSION = '0.12';
     86my $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)
     101my $MACRO_PATTERN       = '[[:alpha:]][[:alnum:]]*';
     102
     103# package names: letters
     104my $PACKAGE_NAME        = '[[:alpha:]]+';
     105
     106# package specification: package name followed by a colon (':')
     107my $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!)
     112my $MACRO_AFFIX         = '(?<!\\\)_';
     113
     114# beginning of macro definition: opening curly bracket ('{')
     115my $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!)
     120my $DEFINITION_END      = '(?<!\\\)\}';
     121
     122# package declaration: 'package' (plus package name)
     123my $PACKAGE_DECLARATION = 'package';
    53124
    54125
     
    56127
    57128# variable initialisation and default values
    58 my ($verbose, $depth, $short, $reverse, $browse, $paged, $pager)
    59  = (0,        '',     0,      0,        0,       0,      'less');
    60 
    61 my @macro_dirs = (catdir($ENV{'GSDLHOME'}, 'macros'));
    62 my @macros     = ();
     129my %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
     146my $TERM         = '';
     147my $CURRENT_FILE = '';
    63148
    64149# usage information and help text
    65 my $USG = <<HERE_USG;
     150my $USAGE = <<HERE_USAGE;
    66151usage:
    67     $NAME [generic-options] [-d <depth>] [-s] [-r] [<package>:]<macro> ...
     152    $NAME [generic-options] [-s] [-d <depth>] [-r] {_[<package>:]<macro>_|<query>} ...
    68153    $NAME [generic-options] {-b|-i} [-p]
    69154    $NAME [-h|-?|--help]
    70155
    71     generic options are: [-v] [-e <directory>,...]
    72 HERE_USG
    73 
    74 my $HLP = <<HERE_HLP;
     156    generic options are: [-v] [-e <directory>,...] [-n <version>]
     157HERE_USAGE
     158
     159my $HELP = <<HERE_HELP;
    75160$NAME: recursively expand greenstone macros (v$VERSION)
    76161
    77 $USG
     162$USAGE
    78163
    79164generic options:
    80     -h, -?, --help                 display this help and exit
    81     -v,     --verbose              output some extra information/warnings
    82 
    83     {-e|--extra} <directory>,...   paths to extra macro directories, comma-separated list (default directory: '$macro_dirs[0]')
     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
    84182
    85183batch mode:
    86     {-d|--depth} <depth>           how deep to recurse through macros (default: '$depth', meaning 'infinite')
    87 
    88     -s,     --short                short output, i.e. only macro names, no content
    89     -ss                            really short, i.e. no content, no recursion (equivalent to '-s -d 0')
    90 
    91     -r,     --reverse              "reverse" search, outputs the macros which _use_ the specified macro(s)
    92 
    93     all non-option arguments will be treated as macro names (without surrounding '_')
    94     you can restrict your query to a certain package by prepending the macro name with '<package-name>:'
     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
    95197
    96198interactive browse mode:
    97     -b, -i, --browse               interactive browse mode, just try it ;-)
    98 
    99     -p,     --paged                data output will be passed to a pager (default: '$pager')
    100             --pager <pager>        pass paged output to specified pager instead of above named default
    101 HERE_HLP
     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
     215NOTE: for this script to run your greenstone environment needs to be set up (GSDLHOME set)
     216HERE_HELP
     217
     218my $INTERACTIVE_HELP = <<HERE_HELP;
     219$NAME: expand greenstone macros in ***interactive browse mode*** (v$VERSION)
     220
     221
     222usage 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
     236commands:
     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
     261HERE_HELP
    102262
    103263# allow for bundling of options
     
    105265
    106266# parse arguments
    107 GetOptions( 'help|h|?'   => sub { print "$HLP\n"; exit 0 },
    108             'verbose|v'  => \$verbose,
    109             'extra|e=s'  => \@macro_dirs,
    110             'depth|d=i'  => \$depth,
    111             'short|s+'   => \$short,
    112             'reverse|r'  => \$reverse,
    113             'browse|b|i' => \$browse,
    114             'paged|p'    => \$paged,
    115             'pager=s'    => \$pager,
    116             '<>'         => sub { push(@macros => @_) } )
    117   or die "$USG\n";
     267GetOptions( '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";
    118282
    119283
    120284### some sanity checks
    121285
    122 # need one of our "actions": batch or browse
    123 # ("batch" requiring at least one macro name specified)
    124 die "$USG\n"
    125   unless @macros || $browse;
     286# need one of our "actions": batch, query or interactive
     287# ("batch" requiring at least one macro name or regexp specified)
     288die "$USAGE\n"
     289  unless @{$ARG{'args'}} || $ARG{'interactive'};
    126290
    127291# need GSDLHOME for default macro directory
     
    130294  unless $ENV{'GSDLHOME'};
    131295
    132 # get the pager executable
    133 # no need to test if not in "paged" mode
    134 unless (! $paged || -x $pager) {
    135   # get first pager executable in PATH
    136   foreach my $path (split(':' => $ENV{'PATH'})) {
    137     if (-x catfile($path, $pager)) {
    138       $pager = catfile($path, $pager);
    139       last;
    140     }
    141   }
    142 
    143   # still no executable?
    144   die "can't find pager '$pager'!\n"
    145     unless -x $pager;
    146 }
    147 
    148296
    149297### action!
    150298
    151299# build hash of macro information
    152 my %db = build_db();
     300my %macro_db = build_db();
    153301die "macro db empty!\n"
    154   unless %db;
    155 
    156 unless ($browse) {
     302  unless %macro_db;
     303
     304unless ($ARG{'interactive'}) {
    157305  # batch mode
    158306
    159307  my $n = 0;
    160   foreach my $macro (@macros) {
    161     unless ($reverse) {
    162       # "normal" search
    163 
    164       get_macro(\%db, $macro);
     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      }
    165332    }
    166333    else {
    167       # "reverse" search
    168 
    169       print "*** $macro ***\n\n";
    170 
    171       # get the macros that use the specified macro
    172       my @refs = get_r_macros(\%db, $macro);
    173       warn "no macro referencing '$macro'\n"
    174         unless @refs;
    175 
    176       # now recurse those macros
    177       foreach my $m (@refs) {
    178         get_macro(\%db, $m);
     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);
    179346      }
    180347    }
     
    182349    # print separator _between_ requested macros (i.e. everytime but the last time)
    183350    # (need to add extra newline for short display)
    184     print(($short ? "\n" : ''), '-' x 80, "\n\n")
    185       unless ++$n >= @macros;
     351    print(($ARG{'short'} ? "\n" : ''), '-' x 80, "\n\n")
     352      unless ++$n >= @{$ARG{'args'}};
    186353  }
    187354}
     
    189356  # interactive browse mode
    190357
     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;
     376entered '$NAME' in ***interactive browse mode*** (v$VERSION)
     377[you can get help at any time by typing '.h', '.?', or '.help']
     378
     379HERE_HINT
     380
    191381  # repeat until explicit exit
    192382  while (1) {
    193     print "enter macro name (without package specification) [leave empty to quit]\n> ";
    194     my $macro = <STDIN>;
    195     die "\n"
    196       unless defined $macro;  # allow for exiting by hitting <ctrl>+d
    197     chomp $macro;
    198 
    199     exit 0
    200       unless length $macro;   # normal exit
     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
    201391
    202392    # now get all packages for given macro, and begin recursion...
    203     recurse_packages(\%db, $macro);
     393    recurse_packages($macro);
     394  }
     395
     396  # can't expect anything down here to be executed
     397}
     398
     399END {
     400  if ($ARG{'interactive'}) {
     401    # save history
     402    savehist();
    204403  }
    205404}
     
    219418#   macro
    220419#   -> package
    221 #      -> 'file'
    222 #      -> 'line'
    223 #      -> 'content'
    224 #
    225 # usage:
    226 #   %db = build_db()
    227 #
    228 #  => db: returned hash ("macro db")
     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")
    229429#
    230430sub build_db {
    231   my %db = ();
    232   my @dm = ();
     431  my %macro_db = ();
     432  my @dm_list = ();
    233433  my ($n, $m) = (0, 0);
    234434
    235435  # get all macro files (*.dm) from specified directories
    236   foreach my $dir (@macro_dirs) {
     436  foreach my $dir (@{$ARG{'macro_dirs'}}) {
    237437    opendir(DIR, "$dir")
    238438      or die "can't read macro directory '$dir': $!\n";
    239439
    240     push(@dm => map { $_ = catfile($dir, $_) } grep { /\.dm$/ } readdir(DIR));
     440    push(@dm_list => map { $_ = catfile($dir, $_) } grep { /\.dm$/ } readdir(DIR));
    241441
    242442    closedir DIR;
     
    244444
    245445  # now parse each macro file and build hash
    246   foreach my $dm (sort @dm) {
     446  foreach my $dm (sort @dm_list) {
    247447    open(DM, "< $dm")
    248448      or die "can't open macro file '$dm': $!\n";
    249449
    250     my ($name, $content, $curpkg, $contd) = ('', '', '', 0);
     450    my ($name, $content, $version, $curpkg, $contd)
     451     = ('',    '',       '0',      '',      0);
     452
    251453    while (my $line = <DM>) {
    252454      chomp($line);
     
    256458                                     # affect cases we actually wanted to keep)
    257459
    258                       # is this sufficient???
    259       if    ($line =~ /^package\s+(\w+)/) {
     460      if    ($line =~ /^$PACKAGE_DECLARATION\s*($PACKAGE_NAME)/) {
    260461        # remember the current package we are in
    261462        $curpkg = $1;
    262463      }
    263                       # my understanding of greenstone macro names:
    264                       #   - enclosed in underscores ('_')
    265                       #   - starts with a letter ([:alpha:])
    266                       #   - followed by alphanumeric characters ([:alnum:])
    267                       #     (consequently, it doesn't start with a number and
    268                       #     particularly isn't a macro parameter, i.e. something like _1_)
    269                       #   - also we need to take care of escaped underscores ('\_')
    270                       #
    271                       #   => does this fit???
    272       elsif ($line =~ /(?<!\\)_([[:alpha:]][[:alnum:]]*)(?<!\\)_\s*\{\s*(.*)/) {
     464      elsif ($line =~ /$MACRO_AFFIX($MACRO_PATTERN)$MACRO_AFFIX\s*(\[v=1\])?\s*$DEFINITION_START\s*(.*)/) {
    273465        # start of macro definition
    274466        $n++;
    275467
    276468        $name    = $1;
    277         $content = $2 || '';
     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'};
    278474
    279475        # is the macro definition already finished?
    280         $contd = ($content =~ s/\s*(?<!\\)\}.*//) ? 0 : 1;
    281 
    282         if (exists $db{$name}->{$curpkg}) {
     476        $contd = ($content =~ s/\s*$DEFINITION_END.*//) ? 0 : 1;
     477
     478        if (exists $macro_db{$name}->{$curpkg}->{$version}) {
    283479          # everytime a macro definition already exists, it's simply
    284480          # overwritten - but we can give a warning
     
    286482          $m++;
    287483
    288           warn <<HERE_WARN if $verbose;
    289 duplicate definition of macro '$curpkg:$name' at '$dm', line $.
    290 (previously defined at $db{$name}->{$curpkg}->{'file'}, line $db{$name}->{$curpkg}->{'line'})
     484          warn <<HERE_WARN if $ARG{'verbose'};
     485duplicate 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'})
    291487HERE_WARN
    292488        }
    293489
    294490        # store the information we got so far
    295         $db{$name}->{$curpkg}->{'file'}    = $dm;
    296         $db{$name}->{$curpkg}->{'line'}    = $.;
    297         $db{$name}->{$curpkg}->{'content'} = [$content] if length $content;
     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;
    298494      }
    299495      elsif ($contd) {
     
    301497
    302498        # is the macro definition already finished?
    303         $contd = ($line =~ s/\s*(?<!\\)\}.*//) ? 0 : 1;
     499        $contd = ($line =~ s/\s*$DEFINITION_END.*//) ? 0 : 1;
    304500
    305501        # store additional content
    306         push(@{$db{$name}->{$curpkg}->{'content'}} => $line);
     502        push(@{$macro_db{$name}->{$curpkg}->{$version}->{'content'}} => $line);
    307503      }
    308504      else {
     
    316512  }
    317513
     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
    318579  # print some statistics
    319580  print "$n total macro definitions, $m duplicates\n"
    320     if $verbose;
     581    if $ARG{'verbose'};
    321582
    322583  # we stored all information there is so we can return it
    323   return %db;
     584  return %macro_db;
    324585}
    325586# </sub build_db>
     
    329590#
    330591# usage:
    331 #   get_macro($db, $macro[, $level])
    332 #
    333 #   db:    hash reference to macro db
    334 #   macro: macro name (optionally including package specification)
    335 #   level: recursion level (optional)
     592#   get_macro($macro[, $level])
     593#
     594#   macro:    macro name (optionally including package specification)
     595#   level:    recursion level (optional)
    336596#
    337597#   => VOID CONTEXT
    338598#
    339599sub get_macro {
    340   my ($db, $macro, $level) = @_;
     600  my ($macro, $level) = @_;
    341601  $level ||= 0;
    342602
     
    345605
    346606  # get all the packages which our macro is defined in
    347   ($macro, my @packages) = get_packages($db, $macro, $indent);
     607  ($macro, my @packages) = get_packages($macro, $indent);
    348608  return unless @packages;
    349609
     
    351611  # (unless a certain package was explicitly specified)
    352612  foreach my $pkg (@packages) {
    353     print "$indent* $pkg:$macro ($db->{$macro}->{$pkg}->{'file'}, line $db->{$macro}->{$pkg}->{'line'})\n";
    354 
    355     next if $short > 1;  # really short (no content, no recursion)
    356 
    357     my $content = '';
    358     # some macros are defined, but don't have any content
    359     if (defined $db->{$macro}->{$pkg}->{'content'}) {
    360       # for batch display we condense the output a little bit...
    361       map { s/^\s*//; s/\s*$// } @{$db->{$macro}->{$pkg}->{'content'}};
    362       # ...and put it on a single line
    363       $content = join(' ' => @{$db->{$macro}->{$pkg}->{'content'}});
    364     }
    365     print "$indent  { $content }\n\n"
    366       unless $short;
    367       # short display only, i.e. no content
    368       # of the macro's definition
    369 
    370     # only go (deeper) into referenced macros if we
    371     # haven't reached the specified recursion level
    372     if ($depth eq '' || $level < $depth) {
    373       # get (referencing|referenced) macros...
    374       my @refs = $reverse
    375                ? get_r_macros($db, $macro)
    376                : get_macros($content);
    377 
    378       # ...and recurse above them (with increased recursion level)
    379       foreach my $ref (@refs) {
    380         get_macro($db, $ref, $level + 1);
     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        }
    381641      }
    382642    }
     
    406666  # get each macro reference in the string
    407667  # (for macro name considerations see above)
    408   while ($content =~ /(?<!\\)_((?:[[:alpha:]]+:)?[[:alpha:]][[:alnum:]]*)(?<!\\)_/g) {
     668  while ($content =~ /$MACRO_AFFIX((?:$PACKAGE_PATTERN)?$MACRO_PATTERN)$MACRO_AFFIX/g) {
    409669    my $m = $1;
    410670
     
    412672                           # from within the server) - unless we're doing a "reverse" search
    413673    next if $seen{$m}++ || ($m =~ /^(cgiarg.*|if|httpimg|gwcgi|(decoded)?compressedoptions)$/i
    414                             && ! $reverse);
     674                            && ! $ARG{'reverse'});
    415675
    416676    if (defined $macro) {
    417677      # is this the macro we wanted? then the current
    418678      # macro uses it => return true
    419       return 1 if $m =~ /^(?:[[:alpha:]]+:)?$macro$/;
     679      return 1 if $m =~ /^(?:$PACKAGE_PATTERN)?$macro$/;
    420680    }
    421681    else {
     
    433693
    434694# <sub get_r_macros>
    435 # returns a list of macro names which reference ("use") the specified macro
    436 #
    437 # usage:
    438 #   @macros = get_r_macros($db, $macro)
    439 #
    440 #   db:    hash reference to macro db
    441 #   macro: macro name
     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)
    442704#
    443705#   => macros: list of macros
    444706#
    445707sub get_r_macros {
    446   my ($db, $macro) = @_;
     708  my ($arg, $query) = @_;
     709  $query ||= 0;
    447710  my %refs = ();
    448711
    449712  # need to test each single macro's...
    450   foreach my $m (sort keys %{$db}) {
     713  foreach my $m (sort keys %macro_db) {
    451714    # ...each single package
    452     foreach my $p (sort keys %{$db->{$m}}) {
    453       my $pm = "$p:$m";  # include package information in the macro name!
    454 
    455                    # does this macro have any content?
    456       $refs{$pm}++ if defined $db->{$m}->{$p}->{'content'}
    457                    # then check if it uses our sought-after macro
    458                    && get_macros(join(' ' => @{$db->{$m}->{$p}->{'content'}}), $macro);
    459                                  # need to stringify content!
     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      }
    460734    }
    461735  }
     
    470744#
    471745# usage:
    472 #   recurse_packages($db, $macro)
    473 #
    474 #   db:    hash reference to macro db
    475 #   macro: macro name (any package specification will be dropped)
     746#   recurse_packages($macro)
     747#
     748#   macro:    macro name (any package specification will be dropped)
    476749#
    477750#   => VOID CONTEXT
    478751#
    479752sub recurse_packages {
    480   my ($db, $macro) = @_;
     753  my ($macro) = @_;
    481754
    482755  # repeat until explicit break/exit
    483756  while (1) {
    484757    # get all the packages which our macro is defined in
    485     ($macro, my @packages) = get_packages($db, $macro);
    486     return unless @packages;
    487 
    488     print "select package for macro '$macro' [leave empty to return]\n";
     758    #($macro, my @packages) = get_packages($macro);
     759    #return unless @packages;
     760    my @packages = ();
     761
    489762    my $n = 0;
    490763    my $package = '';
    491764    # ask for user's selection...
    492765    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";
    493772      foreach my $pkg (@packages) {
    494773        printf "    [%d]%s %s\n", ++$n, " " x (4 - length $n), $pkg;
    495774      }
    496       print "> ";
    497       $package = <STDIN>;
    498       die "\n"
    499         unless defined $package;  # allow for exiting by hitting <ctrl>+d
    500       chomp $package;
     775      $package = prompt();
    501776      $n = 0;
    502777    # ...until we return...
    503     } until ($package eq ''
     778    } until ($package eq '' || $package eq '-1'
    504779         # ...or a valid number is provided
    505780         || ($package =~ /^\d+$/ && $package > 0 && $package <= @packages));
    506781
    507     return unless length $package;  # return to previous stage
     782    return unless length $package;          # return to previous stage
     783    return '-1'   if     $package eq '-1';  # return to top
    508784
    509785    # set selected package
    510786    $package = $packages[$package - 1];
    511787
    512                   # some macros are defined, but don't have any content
    513     my $content = defined $db->{$macro}->{$package}->{'content'}
    514                 ? join("\n" => @{$db->{$macro}->{$package}->{'content'}})
    515                   # now we want to retain the original structure
    516                 : '';
    517 
    518     my $content_string = <<HERE_CONTENT;
    519 * $package:$macro ($db->{$macro}->{$package}->{'file'}, line $db->{$macro}->{$package}->{'line'})
    520   { $content }
    521 HERE_CONTENT
    522 
    523     if ($paged) {
    524       # pass output to pager
    525 
    526       open(LESS, "| $pager")
    527         or die "can't open pipe to '$pager': $!";
    528 
    529       print LESS "$content_string";
    530 
    531       close LESS;
    532     }
    533     else {
    534       # print to standard out...
    535 
    536       print      "\n$content_string\n";
    537 
    538       # ...and wait for user reaction to continue
    539       print "[press <enter> to continue]";
    540       print "\n"
    541         if <STDIN>;
    542     }
    543 
    544     # now on to the macros referenced within this one
    545     recurse_macros($db, $content);
     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    }
    546815  }
    547816}
     
    553822#
    554823# usage:
    555 #   ($macro, @packages) = get_packages($db, $macro)
    556 #
    557 #   db:    hash reference to macro db
    558 #   macro: macro name
     824#   ($macro, @packages) = get_packages($macro)
     825#
     826#   macro:    macro name
    559827#
    560828#   => macro:    modified macro name
     
    562830#
    563831sub get_packages {
    564   my ($db, $macro, $indent) = @_;
     832  my ($macro, $indent) = @_;
    565833  $indent ||= '';
    566 
    567   # remove surrounding '_'
    568   $macro =~ s/^_//;
    569   $macro =~ s/_$//;
    570834
    571835  # save original macro name (including package specification)
     
    574838  my @packages = ();
    575839
    576                 # for macro name considerations see above
    577   if ($macro =~ /^([[:alpha:]]+:)?[[:alpha:]][[:alnum:]]*$/) {
     840  if ($macro =~ /^($PACKAGE_PATTERN)?$MACRO_PATTERN$/) {
    578841    # valid macro name
    579842
    580843    # strip off package specification
    581     my $package = ($macro =~ s/^([[:alpha:]]+)://) ? $1 : '';
    582 
    583     if (exists $db->{$macro}) {
     844    my $package = ($macro =~ s/^($PACKAGE_NAME)://) ? $1 : '';
     845
     846    if (exists $macro_db{$macro}) {
    584847      # valid/existing macro
    585848
    586       if (length $package && ! $browse) {
    587         # regard any package specification unless we're in browse mode
    588 
    589         @packages = ($package)
    590           if exists $db->{$macro}->{$package};
     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        }
    591861      }
    592862      else {
    593         # get all packages otherwise
    594 
    595         @packages = sort keys %{$db->{$macro}};
     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        }
    596872      }
    597873    }
     
    619895#
    620896# usage:
    621 #   recurse_macros($db, $content)
    622 #
    623 #   db:      hash reference to macro db
    624 #   content: content string
     897#   recurse_macros($content)
     898#
     899#   content:  content string
    625900#
    626901#   => VOID CONTEXT
    627902#
    628903sub recurse_macros {
    629   my ($db, $content) = @_;
     904  my ($content) = @_;
    630905
    631906  # repeat until explicit break/exit
    632907  while (1) {
    633908    # get all the macros referenced within the current one
    634     @macros = get_macros($content);
     909    my @macros = get_macros($content);
    635910    return unless @macros;
    636911
    637     print "select macro [leave empty to return]\n";
    638912    my $n = 0;
    639913    my $macro = '';
    640914    # ask for user's selection...
    641915    do {
     916      print "select macro [leave empty to return]\n";
    642917      foreach my $m (@macros) {
    643918        printf "    [%d]%s %s\n", ++$n, " " x (4 - length $n), $m;
    644919      }
    645       print "> ";
    646       $macro = <STDIN>;
    647       die "\n"
    648         unless defined $macro;  # allow for exiting by hitting <ctrl>+d
    649       chomp $macro;
     920      $macro = prompt();
    650921      $n = 0;
    651922    # ...until we return...
    652     } until ($macro eq ''
     923    } until ($macro eq '' || $macro eq '-1'
    653924         # ...or a valid number is provided
    654925         || ($macro =~ /^\d+$/ && $macro > 0 && $macro <= @macros));
    655926
    656     return unless length $macro;  # return to previous stage
     927    return unless length $macro;          # return to previous stage
     928    return '-1'   if     $macro eq '-1';  # return to top
    657929
    658930    # set selected macro
     
    660932
    661933    # now we want all the macro's packages again
    662     recurse_packages($db, $macro);
     934    my $return = recurse_packages($macro);
     935
     936    return $return if defined $return;
    663937  }
    664938}
    665939# </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#
     951sub 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#
     991sub 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#
     1021sub 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#
     1037sub 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;
     1125current configuration for '$NAME - interactive browse mode':
     1126
     1127'version':         $ARG{'version'}
     1128'short' output:    $short
     1129'paged' output:    $paged
     1130'pager':           $ARG{'pager'}
     1131current file:      $CURRENT_FILE
     1132HERE_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#
     1159sub 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#
     1191sub 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#
     1246sub 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>
Note: See TracChangeset for help on using the changeset viewer.