#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
    if $running_under_some_shell;
##
##  IPP -- Include Pre-Processor
##  Copyright (c) 1997,1998,1999 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/5.005/alpha-linux";
use lib "/usr/local/lib/site_perl";
use lib "/usr/local/lib/site_perl/alpha-linux";

use Getopt::Long 2.13;
use IO::Handle 1.15;
use IO::File 1.06;
use Text::BlockParser qw(parseblock);
use File::Find;
use Cwd;


#
#   help functions
#
sub verbose {
    my ($level, $str) = @_;
    if ($opt_v) {
        print STDERR ' ' x ($level*2) . "$str\n";
    }
}
sub error {
    my ($str) = @_;
    print STDERR "** IPP:Error: $str\n";
    exit(1);
}
sub warning {
    my ($str) = @_;
    print STDERR "** IPP:Warning: $str\n";
}


#
#   process command line 
#
sub usage {
    print STDERR "Usage: ipp [options] file ...\n";
    print STDERR "\n";
    print STDERR "Options:\n";
    print STDERR "  -D, --define=<name>=<value>  define a variable\n";
    print STDERR "  -S, --sysincludedir=<dir>    add system include directory\n";
    print STDERR "  -I, --includedir=<dir>       add user include directory\n";
    print STDERR "  -s, --sysincludefile=<file>  pre-include system include file\n";
    print STDERR "  -i, --includefile=<file>     pre-include user include file\n";
    print STDERR "  -M, --depend=<options>       dump dependencies as gcc does\n";
    print STDERR "  -P, --prolog=<path>          specify one or more prolog filters\n";
    print STDERR "  -m, --mapfile=<file>         use include file mapping table\n";
    print STDERR "  -o, --outputfile=<file>      set output file instead of stdout\n";
    print STDERR "  -v, --verbose                verbosity\n";
    exit(1);
}
$opt_v = 0;
$opt_M = '-';
@opt_I = ('.');
@opt_D = ();
@opt_S = ();
@opt_i = ();
@opt_s = ();
@opt_P = (); 
@opt_m = (); 
$opt_o = '-';
$Getopt::Long::bundling = 1;
$Getopt::Long::getopt_compat = 0;
if (not Getopt::Long::GetOptions(
    "v|verbose", 
    "S|sysincludedir=s@", 
    "D|define=s@", 
    "I|includedir=s@", 
    "s|sysincludefile=s@", 
    "i|includefile=s@", 
    "M|depend:s" ,
    "P|prolog=s@",
    "m|mapfile=s@", 
    "o|outputfile=s"  )) {
    &usage;
}
#   Adjust the -M flags
if ($opt_M !~ m%^(-|[MD]*)$% && $#ARGV == -1) {
    push(@ARGV,$opt_M);
    $opt_M = '';
}
&usage if ($#ARGV == -1);

#
#   read mapfiles
#
sub read_mapfile {
    my ($MAP, $mapfile) = @_;
    local (*FP);

    open(FP, "<$mapfile") || die "cannot load $mapfile";
    while (<FP>) {
        next if (m|^\s*$|);
        next if (m|^\s*#.*$|);
        if (($given, $replace, $actiontype, $actiontext) =
             m|^(\S+)\s+(\S+)\s+\[\s*([SWE])\s*:\s*(.+?)\s*\].*$|) {
            if ($given =~ m|,|) {
                @given = split(/,/, $given);
            }
            else {
                @given = ($given);
            }
            foreach $given (@given) {
                $MAP->{$given} = {};
                $MAP->{$given}->{REPLACE}    = $replace; 
                $MAP->{$given}->{ACTIONTYPE} = $actiontype;
                $MAP->{$given}->{ACTIONTEXT} = $actiontext;
            }
        }
    }
    close(FP);
}
$MAP = {};
foreach $file (@opt_m) {
    &read_mapfile($MAP, $file);
}


#
#   iterate over the input files
#

%INCLUDES = ();
$outbuf   = '';

sub setargs {
    my ($arg, $str) = @_;

    return if ($str eq '');
    while ($str) {
        $str =~ s|^\s+||;
        last if ($str eq '');
        if ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)="([^"]*)"(.*)$|) {
            $arg->{$1} = $2;
            $str = $3;
        }
        elsif ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)=(\S+)(.*)$|) {
            $arg->{$1} = $2;
            $str = $3;
        }
        elsif ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)=\s+(.*)$|) {
            $arg->{$1} = '';
            $str = $3;
        }
        elsif ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)(.*)$|) {
            $arg->{$1} = 1;
            $str = $2;
        }
        else {
            $str = substr($str, 1); # make sure the loop terminates
        }
    }
}

