#!/usr/bin/perl

use strict;

my $usage =
    "usage: register [-dcp] [-iur files]\n\n" .
    "Arguments:\n" .
    "\t-c create library\n" .
    "\t-d delete all files from library" . 
    "\t-p print linked files and functions\n" .
    "\t-i insert [files] to library\n" .
    "\t-u update [files] in library\n" .
    "\t-r remove [files] from library\n" ;


# variable definitions. The three first may be changed to customize
# the program but the rest should be as is. 
# where lparse sources are located 
my $src_dir = ".";		

# where library object files are stored 
my $obj_dir = "./lib";

#and c-compiler
my $cc = "gcc";

# ABANDON ALL HOPE ALL YE WHO ENTER HERE
#input file, should always be library.cc
my $ifile = "library.cc";

#utput file, should be a temporary file
my $ofile = "lib.cc";

#archive file
my $archive = "$src_dir/library.a";

#makefile
my $makefile = "$src_dir/Makefile";

# regular expressions:

#matching function declarations
my $def = "long\\s+([a-zA-Z0-9_]+)\\(.*\\)";

#separates path names from file names
my $fnam = ".*?([a-zA-Z0-9_]+\\.c+)";


#global data structures:

# %object_files contains the object files that are or will be stored
# in library.a. The key is the file name without path and the value is
# the full path to the object file.
my %object_files;

# %command_files contains the names of the files given as a command
# line argument as keys and the requested operations as values. The
# names don't have paths, the paths are stored in %full_names
my %command_files;
my %full_names;

# $failed_check{$file} is '1' if for some reason (e.g. failed
# compilation) the $file cannot be added to the library.
my %failed_check;

# @functions contains all functions that should be added to the
# library. The functions are found when reading through the .cc
# files. %func_files contains the names where the functions were
# found.
my @functions;
my %func_files;

# the functions to remove are here.
my %remove;

# and finally the arrays where the files to be added or removed are
# listed.
my @insert_f;
my @remove_f;

# functions:
sub read_files;
sub compile_objs;
sub process_file;
sub make_library;
sub print_functions;

#open the input and output files
open(LIB, $ifile) || die "cannot open library file '$ifile'";
open(OUT, ">$ofile") || die "cannot open temporary file '$ofile'";


#process the arguments using a finite state automaton. The states are
#also used as symbolic constants when processing files
my $init = 0;
my $insert = 1;
my $remove = 2;
my $update = 3;
my $state = $init;
my $create = 0;
my $print = 0;
my $file = 0;
my $remove_all = 0;

while ($_ = shift) {
    if ( $_ eq "-i") {
	$state = $insert;
	next;
    } elsif ($_ eq "-r") {
	$state =  $remove;
	next;
    } elsif ($_ eq "-u") {
	$state = $update;
	next;
    } elsif ($_ eq "-p") {
	$print = 1;
	next;
    } elsif ($_ eq "-c") {
	$create = 1;
	next;
    } elsif ($_ eq "-d") {
	$remove_all = 1;
	next;
    } else {
	if ( /$fnam/ ){
	    $file = $1;
	} else {
	    print "invalid file specifier in '$_'\n";
	    next;
	}

	if ($state == $insert) {
	    if ($command_files{$file} &&
		$command_files{$file} != $insert){
		die "conflicting specifiers for $_";
	    } else {
		$command_files{$file} = $insert;
		$full_names{$file} = $_;
		push @insert_f, $_;
	    }
	} elsif ($state == $remove) {
	    if ($command_files{$file} &&
	    $command_files{$file} != $remove){
		die "conflicting specifiers for $_";
	    } else {
		$command_files{$file} = $remove;
		$full_names{$file} = $_;
		push @remove_f, $_;
	    }
	} elsif ($state == $update) {
	    if ($command_files{$file} &&
		$command_files{$file} != $update){
		die "conflicting specifiers for $_";
	    } else {
		$command_files{$file} = $update;
		$full_names{$file} = $_;
		push @remove_f, $_;
		push @insert_f, $_;
	    }
	}else {
	    die $usage;
	}
    }
}

#the main program. quite small
if ($print) {
    print_functions();
} else {
    if ($remove_all) {
	undef @insert_f;
	undef %command_files;
    }
    read_files();
    compile_objs();
    process_file();
    make_library();
}

print "done\n";

#ends here, beneath this is only function definitions

sub check_file;

sub read_files {
    my $found = 0;
    my $file;
    my $obj_file;
    my $short_name;
    # first read the initial lines
    while ($_ = <LIB>) {
	print OUT $_;
	if ( /char .*external/ ) {
	    $found = 1;
	    last;
	}
    }
    if (!$found) {
	die "misformed input file: cannot found file definitions";
    }
    #and then read the file definitions
    while ($_ = <LIB>) {
	if (/$fnam/) {
	    #check if the file has to be removed
	    if (($command_files{$1} != $remove) && !$remove_all) { 
		$obj_file = $file = $1;
		$obj_file =~ s/\.c+/\.o/; #change suffix
		$object_files{$file} = "$obj_dir/$obj_file";
	    }
	} else {
	    last;
	}
    }
    #and add the new files to the list
    foreach $file (@insert_f) {
	if ($file =~ /$fnam/) {
	    $obj_file = $short_name = $1;
	    $obj_file =~ s/\.c+/\.o/;
	}
	if (check_file($file)) {
	    $object_files{$short_name} = "$obj_dir/$obj_file";
	} else {
	    $failed_check{$file} = 1;
	}
    }
    print "All object files: ", join(", ", (sort keys %object_files)), "\n";
}

