#!/usr/local/bin/perl -w

## This requires at least perl5
if ($] < 5) {
    die("This program requires perl 5.002 or greater.\n");
}

@args = ();
$make_changes = 1;
$full_messages = 0;
for (@ARGV) {
    if (/^-/) {
        if (/^-full/) {
            $full_messages = 1;
        }
        if (/^-list/) {
            $make_changes = 0;
            print "** Not writing changes\n";
        }
    } else {
        push(@args, $_);
    }
}

$base = actual_path($0);
@path = split(/(\/)/, $base);
$0 = pop(@path);
pop(@path);
$base = join("", @path);

## -------------------------------------------------------------------------
## Get the version
##

open(VER, "$base/files/version") || die("No version file??\n");
chomp($ver = <VER>);
close(VER);
$ver || die("No version??\n");

## -------------------------------------------------------------------------
## Defaults..
##

$| = 1;
$coldcc    = "coldcc";
$genesis   = "genesis";
#$clean     = "$base/scripts/finalclean";
$patchfile = "$base/files/patch";
#$patchmods = "$base/files/mods";
$upgradedb = "";
$workdir   = "work";
$msg = "==>";
$ind = "   ";
$err = "$ind ERROR:";

## -------------------------------------------------------------------------
## make sure everything is correct
##
!-f $patchfile &&
    die("$err $patchfile is missing!  Did you move it??  Put it back!\n");


## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## dig up genesis
if ($make_changes) {
    print "$msg Checking for genesis..";
    if (! -e $genesis) {
        print "\n";
        while (! -e $genesis) {
            print "$err Unable to find Genesis executable.\n";
            print "$ind Specify location: ";
            chomp($genesis = <STDIN>);
            if ($genesis !~ /genesis$/) {
                print "$err Invalid genesis reference.\n";
                $genesis = "";
            }
        }
        $genesis = actual_path($genesis);
        print "$msg .. Using $genesis\n";
    } else {
        $genesis = actual_path($genesis);
        print ".$genesis\n";
    }

## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## dig up coldcc
    print "$msg Checking for coldcc..";
    if (! -e $coldcc) {
        print "\n";
        my @tmp = split(/(\/)/, $genesis);
        pop(@tmp);
        $coldcc = join("", @tmp) . 'coldcc';
    
        while (! -e $coldcc) {
            print "$err Unable to find ColdCC executable.\n";
            print "$ind Specify location: ";
            chomp($coldcc = <STDIN>);
            if ($coldcc !~ /coldcc$/) {
                print "$err Invalid coldcc reference.\n";
                $coldcc = "";
            }
        }
        $coldcc = actual_path($coldcc);
        print "$msg .. Using $coldcc\n";
    } else {
        $coldcc = actual_path($coldcc);
        print ".$coldcc\n";
    }

    (-d "$base/$workdir") &&
        die("\n$err Working directory '$workdir' already exists, aborting..\n");


## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
## dig up the binary db

    for (;;) {
        print <<END;

$ind Specify binary directory to read from.
$ind 
$ind !!!!    THIS SHOULD *NOT* BE AN ACTIVELY USED BINARY DB    !!!!
$ind !!!! MAKE SURE TO SHUTDOWN YOUR DATABASE BEFORE DOING THIS !!!!
$ind 
$ind This database will be cleaned with the command-line option:
$ind
$ind     $genesis -f --clean --quit
$ind 
$ind This should not effect the integrity of the database.

END
        print "$ind Specify binary db: ";
        chomp($ans = <STDIN>);
        !$ans && next;
        $upgradedb = actual_path($ans) || next;
        if (! -d $upgradedb) {
            print "$err $upgradedb is not a directory.\n";
        } elsif (! -f "$upgradedb/.clean") {
            print "$err $upgradedb is not a clean database.\n";
        } else {
            last;
        }
    }

    print "$msg .. Using $upgradedb\n";

############################################################################
## go for it..

    $workdir = "$base/$workdir";
    mkdir($workdir, 0755) || die("$err mkdir(\"$workdir\"): $!\n");
    chdir($workdir) || die("$err chdir(\"$workdir\"): $!\n");

    print "$msg Cleaning Database..\n";
    $output = `($genesis -db $upgradedb -f --clean --quit) 2>&1`;
    if ($? / 256) {
        print "$err: Genesis errored out:\n";
        print $output;
        exit;
    }

}

