#!/usr/bin/perl -w
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
    if $running_under_some_shell;
##
##  divert -- Diversion Filter
##  Copyright (c) 1997,1998 Ralf S. Engelschall, All Rights Reserved.
##

require 5.003;

BEGIN { $^W = 0; } # get rid of nasty warnings

use lib "/usr/lib/wml/perl/lib";
use lib "/usr/lib/wml/perl/lib/m68k-linux/5.004";
use lib "/usr/local/lib/site_perl";
use lib "/usr/local/lib/site_perl/m68k-linux";

use Getopt::Long 2.13;
use IO::Handle 1.15;
use IO::File 1.06;

#
#   process command line
#
sub usage {
    print STDERR "Usage: divert [options] [file]\n";
    print STDERR "\n";
    print STDERR "Options:\n";
    print STDERR "  -o, --outputfile=<file>  set output file instead of stdout\n";
    print STDERR "  -q, --quiet              quiet mode (no warnings)\n";
    print STDERR "  -v, --verbose            verbose mode\n";
    exit(1);
}
$opt_v = 0;
$opt_q = 0;
$opt_o = '-';
$Getopt::Long::bundling = 1;
$Getopt::Long::getopt_compat = 0;
if (not Getopt::Long::GetOptions(
    "v|verbose",
    "q|quiet",
    "o|outputfile=s")) {
    &usage;
}
sub verbose {
    my ($str) = @_;
    if ($opt_v) {
        print STDERR "** Divert:Verbose: $str\n";
    }
}
sub warning {
    my ($file, $line, $str) = @_;
    if (not $opt_q) {
        print STDERR "** Divert:Warning: $file:$line: $str\n";
    }
}

#
#   open input file and read into buffer
#
my $data;
my $file;
my $line;