sub compile_objs {
    my $file;
    my $short_name; 
    my $obj_file;
    
    foreach $file (@insert_f) {
	if (!$failed_check{$file}) {
	    print "compiling file '$file'\n";
	    if ($file =~ /$fnam/) {
		$short_name = $1;
		$obj_file = $object_files{$short_name};
		
		`$cc -x c++ -o $obj_file -c $file`;
		if ($? != 0) {
		    print "compile error with file '$file' - skipping\n";
		    $failed_check{$file} = 1;
		    undef $failed_check{$file};
		}
	    }
	}
    }
}

sub print_files;
sub process_regs;
sub process_defs;

sub process_file {
    print_files();
    process_defs();
    process_regs();
}



sub make_library {
    my $objs;
    my $file;
    #check if modifications are necessary
    `diff $src_dir/$ifile $src_dir/$ofile`;
    if ($? || $create) {
	print "updating $archive\n";
	#make new library
	#compile library.cc
	`$cc -o $src_dir/library.o -c $src_dir/$ofile`;
	if ($?) {
	    die "cannot compile lib.cc -- aborting";
	}
	#remove what should be removed
	$objs = join (' ', @remove_f);
	$objs =~ s/(\.c\b|\.cc\b)/\.o/g;
	if ($objs) {
	    `ar d $archive $objs`;
	    `rm -f $objs`;
	}
	if ($remove_all) {
	    `rm -f $obj_dir/*`;
	}

	
	#and add the files
	undef $objs;

	$objs = join(' ', (values %object_files));
	`ar r $archive $src_dir/library.o $objs`;

	if (!$create) {
	    #copy the output file as input file and make
	    `mv $src_dir/$ofile $src_dir/$ifile`;
	    print "relinking lparse\n";
	    `make -f $makefile`;
	}
    } else {
	print "no changes made. no need to relink\n";
    }
}


sub check_file {
    my $file = @_[0];
    my $res = 1;
    my $short_name;
    
    if ($failed_check{$file}) {
	$res = 0;
    } elsif (open(FILE, $file)) {
	while ($_ = <FILE>) {
	    if ($file =~ /$fnam/ ){
		$short_name = $1;
	    } else {
		$short_name = $file;
	    }
	    if (/$def/o) {
		print "$file: found function '$1'\n";
		push @functions, $1;
		$func_files{$1} = $short_name;
	    }
	}
	close(FILE);
    } else {
	print "cannot open file '$file' - skipping\n";
	$res = 0;
    }
    $res;
}


sub print_files {
    my $file;

    foreach $file (sort keys %object_files) {
	if ($failed_check{$file } != 1) {
	    if ($file =~ /.*?([a-zA-Z0-9_]*\.[a-zA-Z0-9_]*)/ ) {
		print OUT "\t\"$1\",\n";
	    }
	}
    }
    print OUT "\tNULL\n";
}

sub process_regs {
    my $regexp;
    my $fun;
    #skip internal declarations
    while ($_ = <LIB>) {
	print OUT $_;
	if (/START HERE/) {
	    last;
	}
    }
    $regexp = "function_table->Register\\(\"([a-zA-Z_0-9]+)\"";
    #remove unwanted registerations
    while ( $_ = <LIB> ){
	if (/END HERE/) {
	    last;
	} elsif (/$regexp/o) {
	    if ( !$remove_all && !$remove{$1} ) {
		print OUT $_;
	    } else {
		; # remove it
	    }
	} else {
	    print OUT $_;
	}
    }
    #and add new functions
    foreach $fun (sort @functions) {
	print OUT "   function_table->Register(\"$fun\", $fun, 0);\n";
    }
    print OUT $_;

    #and print rest of file
    while ($_ = <LIB>) {
	print OUT $_;
    }
    close(LIB);
    close(OUT);
}

sub process_defs
{
    my $regexp;
    my $fun;
    #find start of the definitions
    while ($_ = <LIB>) {
	print OUT $_;
	if (/START HERE/) {
	    last;
	}
    }
    $regexp =  $def . ";\\s+\\/\\*\\s*([a-zA-Z0-9_]+\.c+)\\s*\\*\/";
    #remove unwanted
    while ( $_ = <LIB> ){
	if (/END HERE/) {
	    last;
	} elsif (/$regexp/o) {
	    if (!$remove_all && ($command_files{$2} != $remove)) {
		print OUT $_;
	    } else {
		$remove{$1} = 1;
		print "Removing: $2:$1(int narg, ...)\n";
	    }
	} else {
	    print OUT $_;
	}
    }
    
    #add wanted
    foreach $fun (sort @functions) {
	print "Adding: $func_files{$fun}:$fun(int narg, ...)\n";
	print OUT "long $fun(int narg, ...); /* $func_files{$fun}"
	    ." */\n" ;
    }
    #and end marker
    print OUT $_;

}

sub print_functions {
    my $tmpfile;
    my $skip;
    my $regexp;
    #print archive information to a temporary file
    $tmpfile = "/tmp/register.$$";
    `nm -s $archive > $tmpfile`;
    
    #construct regexp to skip unwanted definitions
    $skip = "(external_files)|(register_functions)";
    
    #and regexp to match contents
    $regexp = "^([a-zA-Z_0-9]+)__Fie.*?([a-zA-Z_0-9]+\.o)";
    

    if (!$?) {
	open (ARC, $tmpfile);
	unlink($tmpfile);
	while ($_ = <ARC>) {
	    if (/$skip/) {
		next;
	    }
	    if (/$regexp/) {
		print "$2: $1\n";
	    }
	}
	close(ARC);
    } else {
	print "cannot open library file\n";
    }
}
