#!/usr/bin/env perl
#-*-perl-*-

# Users account mannager. Designed to be architecture and distribution independent.
#
# Copyright (C) 2000 JP Rosevear
#
# Authors: JP Rosevear <jpr@helixcode.com>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Library General Public License as published
# by the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.

# Best viewed with 100 columns of width.

my ($conf_file,
    $make_file,
    $make_in_file,
    $make_am_file,
    $operation,
    $project_dir,
    $verbose,
    $version,
    @auto_files,
    @extra_targets,
    %targets,
    %targets_type,
    %target_vars);

# --- Usage text --- #

my $Usage =<<"End_of_Usage;";
Usage: gbf-am-parse <-g | -s | -h> [-v] project-dir

       Major operations (specify one of these):

       -g --get Prints the current project to standard
                output, as as standalone XML document.

       -s --set Write the current project to standard
                output, using the xml document from stdin

       -h --help     Prints this page to standard output. That\'s all.

          --version  Prints version information to standard output.

       Modifiers (specify any combination of these):

       -v --verbose  Turns on diagnostic messages to standard error.

End_of_Usage;

$version = "0.0.2";

# --- Internal configuration variables --- #
$operation = "";
$verbose = 0;
$project_dir = "";
%targets = qw ();
%targets_type = qw ();
@extra_targets = qw ();

# --- Constants --- #
$conf_file = "configure.in";
$make_file = "Makefile";
$make_in_file = "Makefile.in";
$make_am_file = "Makefile.am";

@auto_files = qw/ChangeLog README INSTALL COPYING COPYING.LIB NEWS TODO AUTHORS Makefile.am configure.in/;
%target_vars = qw/_PROGRAMS program _SCRIPTS program _LTLIBRARIES shared_lib _LIBRARIES static_lib/;

# --- Utility stuff --- #
sub source_name {
    my ($name);

    $name = $_[0];
    $name =~ s/\/\//\//g;
    $name =~ s/$project_dir//;
    $name =~ s/^\///;

    return $name;
}

sub base_name {
    my ($name, $dir);
    
    $name = $_[0];
    $dir = dir_name ($name);
    $name =~ s/$dir//;

    return $name;
}

sub dir_name {
    my ($name);

    $name = $_[0];
    $name =~ s/[^\/]+$//;

    return $name;
}

sub target_name 
{
    my ($name);

    $name = $_[0];
    $name =~ tr/\.-/_/;
    
    return $name;
}