sub mapfile {
    my ($file) = @_;
    my ($replace, $type, $text);

    if ($replace = $MAP->{$file}->{REPLACE}) {
        $type = $MAP->{$file}->{ACTIONTYPE};
        $text = $MAP->{$file}->{ACTIONTEXT};
        if ($type eq 'S') {
            $file = $replace;
        }
        elsif ($type eq 'W') {
            &warning("$file: $text");
            $file = $replace;
        }
        else {
            &error("$file: $text");
        }
    }
    return $file;
}

sub CanonPath {
    my ($path) = @_;

    $pathL = '';
    while ($path ne $pathL) {
        $pathL = $path;
        $path =~ s|//|/|g;
        $path =~ s|/\./|/|g;
        $path =~ s|/\.$|/|g;
        $path =~ s|^\./(.)|$1|g;
        $path =~ s|([^/.][^/.]*)/\.\.||;
    }
    return $path;
}

sub PatternProcess {
    my ($mode, $delimiter, $dirname, $pattern, $ext, $level, $noid, %arg) = @_;
    my ($dir, $out, $test, @ls);

    $out = '';
    if ($ext eq '') {
        $test = '-f "$dir/$dirname/$_"';
    }
    else {
        $test = '-d "$dir/$dirname"';
    }
    if ($delimiter eq '<') {
        foreach $dir (@opt_S) {
            opendir(DIR, "$dir/$dirname") || next;
            @ls = grep { /^$pattern$/  && eval $test } readdir(DIR);
            closedir DIR;
            foreach (@ls) {
                next if (m|/\.+$| or m|^\.+$|);
                $out .= &ProcessFile($mode, $delimiter, "$dirname/$_$ext", $level, $noid, %arg);
            }
        }
    }
    if ($delimiter eq '<' or $delimiter eq '"') {
        foreach $dir (@opt_I) {
            opendir(DIR, "$dir/$dirname") || next;
            @ls = grep { /^$pattern$/  && eval $test } readdir(DIR);
            closedir DIR;
            foreach (@ls) {
                next if (m|/\.+$| or m|^\.+$|);
                $out .= &ProcessFile($mode, $delimiter, "$dirname/$_$ext", $level, $noid, %arg);
            }
        }
    }
    if ($delimiter eq '<' or $delimiter eq '"' or $delimiter eq "'") {
        $dir = '.';
        if (-d $dirname) {
            opendir(DIR, "$dirname");
            @ls = grep { /^$pattern$/  && eval $test } readdir(DIR);
            closedir DIR;
            foreach (@ls) {
                next if (m|/\.+$| or m|^\.+$|);
                $out .= &ProcessFile($mode, $delimiter, "$dirname/$_$ext", $level, $noid, %arg);
            }
        }
    }
    return $out;
}

