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

require 5.003;

use lib "/var/tmp/perl-root/usr//lib/wml/perl/lib";
use lib "/var/tmp/perl-root/usr//lib/wml/perl/lib/i386-linux/5.00401";
use lib "/var/tmp/perl-root/usr//lib/wml/perl/lib/site_perl";
use lib "/var/tmp/perl-root/usr//lib/wml/perl/lib/site_perl/i386-linux";

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

#
#   process command line
#
sub usage {
    print STDERR "Usage: divert [options] [file]\n";
    print STDERR "   where options are\n";
    print STDERR "   -o file  set output file instead of stdout\n";
    print STDERR "   -q       quiet mode (no warnings)\n";
    print STDERR "   -v       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 ($str) = @_;
    if (not $opt_q) {
        print STDERR "** Divert:Warning: $str\n";
    }
}

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

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

#
#   parse the buffer into disjunct diverts 
#
$divcur   = 'main';           # current active diversion
@DIVSTACK = ();               # stack of remembered diversions
%DIVBUFF  = ($divcur => []);  # the diversion buffers
%OVINFO   = ();               # the overwrite info

$read   = '';                 # already read but still not stored data
$remain = $buffer;            # still remaining data

sub store {
    #   store still remembered data
    if ($read ne '') {
        push(@{$DIVBUFF{$divcur}}, $read);
        $read = '';
    }
}

while ($remain) { 

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

        #   adjust remaining data
        $remain = $2;

        #   store remembered data
        &store;

        # initialize new diversion
        $DIVBUFF{$1} = [] if ($DIVBUFF{$1} eq '');

        #   insert diversion pointer into current diversion
        if ($DIVBUFF{$divcur} == $DIVBUFF{$1}) {
            &warning("self-reference of diversion ``$divcur'' - ignoring"); 
        }
        else {
            push(@{$DIVBUFF{$divcur}}, $DIVBUFF{$1});
        }

        next;
    }

    if (   $remain =~ m|^\.\.(\!?[a-zA-Z][a-zA-Z0-9_]*\!?)>>(.*)$|s
        or $remain =~ m|^{#(\!?[a-zA-Z][a-zA-Z0-9_]*\!?):(.*)$|s) {
        #
        #   enter diversion
        #

        #   adjust remaining data
        $remain = $2;
        #   store remembered data
        &store;

        #   remember old diversion on stack
        push(@DIVSTACK, $divcur);

        #   determine diversion and enter it
        $divcur = $1;                                        
        $rewind_now  = 0;
        $rewind_next = 0;
        if ($divcur =~ m|^\!(.*)$|) {
            #   divertion should be rewinded now
            $divcur = $1;
            $rewind_now = 1;
        }
        if ($divcur =~ m|^(.*)\!$|) {
            #   diversion should be rewinded next time
            $divcur = $1;
            $rewind_next = 1;
        }

        #   initialize diversion
        $DIVBUFF{$divcur} = [] if ($DIVBUFF{$divcur} eq '');

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

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

        #   execute a "rewind now"
        if ($rewind_now == 1) {
            while ($#{$DIVBUFF{$divcur}} > -1) {
                shift(@{$DIVBUFF{$divcur}});
            }
        }

        next;
    }

    if (   $remain =~ m|^<<\.\.(.*)$|s 
        or $remain =~ m|^:#}(.*)$|s) {
        #
        #   leave diversion
        #

        #   adjust remaining data
        $remain = $1;

        #   store remembered data
        &store;
        
        #   restore previous diversion from stack
        if ($#DIVSTACK >= 0) {
            $divcur = pop(@DIVSTACK);                  
        }

        next;
    }

    #   calculate the minimum amount of plain characters we can skip
    $l = length($remain);
    $i1 = index($remain, "<<");  $i1 = ($i1 == -1 ? $l : $i1);
    $i2 = index($remain, "..");  $i2 = ($i2 == -1 ? $l : $i2);
    $i3 = index($remain, "{#");  $i3 = ($i3 == -1 ? $l : $i3);
    $i4 = index($remain, ":#}"); $i4 = ($i4 == -1 ? $l : $i4);
    $i = ($i1 < $i2 ? $i1 : $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 next char to remembered data
    $remain = substr($remain, $i, $l-$i);    # refresh remaining data 
}
#   store still remembered data
&store;

#
#   recursively expand the diversion
#
sub ExpandDivertion {
    my ($div) = @_;
    my ($buffer) = "";
    my ($el);

    foreach $divseen (@DIVSTACK) {
        if ($divseen == $div) {
            $name = "unknown";
            foreach $n (keys(%DIVBUFF)) {
                if ($DIVBUFF{$n} == $div) {
                    $name = $n;
                    last;
                }
            }
            &warning("recursion through divertion ``$name'' - break");
            return '';
        }
    }
    push(@DIVSTACK, $div);
    foreach $el (@{$div}) {
        if (ref($el)) {
            $buffer .= &ExpandDivertion($el);
        }
        else {
            $buffer .= $el;
        }
    }
    pop(@DIVSTACK);
    return $buffer;
}

@DIVSTACK = ();
$buffer = &ExpandDivertion($DIVBUFF{'main'});
print $out $buffer;
$out->close;

exit(0);

##EOF##