sub ignore_line
{
    if (($_[0] =~ /^\#/) || ($_[0] =~ /^[ \t\n\r]*$/)) { return 1; }
    return 0;
}

sub item_is_in_list
{
  my $value = shift(@_);

  foreach my $item (@_) {
      if ($value eq $item) { 
	  return 1; 
      }
  }

  return 0;
}

sub is_target_var
{
    my ($target_var, $var);

    $target_var = $_[0];
    $var = $_[1];

    if ($var =~ /$target_var/) {
	return 1;
    }

    return 0;
}

sub get_var_name
{
    my ($line);

    $line = $_[0];

    if (s/^\s*(\w+)\s*=//) {
	return $1;
    }

    return "";
}

sub remove_string 
{
    my ($string, $line);

    $string = $_[0];
    $line = $_[1];

    $line =~ s/$string//;

    if ($line =~ /^[\s\\]*$/) {
	return "";
    }

    return $line;
}

# --- XML print formatting  --- #
my ($indent_level, $have_vspace);

$indent_level = 0;
$have_vspace = 0;

sub xml_enter  { $indent_level += 2; }
sub xml_leave  { $indent_level -= 2; }
sub xml_indent { my ($i); for ($i = 0; $i < $indent_level; $i++) { print " "; } $have_vspace = 0; }
sub xml_vspace { if (not $have_vspace) { print "\n"; $have_vspace = 1; } }
sub xml_print { &xml_indent; print @_; }

# --- Configuration manipulation --- #

sub extract_vars {
    my ($path, $var_name, $var_text, $in_var);
    my (%vars);

    $path = $_[0];
    if (!-e "$path/$make_am_file") {
	return;
	
	# Comment this out for now because po doesn't exist 
	# prior to autoconf being run
#	if (-e "$path/$make_in_file" || -e "$path/$make_file") {
#	    return;
#	} else {
#	    die "Error: Malformed project";	    
#	}
    }
    open (FILE, "$path/$make_am_file") || die "Error: Malformed project";
    while (<FILE>) {
	s/#.*//;

	if (s/^\s*(\w+)\s*=//) {
	    $var_name = $1;
	    $in_var = 1;
	}

	if ($in_var) {
	    if (!s/\s*\\\s*$//) {
		s/\s*$//;
		$in_var = 0;
	    }
	    s/^\s*//;
	    s/\s*$//;

	    if ($var_text ne "") {
		$var_text .= " ";
	    }
	    $var_text .= $_;

	    if (!$in_var) {
		$vars{$var_name} = $var_text;
		$var_text = "";
	    }
	}
    }
    close (FILE);

    return \%vars;
}

sub expand_vars {
    my ($varref, $key, $var_name);

    $varref = $_[0];
    foreach $key (keys %$varref) {
	while ($$varref{$key} =~ /\$\((\w*)\)/) {
	    $var_name = $1;
	    $$varref{$key} =~ s/\$\($var_name\)/$$varref{$var_name}/;
	}
    }
}

sub extract_targets {
    my ($prefix, $varref, $src, $t, $key, $path, $target, $target_name, $source, $file, $full, $dir);
    my (@subdirs, %vars, @tmp, @tmp2);

    $prefix = $_[0];

    $varref = extract_vars ("$prefix");
    expand_vars ($varref);
    %vars = %$varref;
    @subdirs = split (/\s+/, $vars{"SUBDIRS"});

    foreach $key (keys %vars) {
	foreach $t (keys %target_vars) {
	    if (is_target_var ($t, $key)) {
		@tmp = (split (/\s+/, $vars{$key}));
		foreach $target (@tmp) {
		    $target_name = target_name ($target);
		    $path = source_name ("$prefix/$target");

		    if ($t eq "_SCRIPTS") {
			%targets = (%targets, $path, [$path]); 
		    } else {
			@tmp2 = qw ();
			foreach $source (split (/\s+/, $vars{$target_name."_SOURCES"})) {
			    @tmp2 = (@tmp2, source_name ("$prefix/$source"));
			}
			$targets{$path} = [@tmp2];
		    }
		    $targets_type{$path} = $target_vars{$t};
		}
	    }
	}
    }

    foreach $file (@auto_files) {
	$full = "$prefix/$file";
	if (-f $full) {
	    @extra_targets = (@extra_targets, source_name ($full));
	}
    }
    
    foreach $dir (@subdirs) {
	if ($dir ne ".") {
	    extract_targets ("$prefix/$dir");
	}
    }
}

sub write_targets 
{
    my ($target, $src, $varref, $new_file, $new_line);
    my (@sources_add, @sources_remove);
    
    foreach $target (keys %targets) {
	if ($targets_type{$target} eq "extra") {
	    next;
	}

	$target_name = target_name (base_name ($target));
	$target_var = $target_name."_SOURCES";
	$path = dir_name ($target);

	$varref = extract_vars ("$project_dir/$path");
	expand_vars ($varref);
	%vars = %$varref;

	if ($vars{$target_var} ne "") {
	    $ref = $targets{$target};
	    @sources = @$ref;
	    @curr_sources = (split (/\s+/, $vars{$target_var}));
	    foreach $src (@sources) {
		if (!item_is_in_list (base_name ($src), @curr_sources)) {
		    @sources_add = (@sources_add, base_name ($src));
		}
	    }
	    foreach $src (@curr_sources) {
		if (!item_is_in_list ("$path$src", @sources)) {
		    @sources_remove = (@sources_remove, base_name $src);
		}
	    }
	}
	
	open (FILE, "$project_dir/$path/$make_am_file");
	while (<FILE>) {
	    if (&ignore_line ($_)) { 
		$new_file .= $_;
		next; 
	    }

	    $new_line = $_;
	    if (($var_name = get_var_name ($_)) ne "") {
		if ($var_name eq $target_var) {
		    $in_var = 1;
		}
	    }
	    if ($in_var) {
		foreach $src (@sources_remove) {
		    $new_line = remove_string ($src, $new_line);
		}
	    }
	    if ($in_var && !s/\s*\\\s*$//) {
		if (@sources_add >= 1) {
		    chomp ($new_line);
		    $new_line =~ /^(\s*)/;
		    $ws = $1;
		    $new_line = "$new_line \\\n";
		    
		    foreach $src (@sources_add) {
			$new_file .= $new_line;
			$new_line = "$ws$src \\\n";
		    }
		}
		$new_line =~ s/\\\n$/\n/;
		$in_var = 0;
	    }
	    
	   $new_file .= $new_line;
	}
	close (FILE);

	system ("mv $project_dir/$path/$make_am_file $project_dir/$path/$make_am_file~");
	open (FILE, ">$project_dir/$path/$make_am_file");
	print FILE $new_file;
	close (FILE);
    }
}

# --- XML scanning --- #

# This code tries to replace XML::Parser scanning from stdin in tree mode.

sub xml_scan_make_kid_array
{
    my %hash = {};
    my @sublist;

    @attr = $_[0] =~ /[^\t\n\r ]+[\t\n\r ]*([a-zA-Z_-]+)[ \t\n\r]*\=[ \t\n\r\"\']*([a-zA-Z0-9_\/.-]+)/g;
    %hash = @attr;
    
    push(@sublist, \%hash);
    return(\@sublist);
}

sub xml_scan_recurse
{
    my @list;
    if (@_) { @list = $_[0]->[0]; }
  
    while (@xml_scan_list) {
	$el = $xml_scan_list[0]; shift @xml_scan_list;

	if (($el eq "") || $el =~ /^\<[!?].*\>$/s) { next; }  # Empty strings, PI and DTD must go.

	if ($el =~ /^\<.*\/\>$/s) {
	    # Empty.

	    $el =~ /^\<([a-zA-Z_-]+).*\/\>$/s;
	
	    push(@list, $1);
	    $ref = &xml_scan_make_kid_array($el);
	    push(@list, $ref);
	} elsif ($el =~ /^\<\/.*\>$/s) {
	    # End.

	    last;
	} elsif ($el =~ /^\<.*\>$/s) {
	    # Start.

	    $el =~ /^\<([a-zA-Z_-]+).*\>$/s;

	    push(@list, $1);

	    $sublist = &xml_scan_make_kid_array($el);
	    push(@list, &xml_scan_recurse($sublist));
	    next;
	} elsif ($el ne "") {
	    # PCDATA.
	    
	    push(@list, 0);
	    push(@list, "$el");
	}
    }
    
    return(\@list);
}

sub xml_scan
{
    my $doc; my @tree; my $i;
    
    if ($xst_input_file eq "") {
	$doc .= $i while ($i = <STDIN>);
    } else {
	open INPUT_FILE, $xst_input_file;
	$doc .= $i while ($i = <INPUT_FILE>);
	close INPUT_FILE;
    }

    @xml_scan_list = ($doc =~ /([^\<]*)(\<[^\>]*\>)[ \t\n\r]*/mg); # pcdata, tag, pcdata, tag, ...
    
    $tree = &xml_scan_recurse;
    
    return($tree);
}

# --- XML printing --- #

sub xml_print_project
{
    my ($target, $i, $j, $k, $src, $ref);
    my (@tmp);

    print "<?xml version='1.0' encoding='ISO-8859-1' standalone='yes'?>\n";
    print "<!DOCTYPE project []>\n\n";
    print "<project name=\"$project_dir\">\n";
    &xml_enter ();
    
    &xml_print ("<target name=\"extra\" type=\"extra\">\n");
    &xml_enter ();
    foreach $src (@extra_targets) {
	&xml_print ("<source name=\"$src\" />\n");
    }
    &xml_leave ();
    &xml_print ("</target>\n");
    
    foreach $target (keys %targets) {
	&xml_print ("<target name=\"$target\" type=\"$targets_type{$target}\">\n");
	&xml_enter ();
	$ref = $targets{$target};
	@tmp = @$ref;
	foreach $src (@tmp) {
	    &xml_print ("<source name=\"$src\" />\n");
	}
	&xml_leave ();
	&xml_print ("</target>\n");
    }
    
    &xml_leave ();
    print "</project>\n";
}

# --- XML parsing --- #

sub xml_parse_target
{
    my $tree = $_[0];
    my @sources;

    $name = $$tree[0]->{name};
    $type = $$tree[0]->{type};

    shift @$tree;

    while (@$tree) {
	if ($$tree[0] eq "source") {
	    $ref = $$tree[1];
	    $sname = $$ref[0]->{name};

	    @sources = (@sources, $sname);
	}

	shift @$tree;
	shift @$tree;
    }

    $targets{$name} = [@sources];
    $targets_type{$name} = $type;
}

sub xml_parse_project
{
    my $tree = $_[0];

    $pd = $$tree[0]->{name};
    $pd eq $project_dir || die "Directories do not match.";

#    print "Project -> $name\n";

    shift @$tree;  # Skip attributes.

    while (@$tree) {
	if ($$tree[0] eq "target") { &xml_parse_target($$tree[1]); }

	shift @$tree;
	shift @$tree;
    }
}

sub xml_parse
{
    $parse_tree = $tree = &xml_scan;

    # Walk the tree recursively and extract configuration parameters.

    while (@$tree) {
	if ($$tree[0] eq "project") { &xml_parse_project($$tree[1]); }

	shift @$tree;
	shift @$tree;
    }
    
    return($tree);
}

# --- Get (read) config --- #

sub get
{
  if ($verbose) { print STDERR "Getting project, generating XML output.\n"; }
  &extract_targets ($project_dir);

  if ($verbose) { print STDERR "Printing XML.\n"; }
  &xml_print_project ();
}

# --- Set (write) config --- #

sub set
{ 
    &xml_parse ();
#    &xml_print_project ();
    
    &write_targets ();
}

# --- Usage and version --- #

sub usage 
{
    print $Usage; 
    exit(0);
}

sub version
{
    print "$version\n";
    exit (0);
}

# --- Main --- #

# Process options.

while (@ARGV)
{
  if    ($ARGV[0] eq "--get"     || $ARGV[0] eq "-g") { $operation = "get"; }
  elsif ($ARGV[0] eq "--set"     || $ARGV[0] eq "-s") { $operation = "set"; }
  elsif ($ARGV[0] eq "--verbose" || $ARGV[0] eq "-v") { $verbose = 1; }
  elsif ($ARGV[0] eq "--help"    || $ARGV[0] eq "-h") { $operation = "usage"; }
  elsif ($ARGV[0] eq "--version")                     { $operation = "version" }
  else {
    if ($project_dir ne "") {
	print STDERR "Error: You may specify only one project directory.\n\n";
	print STDERR $Usage; exit(1);
    }

    $project_dir = $ARGV[0];
    if (!-e $project_dir || !-d $project_dir) {
	print STDERR "Error: project directory does not exist\n\n";
	print STDERR $Usage; exit(1);
    }

    if (!-e "$project_dir/$make_am_file" || !-e "$project_dir/$conf_file") {
	print STDERR "Error: project directory does not contain appropriate files\n\n";
	print STDERR $Usage; exit(1);
    }
  }

  shift @ARGV;
}


# Do our thing.
if ($project_dir eq "") {
    print STDERR "Error: No project directory specified.\n\n";
    print STDERR $Usage; exit(1);
}

if    ($operation eq "get")     { &get; }
elsif ($operation eq "set")     { &set; }
elsif ($operation eq "usage")   { &usage; }
elsif ($operation eq "version") { &version; }
else {
  print STDERR "Error: No operation specified.\n\n";
  print STDERR $Usage; exit(1);
}