sub ProcessFile {
    my ($mode, $delimiter, $file, $level, $noid, %arg) = @_;
    my ($in, $found, $line, $incfile, $type, %argO, $out, $store);

    #
    #   first check whether this is a filename pattern in which case
    #   we must expand it
    #
    if ($file =~ m/([?*]|\[[^]]*\])/) {
        my ($dirname, $pattern, $ext);

        $dirname = $`;
        $pattern = $1;
        $ext     = $';
        if ($dirname =~ m|^(.*)/(.*?)$|) {
            $dirname = $1;
            $pattern = $2.$pattern;
        }
        else {
            $pattern = $dirname.$pattern;
            $dirname = '.';
        }
        if ($ext =~ m|^(.*?)(/.*)$|) {
            $pattern .= $1;
            $ext     = $2;
        }
        else {
            $pattern .= $ext;
            $ext     = '';
        }

        #
        #   replace filename patterns by regular expressions
        #
        $pattern =~ s/\./\\./g;
        $pattern =~ s/\*/.*/g;
        $pattern =~ s/\?/./g;
        return &PatternProcess($mode, $delimiter, $dirname, $pattern, $ext, $level, $noid, %arg);
    }

    #
    #    this is a regular file
    #
    $found  = 0;

    if ($delimiter eq '<') {
        foreach $dir (@opt_S) {
            if (-f "$dir/$file") {
                $file = "$dir/$file";
                $found = 1;
            }
        }
    }
    if ($delimiter eq '<' or $delimiter eq '"') {
        foreach $dir (@opt_I) {
        if (-f "$dir/$file") {
                $file = "$dir/$file";
                $found = 1;
            }
        }
    }
    if ($delimiter eq '<' or $delimiter eq '"' or $delimiter eq "'") {
        if (-f $file) {
            $found = 1;
        }
    }
    &error("file not found: $file") if not $found;

    #
    #   stop if file was still included some time before
    #
    if (not $noid) {
        $id = &CanonPath($file);
        if ($mode eq 'use') {
            return '' if (exists $INCLUDES{$id});
        }
        if ($delimiter eq '<') {
            $INCLUDES{$id} = 1;
        }
        else {
            $INCLUDES{$id} = 2;
        }
    }
    #
    #   stop if just want to check dependency
    #
    return '' if $mode eq 'depends';

    #
    #   process the file
    #
    $in = new IO::File;
    &verbose($level, "|");
    &verbose($level, "+-- $file");
    $in->open("<$file");
    $line   = 0;
    $out    = '';
    $store  = '';
    while ($l = <$in>) {
        $line++;

        #
        #   Variable Interpolation
        #

        #   This block is to replace variables with constructs like
        #   $(var)$(var)
        {
            #   Indicate Error if Unset
            redo if $l =~ s/((?!\\).|^)\$\(([a-zA-Z0-9_]+):\?\[(.+?)\]\)/exists $arg{$2} ? $1.$arg{$2} : &error($3)/ge;
            #   Use Default Values
            redo if $l =~ s/((?!\\).|^)\$\(([a-zA-Z0-9_]+):-([^\)]+)\)/exists $arg{$2} ? $1.$arg{$2} : $1.$3/ge;
            #   Assign And Use Default Values
            redo if $l =~ s/((?!\\).|^)\$\(([a-zA-Z0-9_]+):=([^\)]+)\)/exists $arg{$2} ? $1.$arg{$2} : $1.($arg{$2}=$3)/ge;
            #   Use Alternative Value
            redo if $l =~ s/((?!\\).|^)\$\(([a-zA-Z0-9_]+):\+([^\)]+)\)/exists $arg{$2} ? $1.$3 : $1/ge;
            #   Use Negative Alternative Value
            redo if $l =~ s/((?!\\).|^)\$\(([a-zA-Z0-9_]+):\*([^\)]+)\)/exists $arg{$2} ? $1 : $1.$3/ge;
            #   Normal Value
            redo if $l =~ s/((?!\\).|^)\$\(([a-zA-Z0-9_]+)\)/$1.$arg{$2}/ge;
        }

        #   Implicit Variables
        $l =~ s|__LINE__|$line|g;
        $l =~ s|__FILE__|$file|g;
        #   remove one preceding backslash
        $l =~ s/\\(\$\([a-zA-Z0-9_]+.*?\))/$1/g;

        #
        #   ``#include'', ``#use'' and ``#depends'' directives
        #

        if (($cmd, $incfile, $args) = ($l =~ m/^#(use|include|depends)\s+(\S+)(.*)$/)) {
            #   set arguments
            %argO = %arg;
            &setargs(\%arg, $args);

            #   do possible argument mapping
            $incfile = &mapfile($incfile);

            #   determine raw filename and type
            if ($incfile =~ m|^(\S+?)::(\S+)$|) {
                $type = '<';
                $incfile = "$2.$1";
                $incfile =~ s|::|/|g;
            }
            elsif ($incfile =~ m|^(['"<])([^'">]+)['">]$|) {
                $type = $1;
                $incfile = $2;
            }
            else {
                &error("Unknown file-argument syntax: ``$incfile''");
            }

            #   now recurse down
            $out .= &ProcessFile($cmd, $type, $incfile, $level+1, 0, %arg);

            #   reset arguments
            %arg = %argO;
        }

        #
        #   ``__END__'' feature
        #
        elsif ($l =~ m|^\s*__END__\s*\n?$|) {
            last;
        }

        #
        #   plain text
        #
        else {
            #   line-continuation support
            if ($store ne '') {
                $l =~ s|^\s+||;
            }
            if ($l =~ m|^\\\s*\n$|) {
                next;
            }
            if ($l =~ m|^(.*[^\\])\\\s*\n$|) {
                $store .= $1;
                next;
            }
            if ($l =~ m|^(.*\\)\\(\s*\n)$|) {
                $l = $1.$2;
            }
            $out .= $store.$l;
            $store = '';
        }
    }
    $out .= $store;
    $in->close();

    return $out;
}

#
#   create initial argument vector
#
%arg = ();
foreach $str (@opt_D) {
    $str =~ s|^(['"])(.*)\1$|$2|;
    if ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)="(.*)"$|) {
        $arg{$1} = $2;
    }
    elsif ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)=(['"]['"])?$|) {
        $arg{$1} = '';
    }
    elsif ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)=(.+)$|) {
        $arg{$1} = $2;
    }
    elsif ($str =~ m|^([a-zA-Z][a-zA-Z0-9_]*)$|) {
        $arg{$1} = 1;
    }
    else {
        &error("Bad argument to option `D': $str");
    }
}