############################################################################
$pfrag   = "$workdir/patchfrag.cdc";
$outfile = "$workdir/coldcc.out";
$errfile = "$workdir/coldcc.err";

sub coldcc_patch {
    my ($patch) = @_;
    my $output = `($coldcc -p -o -b $upgradedb -t $patch) 2>$errfile`;
    my $error = $? / 256;
    if ($error) {
        print "\n$err ColdCC exited with error status $error, output:\n";
        print "$output\n";
        exit(1);
    }
    if ($output =~ /WARNING/ && $output !~ /overrides native method$/) {
        print "\n$err ColdCC warning:\n$output\n$err Continue? [yes] ";
        <STDIN>;
    }
#open(OUT, ">>$outfile");
# print OUT "\n$output";
#close(OUT);
}

open(PATCHFILE, $patchfile) || die("open($patchfile): $!\n");
$state = 0;
$type = 0;
$changes = 0;
$closed = 1;
while (<PATCHFILE>) {
    if (/^\x1b\x0c(.*)$/) {
        if ($type) {
            if ($eval && $make_changes) {
                close(PATCHFRAG);
                coldcc_patch($pfrag);
                $closed = 1;
            }
        }
        if ($patchfrag) {
            print $patchfrag;
            $patchfrag = "";
        }
        $type = $1;
        $state = 1;
        $eval = 0;
        if ($type eq "new obj") {
            $eval = 1;
        }
        if ($closed && $make_changes) {
            $closed = 0;
            open(PATCHFRAG, ">$pfrag") || die("open(>$pfrag): $!\n");
        }
        $changes++;
        $pmsg = "";
    } elsif (/^\x1b\x07/) {
        if ($type eq "maintenance") {
            $pmsg = "Run-Time PATCH maintenance\n";
        }
        if ($full_messages) {
            print "\n//" . ("/" x 50) . "\n// $pmsg//\n\n";
        } else {
            print $pmsg;
        }
        $state = 2;
    } else {
        if ($state == 1) {
            $pmsg .= $_;
        } elsif ($state == 2) {
            if ($make_changes) {
                print PATCHFRAG $_;
            } elsif ($full_messages) {
#                if ($type eq "new method" ||
#                    $type eq "update objvar")
#                {
                    $patchfrag .= $_;
#                }
            }
        }
    }
}
close(PATCHFILE);
if ($make_changes) {
    close(PATCHFRAG);
    coldcc_patch($pfrag);
}


print "$changes total changes\n";

##
## Figure the full 'real' path, clearing out any '..' and '.' references
##  
sub actual_path {
    my $file = $_[0];
    my ($fullname, $wd, $last, $dir, $parts, $top);
    
    $file =~ s/^\.\///;
    $file =~ s/\/\.$//;
        
    if ($file =~ /^\//) {
        $fullname = $file;
    } else {
        chomp($wd = `pwd`);
        $fullname = "$wd/$file";
    }
    
    if ($fullname =~ /\/\.\.\//) { 
        my $origwd = `pwd`;
        chomp($origwd);
        @parts = split(/(\/?\.\.\/?)/, $fullname);
        $top = pop(@parts);
        $dir = join("", @parts);
        chdir($dir) || return 0;
        chomp($wd = `pwd`);
        $fullname = "$wd/$top";
        chdir($origwd) || die("chdir($origwd): $!\n");
    }
    
    $fullname =~ s/\/\.\///g;
    return $fullname;
}