#! /usr/bin/perl

##################################################################################
#                                                                                #
# expand_macros.pl -- recursively expand greenstone macros / 1080805 - 7140805   #
#                                                                                #
# Copyright (C) 2005 Jens Wille <j_wille at gmx.net>                             #
#                                                                                #
# This program is free software; you can redistribute it and/or                  #
# modify it under the terms of the GNU General Public License                    #
# as published by the Free Software Foundation; either version 2                 #
# of the License, or (at your option) any later version.                         #
#                                                                                #
# This program is distributed in the hope that it will be useful,                #
# but WITHOUT ANY WARRANTY; without even the implied warranty of                 #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the                  #
# GNU General Public License for more details.                                   #
#                                                                                #
# You should have received a copy of the GNU General Public License              #
# along with this program; if not, write to the Free Software                    #
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.    #
#                                                                                #
##################################################################################

#
# expand_macros.pl reads in specified greenstone macro files and prints the
# definitions of requested macros and recursively the definitions of macros
# used within these definitions.
#
# it also has an "interactive browse mode" where you can select which macro
# (and from which package) to display next.
#
# you can even search for macros that use certain macros ("reverse" search)
# - recursively!
#

use strict;
use warnings;

use Getopt::Long          qw(GetOptions);

use File::Basename        qw(basename);
use File::Spec::Functions qw(catdir catfile);

use IO::Handle            qw(autoflush);
STDOUT->autoflush(1);


### progname and version

my $NAME    = basename $0;
my $VERSION = '0.12';


### command line arguments

# variable initialisation and default values
my ($verbose, $depth, $short, $reverse, $browse, $paged, $pager)
 = (0,        '',     0,      0,        0,       0,      'less');

my @macro_dirs = (catdir($ENV{'GSDLHOME'}, 'macros'));
my @macros     = ();

# usage information and help text
my $USG = <<HERE_USG;
usage:
    $NAME [generic-options] [-d <depth>] [-s] [-r] [<package>:]<macro> ...
    $NAME [generic-options] {-b|-i} [-p]
    $NAME [-h|-?|--help]

    generic options are: [-v] [-e <directory>,...]
HERE_USG

my $HLP = <<HERE_HLP;
$NAME: recursively expand greenstone macros (v$VERSION)

$USG

generic options:
    -h, -?, --help                 display this help and exit
    -v,     --verbose              output some extra information/warnings

    {-e|--extra} <directory>,...   paths to extra macro directories, comma-separated list (default directory: '$macro_dirs[0]')

batch mode:
    {-d|--depth} <depth>           how deep to recurse through macros (default: '$depth', meaning 'infinite')

    -s,     --short                short output, i.e. only macro names, no content
    -ss                            really short, i.e. no content, no recursion (equivalent to '-s -d 0')

    -r,     --reverse              "reverse" search, outputs the macros which _use_ the specified macro(s)

    all non-option arguments will be treated as macro names (without surrounding '_')
    you can restrict your query to a certain package by prepending the macro name with '<package-name>:'

interactive browse mode:
    -b, -i, --browse               interactive browse mode, just try it ;-)

    -p,     --paged                data output will be passed to a pager (default: '$pager')
            --pager <pager>        pass paged output to specified pager instead of above named default
HERE_HLP

# allow for bundling of options
Getopt::Long::Configure ("bundling");

# parse arguments
GetOptions( 'help|h|?'   => sub { print "$HLP\n"; exit 0 },
            'verbose|v'  => \$verbose,
            'extra|e=s'  => \@macro_dirs,
            'depth|d=i'  => \$depth,
            'short|s+'   => \$short,
            'reverse|r'  => \$reverse,
            'browse|b|i' => \$browse,
            'paged|p'    => \$paged,
            'pager=s'    => \$pager,
            '<>'         => sub { push(@macros => @_) } )
  or die "$USG\n";


### some sanity checks

# need one of our "actions": batch or browse
# ("batch" requiring at least one macro name specified)
die "$USG\n"
  unless @macros || $browse;

# need GSDLHOME for default macro directory
# (does also allow to have the script in gsdl bin path)
die "GSDLHOME not set! please change into the directory where greenstone has been installed and run/source the appropriate setup script.\n"
  unless $ENV{'GSDLHOME'};

# get the pager executable
# no need to test if not in "paged" mode
unless (! $paged || -x $pager) {
  # get first pager executable in PATH
  foreach my $path (split(':' => $ENV{'PATH'})) {
    if (-x catfile($path, $pager)) {
      $pager = catfile($path, $pager);
      last;
    }
  }

  # still no executable?
  die "can't find pager '$pager'!\n"
    unless -x $pager;
}


### action!

# build hash of macro information
my %db = build_db();
die "macro db empty!\n"
  unless %db;