$line = 1;
if (($#ARGV == 0 and $ARGV[0] eq '-') or $#ARGV == -1) {
    my $in = new IO::Handle;
    $file = 'STDIN';
    $in->fdopen(fileno(STDIN), "r");
    local ($/) = undef;
    $data = <$in>;
    $in->close;
}
elsif ($#ARGV == 0) {
    my $in = new IO::File;
    $file = $ARGV[0];
    $in->open($file);
    local ($/) = undef;
    $data = <$in>;
    $in->close;
}
else {
    &usage;
}


##
##   Pass 1: Parse the input data into disjunct location buffers
##           Each location buffer contains plain text blocks and
##           location pointers.
##

my $location = 'main';                       # currently active location
my @LOCSTACK = ('null');                     # stack of remembered locations
my %BUFFER   = ('null' => [], 'main' => []); # the location buffers
my %OVRWRITE = ();                           # the overwrite flags
my $remain   = $data;                        # still remaining data

while ($remain) {
    if (   $remain =~ m|^<<([a-zA-Z][a-zA-Z0-9_]*)>>(.*)$|s
        or $remain =~ m|^{#([a-zA-Z][a-zA-Z0-9_]*)#}(.*)$|s) {
        ##
        ##  Tag: dump location
        ##

        #   adjust remaining data
        $remain = $2;

        #   initialize new location buffer
        $BUFFER{$1} = [] if (not exists($BUFFER{$1}));

        #   insert location pointer into current location
        if ($BUFFER{$location} == $BUFFER{$1}) {
            &warning($file, $line, "self-reference of location ``$location'' - ignoring");
        }
        else {
            push(@{$BUFFER{$location}}, $BUFFER{$1});
        }
    }
    elsif (   $remain =~ m|^\.\.(\!?[a-zA-Z][a-zA-Z0-9_]*\!?)>>(.*)$|s
           or $remain =~ m|^{#(\!?[a-zA-Z][a-zA-Z0-9_]*\!?):(.*)$|s) {
        ##
        ##  Tag: enter location
        ##

        #   adjust remaining data
        $remain = $2;

        #   remember old location on stack
        push(@LOCSTACK, $location);

        #   determine location and optional
        #   qualifies, then enter this location
        $location = $1;
        my $rewind_now  = 0;
        my $rewind_next = 0;
        if ($location =~ m|^\!(.*)$|) {
            #   location should be rewinded now
            $location = $1;
            $rewind_now = 1;
        }
        if ($location =~ m|^(.*)\!$|) {
            #   location should be rewinded next time
            $location = $1;
            $rewind_next = 1;
        }

        #   initialize location buffer
        $BUFFER{$location} = [] if (not exists($BUFFER{$location}));

        #   is a "rewind now" forced by a "rewind next" from last time?
        if ($OVRWRITE{$location}) {
            $rewind_now = 1;
            $OVRWRITE{$location} = 0;
        }

        #   remember a "rewind next" for next time
        $OVRWRITE{$location} = 1 if ($rewind_next);

        #   execute a "rewind now" by clearing the location buffer
        if ($rewind_now == 1) {
            while ($#{$BUFFER{$location}} > -1) {
                shift(@{$BUFFER{$location}});
            }
        }
    }
    elsif (   $remain =~ m|^<<([a-zA-Z][a-zA-Z0-9_]*)?\.\.(.*)$|s
           or $remain =~ m|^:([a-zA-Z][a-zA-Z0-9_]*)?#}(.*)$|s) {
        ##
        ##  Tag: leave location
        ##

        #   adjust remaining data
        $remain = $2;

        if ($#LOCSTACK == -1) {
            &warning($file, $line, "already in ``null'' location -- ignoring leave");
        }
        else {
            my $loc = $1;
            if ($loc eq 'null') {
                &warning($file, $line, "cannot leave ``null'' location -- ignoring named leave");
            }
            elsif ($loc ne '' and $loc ne $location) {
                #   leave the named location and all locations
                #   on the stack above it.
                my $n = -1;
                for (my $i = $#LOCSTACK; $i >= 0; $i--) {
                    if ($LOCSTACK[$i] eq $loc) {
                        $n = $i;
                        last;
                    }
                }
                if ($n == -1) {
                    &warning($file, $line, "no such currently entered location ``$loc'' -- ignoring named leave");
                }
                else {
                    splice(@LOCSTACK, $n);
                    $location = pop(@LOCSTACK);
                }
            }
            else {
                #   leave just the current location
                $location = pop(@LOCSTACK);
            }
        }
    }
    else {
        ##
        ##  Plain text
        ##

        #   calculate the minimum amount of plain characters we can skip
        my $l = length($remain);
        my $i1 = index($remain, '<<');  $i1 = ($i1 == -1 ? $l : $i1);
        my $i2 = index($remain, '..');  $i2 = ($i2 == -1 ? $l : $i2);
        my $i3 = index($remain, '{#');  $i3 = ($i3 == -1 ? $l : $i3);
        my $i4 = index($remain, ':#}'); $i4 = ($i4 == -1 ? $l : $i4);
        my $i = $i1;
        $i = ($i  < $i2 ? $i  : $i2);
        $i = ($i  < $i3 ? $i  : $i3);
        $i = ($i  < $i4 ? $i  : $i4);

        #   skip at least 2 characters if we are sitting
        #   on just a "<<", "..", "{#" or ":#}"
        $i = 2 if ($i == 0);

        #   now adjust the buffers
        $read  .= substr($remain, 0, $i);        # append plain text to remembered data
        if ($read ne '') {
            push(@{$BUFFER{$location}}, $read);
            $read =~ s|\n|$line++, ''|sge;
            $read = '';
        }
        $remain = substr($remain, $i, $l-$i);    # refresh remaining data
    }
}


##
##   Pass 2: Recursively expand the location structure
##           by starting from the main location buffer
##

@LOCSTACK = ();

$data = &ExpandDiversion($BUFFER{'main'});

sub ExpandDiversion {
    my ($loc) = @_;
    my ($data, $locseen, $name, $n, $el);

    #   check for recursion by making sure
    #   the current location has not already been seen.
    foreach $locseen (@LOCSTACK) {
        if ($locseen == $loc) {
            #   find name of location via location pointer
            #   for human readable warning message
            $name = 'unknown';
            foreach $n (keys(%BUFFER)) {
                if ($BUFFER{$n} == $loc) {
                    $name = $n;
                    last;
                }
            }
            &warning($file, $line, "recursion through location ``$name'' - break");
            return '';
        }
    }

    #   ok, location still not seen,
    #   but remember it for recursive calls.
    push(@LOCSTACK, $loc);

    #   recursively expand the location
    #   by stepping through its list elements
    $data = '';
    foreach $el (@{$loc}) {
        if (ref($el)) {
            #   element is a location pointer, so
            #   recurse into the expansion of it
            $data .= &ExpandDiversion($el);
        }
        else {
            #   element is just a plain text block
            $data .= $el;
        }
    }

    #   we can remove the location from
    #   the stack because we are back from recursive calls.
    pop(@LOCSTACK);

    #   return expanded buffer
    return $data;
}


#
#   create output file
#
my $out;
if ($opt_o eq '-') {
    $out = new IO::Handle;
    $out->fdopen(fileno(STDOUT), "w") || die;
}
else {
    $out = new IO::File;
    $out->open(">$opt_o") || die;
}
print $out $data;
$out->close;


#
#   die gracefully
#
exit(0);


##EOF##
