#!/usr/bin/perl -w

# Rev. 2002-09-02
#
# noWeb tangle perl version
#
# recognizes
# @ as document start
# <<...>>= as code start

# BUG if a unknown chunk is specified
#   the whole line is skipped
#   OR SAY PREMATCH and POSTMATCH are not garanteed to be printed


use English;

$debugPrint = 0;

# prototypes
sub Expand($$);
sub storeCCode($$);
sub lookForChunkRef($);
sub differs($$);


# get path for output files
my ($textPath) = $ARGV[0] =~ /^(.+:).+$/;
$textPath .= "TANGLED/";

print( "INP.: <$ARGV[0]>\n" );
print( "PATH: <$textPath>\n" );

my $DosEOL  = "\x0d\x0a";    # DOS file
my $MacEOL  = "\x0d";        # mac file
my $UnixEOL = "\x0a";        # unix file

$/ = $UnixEOL;      # input record separator
$OutEOL = $UnixEOL;

my %code = ();      # hash array of code chunks: idx chunk name
my %codeRef = ();   # hash array of code chunks references:
                    #  idx referenced chunks name

my ($docs,$cods,$lns);  # chunk counter

my $state = 0;   # doc chunk at start
                 # code chunks = 1
# BUG beaware of multiple files dropped

my $codeName = "";  # last code chunks name
my $ccode = "";     # current code chunk

while (<>) {
  $lns++;
	$_ =~ s/[\x0d\x0a]*$//;	# remove end of line and trailing 
  if(( $_ =~ /^@/ )and( $state != 0 )){
    # a documentation chunk, ends code chunk, is ignored
    print( "$. doc: $_\n" ) if( $debugPrint > 0 );
    $docs++;
    $state = 0;
  }elsif( $_ =~ /^<<.+>>=/ ){
    # a new code chunk, ends any doc or code chunk
    storeCCode( $codeName, $ccode );
   
    ($codeName) = $_ =~ /<<(.+)>>=/;
    $ccode = "";
    print( "$. cod: <$codeName>\n" ) if( $debugPrint > 0 );
    $cods++;
    $state = 1;
  }elsif( $state == 1 ){
    # append line to current code chunk
    $ccode .= $_ . "\n";
    lookForChunkRef( $_ );
  }
}

storeCCode( $codeName, $ccode );

my @errors = ();

print( "$lns lines, $docs document chunks and $cods code chunks\n" );

foreach $key (keys %code){
  my $exp_column = 0;  # column for chunk name printing
  print( "CHUNK : <$key>\n" )            if( $debugPrint > 0 );
  if( defined( $codeRef{ $key } ) ){
    print( "  REF: $codeRef{ $key }\n" ) if( $debugPrint > 0 );;
  }else{
    print( "  ROOT\n" )                 if( $debugPrint > 0 );
    print( "<<$key>>=\n" )               if( $debugPrint == 0 );
    $exp_column = 0;
    if( $key eq "*" ){
      # the root chunk
      open( OUTF, ">$textPath"."DEF" );
      Expand( $key, "" );
      close( OUTF );
    }elsif( $key !~ /\s/ ){
      # if there is no white space in the chunk name its a filename
      my $tmpfn = "$textPath"."noptangle.out";
      open( OUTF, ">$tmpfn" );
      Expand( $key, "" );
      close( OUTF );
	    my $outfn = "$textPath"."$key";
			if (differs($tmpfn,$outfn)) {
			  unlink($outfn);
				rename($tmpfn,$outfn);
			  print("\n$outfn is new.\n");
			} else {
			  print("\n$outfn is unchanged.\n");
			}
    }else{
      print( "  STRANGE ROOT\n" );
      push(@errors,$key." STRANGE ROOT");
    }
  }
}
if (@errors) {
  print( join("\n",@errors), "\n" );
}
print( "fini\n" );


# --- FUNCTIONS ---

my %expChunks = ();  # currently expanding chunks;
                     # prevent from circulars
sub Expand($$){
  my $cname = $_[0];
  my $ind = $_[1];   # prepend to lines

  if( defined( $expChunks{ $cname } ) ){
    print( "\n ERROR <<$cname>> already expanding\n" );
    push(@errors,$cname." ALREADY EXPANDING.");
    return;
  }elsif( ! defined( $code{ $cname } ) ){
    print( "\n ERROR: <<$cname>> undefined\n" );
    push(@errors,$cname." UNDEFINED CHUNK.");
    return; 
  }else{
    if($exp_column>4) {
      print("\n");
      $exp_column = 0;
    }
    $exp_column++;
    print( "  $exp_column $cname," );
  };
  
  $expChunks{ $cname } = 1;
  foreach (split( /\n/, $code{ $cname } )){
    if( $_ =~ /<<(.+)>>/ ){
      # does work only with chunk references on separate lines
      my ($ncname) = $_ =~ /<<(.+)>>/; 
      my $pre  = $PREMATCH;
      my $post = $POSTMATCH;
      if( $pre =~ /\S/ ){  # non white indentation
        print( "  $pre\n" ) if( $debugPrint > 1 );
        
        print( OUTF "$pre$OutEOL" );
        $pre =~ s/./ /g;
      }
      print( "  $pre\n" ) if( $debugPrint > 1 );
      print( "  $ncname\n" ) if( $debugPrint > 1 );
      print( "  $post\n" ) if( $debugPrint > 1 );
      Expand( $ncname, $pre );
    	if (length($post)>0) { 
	      print( OUTF "$post$OutEOL" );
      }
    }else{
      # indentation gets wrong
      print( OUTF "$ind$_$OutEOL" );
    };
  };
  undef( $expChunks{ $cname } );
}

sub storeCCode($$){
  # store second param under first param
  my ($codeName, $ccode) = @_;
  
  return if( $codeName eq "" );

  if( defined( $code{ $codeName } ) ){
    $code{ $codeName } .= $ccode;
  }else{
    $code{ $codeName } = $ccode;
  }
}

sub lookForChunkRef($){
  # look for chunk references
  my @cref = $_[0] =~ /<<(.+)>>/g;
  my $i;
  foreach (@cref){
    print( "  $_\n" ) if( $debugPrint>1 );
    if( defined( $codeRef{ $_ } ) ){
      $codeRef{ $_ } .= ">>" . $codeName;
    }else{
      $codeRef{ $_ } = $codeName;
    }
  }
}

sub differs($$) {
  my ($f1,$f2) = @_;
  if ((not -e $f1) or (not -e $f2)) {
	  return 1;
	}	
	my $s1,$s2;
	local *INF;
	open(INF,"$f1");
	my @a = <INF>;
	close(INF);
	$s1 = join("",@a);

	open(INF,"$f2");
	my @a = <INF>;
	close(INF);
	$s2 = join("",@a);

  if ($s1 ne $s2) {
	  return 1;
	}	
  return 0;
}