unless ($browse) {
  # batch mode

  my $n = 0;
  foreach my $macro (@macros) {
    unless ($reverse) {
      # "normal" search

      get_macro(\%db, $macro);
    }
    else {
      # "reverse" search

      print "*** $macro ***\n\n";

      # get the macros that use the specified macro
      my @refs = get_r_macros(\%db, $macro);
      warn "no macro referencing '$macro'\n"
        unless @refs;

      # now recurse those macros
      foreach my $m (@refs) {
        get_macro(\%db, $m);
      }
    }

    # print separator _between_ requested macros (i.e. everytime but the last time)
    # (need to add extra newline for short display)
    print(($short ? "\n" : ''), '-' x 80, "\n\n")
      unless ++$n >= @macros;
  }
}
else {
  # interactive browse mode

  # repeat until explicit exit
  while (1) {
    print "enter macro name (without package specification) [leave empty to quit]\n> ";
    my $macro = <STDIN>;
    die "\n"
      unless defined $macro;  # allow for exiting by hitting <ctrl>+d
    chomp $macro;

    exit 0
      unless length $macro;   # normal exit

    # now get all packages for given macro, and begin recursion...
    recurse_packages(\%db, $macro);
  }
}


### that's it ;-)

exit 0;


### subroutines

# <sub build_db>
# build hash of macro information ("macro db")
#
# hash structure:
#   macro
#   -> package
#      -> 'file'
#      -> 'line'
#      -> 'content'
#
# usage:
#   %db = build_db()
#
#  => db: returned hash ("macro db")
#
sub build_db {
  my %db = ();
  my @dm = ();
  my ($n, $m) = (0, 0);

  # get all macro files (*.dm) from specified directories
  foreach my $dir (@macro_dirs) {
    opendir(DIR, "$dir")
      or die "can't read macro directory '$dir': $!\n";

    push(@dm => map { $_ = catfile($dir, $_) } grep { /\.dm$/ } readdir(DIR));

    closedir DIR;
  }

  # now parse each macro file and build hash
  foreach my $dm (sort @dm) {
    open(DM, "< $dm")
      or die "can't open macro file '$dm': $!\n";

    my ($name, $content, $curpkg, $contd) = ('', '', '', 0);
    while (my $line = <DM>) {
      chomp($line);
      next unless length $line;      # skip empty lines
      next if     $line =~ /^\s*$/;  # skip "empty" lines
      next if     $line =~ /^\s*#/;  # skip comments (i hope this doesn't
                                     # affect cases we actually wanted to keep)

                      # is this sufficient???
      if    ($line =~ /^package\s+(\w+)/) {
        # remember the current package we are in
        $curpkg = $1;
      }
                      # my understanding of greenstone macro names:
                      #   - enclosed in underscores ('_')
                      #   - starts with a letter ([:alpha:])
                      #   - followed by alphanumeric characters ([:alnum:])
                      #     (consequently, it doesn't start with a number and
                      #     particularly isn't a macro parameter, i.e. something like _1_)
                      #   - also we need to take care of escaped underscores ('\_')
                      #
                      #   => does this fit???
      elsif ($line =~ /(?<!\\)_([[:alpha:]][[:alnum:]]*)(?<!\\)_\s*\{\s*(.*)/) {
        # start of macro definition
        $n++;

        $name    = $1;
        $content = $2 || '';

        # is the macro definition already finished?
        $contd = ($content =~ s/\s*(?<!\\)\}.*//) ? 0 : 1;

        if (exists $db{$name}->{$curpkg}) {
          # everytime a macro definition already exists, it's simply
          # overwritten - but we can give a warning
          # (this might also serve debugging purposes)
          $m++;

          warn <<HERE_WARN if $verbose;
duplicate definition of macro '$curpkg:$name' at '$dm', line $.
(previously defined at $db{$name}->{$curpkg}->{'file'}, line $db{$name}->{$curpkg}->{'line'})
HERE_WARN
        }

        # store the information we got so far
        $db{$name}->{$curpkg}->{'file'}    = $dm;
        $db{$name}->{$curpkg}->{'line'}    = $.;
        $db{$name}->{$curpkg}->{'content'} = [$content] if length $content;
      }
      elsif ($contd) {
        # continuation of macro definition

        # is the macro definition already finished?
        $contd = ($line =~ s/\s*(?<!\\)\}.*//) ? 0 : 1;

        # store additional content
        push(@{$db{$name}->{$curpkg}->{'content'}} => $line);
      }
      else {
        # something else...

        ($name, $content) = ('', '');
      }
    }

    close DM;
  }

  # print some statistics
  print "$n total macro definitions, $m duplicates\n"
    if $verbose;

  # we stored all information there is so we can return it
  return %db;
}
# </sub build_db>

# <sub get_macro>
# recursively print macro information
#
# usage:
#   get_macro($db, $macro[, $level])
#
#   db:    hash reference to macro db
#   macro: macro name (optionally including package specification)
#   level: recursion level (optional)
#
#   => VOID CONTEXT
#
sub get_macro {
  my ($db, $macro, $level) = @_;
  $level ||= 0;

  # indent output according to recursion level
  my $indent  = '    ' x $level;

  # get all the packages which our macro is defined in
  ($macro, my @packages) = get_packages($db, $macro, $indent);
  return unless @packages;

  # macro definitions may occur in several packages so we display them all
  # (unless a certain package was explicitly specified)
  foreach my $pkg (@packages) {
    print "$indent* $pkg:$macro ($db->{$macro}->{$pkg}->{'file'}, line $db->{$macro}->{$pkg}->{'line'})\n";

    next if $short > 1;  # really short (no content, no recursion)

    my $content = '';
    # some macros are defined, but don't have any content
    if (defined $db->{$macro}->{$pkg}->{'content'}) {
      # for batch display we condense the output a little bit...
      map { s/^\s*//; s/\s*$// } @{$db->{$macro}->{$pkg}->{'content'}};
      # ...and put it on a single line
      $content = join(' ' => @{$db->{$macro}->{$pkg}->{'content'}});
    }
    print "$indent  { $content }\n\n"
      unless $short;
      # short display only, i.e. no content
      # of the macro's definition

    # only go (deeper) into referenced macros if we
    # haven't reached the specified recursion level
    if ($depth eq '' || $level < $depth) {
      # get (referencing|referenced) macros...
      my @refs = $reverse
               ? get_r_macros($db, $macro)
               : get_macros($content);

      # ...and recurse above them (with increased recursion level)
      foreach my $ref (@refs) {
        get_macro($db, $ref, $level + 1);
      }
    }
  }
}
# </sub get_macro>

# <sub get_macros>
# returns a list of macros extracted from a content string
# or a boolean value if a macro name was specified
#
# usage:
#   @macros  = get_macros($content)
#   $boolean = get_macros($content, $macro)
#
#   content: content string
#   macro:   macro name
#
#   => macros:  list of macros
#   => boolean: boolean value (true = 1 / false = empty list)
#
sub get_macros {
  my ($content, $macro) = @_;
  my @macro_list = ();
  my %seen       = ();

  # get each macro reference in the string
  # (for macro name considerations see above)
  while ($content =~ /(?<!\\)_((?:[[:alpha:]]+:)?[[:alpha:]][[:alnum:]]*)(?<!\\)_/g) {
    my $m = $1;

                           # we want to skip some macros that have no content anyway (defined
                           # from within the server) - unless we're doing a "reverse" search
    next if $seen{$m}++ || ($m =~ /^(cgiarg.*|if|httpimg|gwcgi|(decoded)?compressedoptions)$/i
                            && ! $reverse);

    if (defined $macro) {
      # is this the macro we wanted? then the current
      # macro uses it => return true
      return 1 if $m =~ /^(?:[[:alpha:]]+:)?$macro$/;
    }
    else {
      # add macro to our list
      push(@macro_list => $m);
    }
  }

  # return the list of used macros
  # (this evaluates to false (empty list) if there are no further
  # macro calls or if this macro doesn't use the sought-after macro)
  return sort @macro_list;
}
# </sub get_macros>

# <sub get_r_macros>
# returns a list of macro names which reference ("use") the specified macro
#
# usage:
#   @macros = get_r_macros($db, $macro)
#
#   db:    hash reference to macro db
#   macro: macro name
#
#   => macros: list of macros
#
sub get_r_macros {
  my ($db, $macro) = @_;
  my %refs = ();

  # need to test each single macro's...
  foreach my $m (sort keys %{$db}) {
    # ...each single package
    foreach my $p (sort keys %{$db->{$m}}) {
      my $pm = "$p:$m";  # include package information in the macro name!

                   # does this macro have any content?
      $refs{$pm}++ if defined $db->{$m}->{$p}->{'content'}
                   # then check if it uses our sought-after macro
                   && get_macros(join(' ' => @{$db->{$m}->{$p}->{'content'}}), $macro);
                                 # need to stringify content!
    }
  }

  # now we have all the macros which use our sought-after
  return sort keys %refs;
}
# </sub get_r_macros>

# <sub recurse_packages>
# recurse all packages for a given macro
#
# usage:
#   recurse_packages($db, $macro)
#
#   db:    hash reference to macro db
#   macro: macro name (any package specification will be dropped)
#
#   => VOID CONTEXT
#
sub recurse_packages {
  my ($db, $macro) = @_;

  # repeat until explicit break/exit
  while (1) {
    # get all the packages which our macro is defined in
    ($macro, my @packages) = get_packages($db, $macro);
    return unless @packages;

    print "select package for macro '$macro' [leave empty to return]\n";
    my $n = 0;
    my $package = '';
    # ask for user's selection...
    do {
      foreach my $pkg (@packages) {
        printf "    [%d]%s %s\n", ++$n, " " x (4 - length $n), $pkg;
      }
      print "> ";
      $package = <STDIN>;
      die "\n"
        unless defined $package;  # allow for exiting by hitting <ctrl>+d
      chomp $package;
      $n = 0;
    # ...until we return...
    } until ($package eq ''
         # ...or a valid number is provided
         || ($package =~ /^\d+$/ && $package > 0 && $package <= @packages));

    return unless length $package;  # return to previous stage

    # set selected package
    $package = $packages[$package - 1];

                  # some macros are defined, but don't have any content
    my $content = defined $db->{$macro}->{$package}->{'content'}
                ? join("\n" => @{$db->{$macro}->{$package}->{'content'}})
                  # now we want to retain the original structure
                : '';

    my $content_string = <<HERE_CONTENT;
* $package:$macro ($db->{$macro}->{$package}->{'file'}, line $db->{$macro}->{$package}->{'line'})
  { $content }
HERE_CONTENT

    if ($paged) {
      # pass output to pager

      open(LESS, "| $pager")
        or die "can't open pipe to '$pager': $!";

      print LESS "$content_string";

      close LESS;
    }
    else {
      # print to standard out...

      print      "\n$content_string\n";

      # ...and wait for user reaction to continue
      print "[press <enter> to continue]";
      print "\n"
        if <STDIN>;
    }

    # now on to the macros referenced within this one
    recurse_macros($db, $content);
  }
}
# </sub recurse_packages>

# <sub get_packages>
# returns list of packages for specified macro, also returns
# modified macro name (without surrounding '_' and package specification)
#
# usage:
#   ($macro, @packages) = get_packages($db, $macro)
#
#   db:    hash reference to macro db
#   macro: macro name
#
#   => macro:    modified macro name
#   => packages: list of packages
#
sub get_packages {
  my ($db, $macro, $indent) = @_;
  $indent ||= '';

  # remove surrounding '_'
  $macro =~ s/^_//;
  $macro =~ s/_$//;

  # save original macro name (including package specification)
  my $omacro = $macro;

  my @packages = ();

                # for macro name considerations see above
  if ($macro =~ /^([[:alpha:]]+:)?[[:alpha:]][[:alnum:]]*$/) {
    # valid macro name

    # strip off package specification
    my $package = ($macro =~ s/^([[:alpha:]]+)://) ? $1 : '';

    if (exists $db->{$macro}) {
      # valid/existing macro

      if (length $package && ! $browse) {
        # regard any package specification unless we're in browse mode

        @packages = ($package)
          if exists $db->{$macro}->{$package};
      }
      else {
        # get all packages otherwise

        @packages = sort keys %{$db->{$macro}};
      }
    }
  }
  else {
    # invalid macro name

    warn "invalid macro name '$macro'!\n";
    return;  # skip it
  }

  # no packages - no definition
  unless (@packages) {
    print "$indent- $omacro\n$indent  no definition for macro!\n\n";
    return;  # skip it
  }

  # return modified macro name and packages found
  return $macro, sort @packages;
}
# </sub get_packages>

# <sub recurse_macros>
# recurse all macros for a given content string
#
# usage:
#   recurse_macros($db, $content)
#
#   db:      hash reference to macro db
#   content: content string
#
#   => VOID CONTEXT
#
sub recurse_macros {
  my ($db, $content) = @_;

  # repeat until explicit break/exit
  while (1) {
    # get all the macros referenced within the current one
    @macros = get_macros($content);
    return unless @macros;

    print "select macro [leave empty to return]\n";
    my $n = 0;
    my $macro = ''; 
    # ask for user's selection...
    do {
      foreach my $m (@macros) {
        printf "    [%d]%s %s\n", ++$n, " " x (4 - length $n), $m;
      }
      print "> ";
      $macro = <STDIN>;
      die "\n"
        unless defined $macro;  # allow for exiting by hitting <ctrl>+d
      chomp $macro;
      $n = 0;
    # ...until we return...
    } until ($macro eq ''
         # ...or a valid number is provided
         || ($macro =~ /^\d+$/ && $macro > 0 && $macro <= @macros));

    return unless length $macro;  # return to previous stage

    # set selected macro
    $macro = $macros[$macro - 1];

    # now we want all the macro's packages again
    recurse_packages($db, $macro);
  }
}
# </sub recurse_macros>