#
#   process the pre-loaded include files
#
$tmpdir = $ENV{'TMPDIR'} || '/tmp';
$tmpfile = $tmpdir . "/ipp.$$.tmp";
unlink($tmpfile);
$tmp = new IO::File;
$tmp->open(">$tmpfile");
foreach $file (@opt_s) {
    if ($file =~ m|^(\S+?)::(\S+)(.*)\n$|) {
        $file = "$2.$1";
        $file =~ s|::|/|g;
    }
    print $tmp "#include <$file>\n";
}
foreach $file (@opt_i) {
    if ($file =~ m|^(\S+?)::(\S+)(.*)$|) {
        print $tmp "#use $file\n";
    }
    else {
        print $tmp "#include \"$file\"\n";
    }
}
$tmp->close();
$outbuf .= &ProcessFile('include', "'", $tmpfile, 0, 1, %arg);
unlink($tmpfile);

#
#   process real files
#
foreach $file (@ARGV) {
    #   read input file
    if ($file eq '-') {
        $in = new IO::Handle;
        $in->fdopen(fileno(STDIN), 'r');
        local ($/) = undef;
        $inbuf = <$in>;
        $in->close;
    }
    else {
        $in = new IO::File;
        $in->open($file);
        local ($/) = undef;
        $inbuf = <$in>;
        $in->close;
    }

    #   create temporary working file
    $tmp = new IO::File;
    $tmp->open(">$tmpfile");
    print $tmp $inbuf;
    $tmp->close();

    #   apply prolog filters
    foreach $p (@opt_P) {
        $rc = system("$p <$tmpfile >$tmpfile.f && mv $tmpfile.f $tmpfile 2>/dev/null");
        &error("Prolog Filter `$p' failed") if ($rc != 0);
    }

    #   process file via IPP filter
    $outbuf .= &ProcessFile('include', "'", $tmpfile, 0, 1, %arg);

    #   cleanup
    unlink($tmpfile);
}

#
#   Comment Support
#

#   EOL-comments
1 while ($outbuf =~ s/^([ \t]*)#[^\n]*\n//s); # special  case: at begin
$outbuf =~ s/\n[ \t]*#[^\n]*(?=\n)//sg;       # standard case: in the middle
$outbuf =~ s/\n[ \t]*#[^\n]*\n?$/\n/s;        # special  case: at end
#   $outbuf =~ s/^([ \t]*)\\(#)/$1$2/mg;      # remove escaping backslash

#   Block-comments
$outbuf = parseblock($outbuf, 
                     sub { return '' }, 0,             # just discard the stuff 
                     quotemeta('/*'), quotemeta('*/'), # the delimiters
                     0, 1, '"', "\\", '"')             # the escapes, etc.
          if $outbuf =~ m|/\*|;

if ($opt_M ne '-' && $opt_o ne '-') {
    #   Write dependencies
    if ($opt_M =~ m|D|) {
        if ($opt_o =~ m|(.*?)\.|) {
            $depfile = $1 . '.d';
        }
        else {
            $depfile = $opt_o . '.d';
        }
        $depout = new IO::File;
        $depout->open(">$depfile");
    }
    else {
        $depout = new IO::Handle;
        $depout->fdopen(fileno(STDOUT), "w");
    }

    #    Write the target
    print $depout $opt_o . ": \\\n" ;

    @deps = @ARGV;
    foreach (keys(%INCLUDES)) {
        push(@deps,$_) if $INCLUDES{$_} != 1 or $opt_M !~ m|M|;
    }
    #    and its dependencies
    print $depout "\t" . join(" \\\n\t",@deps) . "\n";
    $depout->close();
}
else {
    #
    #  create output file
    #
    if ($opt_o eq '-') {
        $out = new IO::Handle;
        $out->fdopen(fileno(STDOUT), "w");
    }
    else {
        $out = new IO::File;
        $out->open(">$opt_o");
    }
    print $out $outbuf;
    $out->close();
}

#   die gracefully
exit(0);

##EOF##
