bin/fill_diacode.pl

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 my $diacodefile = $ARGV[0];
   6 my $subcodefile = $ARGV[1];
   7 my $use_debug_class = @ARGV > 2 ? $ARGV[2] : 1;
   8
   9 print "$diacodefile does not exist\n" unless ( -e $diacodefile );
  10 print "$subcodefile does not exist\n" unless ( -e $subcodefile );
  11
  12 open ( DIACODE, $diacodefile );
  13 my @diacode = <DIACODE>;
  14 close ( DIACODE );
  15
  16 open ( SUBCODE, $subcodefile );
  17 my @subcode = <SUBCODE>;
  18 close ( SUBCODE );
  19
  20 open ( NEWCODE, '>tmp.txt' );
  21
  22 my $in_sub = 0;
  23 my $diacode_line_number = 1;
  24 my @include  = ();
  25
  26 my $package;
  27 my $have_package = 0;
  28
  29 my ( $junk, $junk2, $sub );
  30 my @transfer = ();
  31 my $in_non_dia = 0;
  32
  33 foreach ( @diacode ) {
  34   $diacode_line_number ++;
  35
  36   if( $have_package ){
  37     foreach ( @subcode ) {
  38       next unless ( /\s*start include statements/ or $in_sub );
  39       if ( /\s*start include statements/ ) {
  40         $in_sub = 1;
  41         next;
  42       }
  43       if ( /\s*end include/ ) {
  44         $in_sub = 0;
  45         push( @include, "use debug;\n" ) unless( $package eq 'debug.pm' or ! $use_debug_class );
  46         last;
  47       }
  48       push ( @include, $_ );
  49     }
  50
  51     if( $in_sub ){
  52       die "Warning, no end of include statements found in $subcodefile \n";
  53     }
  54
  55     $diacode_line_number += scalar( @include ) + 1;
  56     print NEWCODE @include, "\n";
  57     $have_package = 0;
  58   }
  59
  60   if ( /^package / ) {
  61     ($junk, $package, $junk2) = split(' ', $_, 3);
  62     $package =~ s/\;//;
  63     $have_package = 1;
  64   }
  65
  66   if ( /^sub / ) {
  67     ($junk, $sub, $junk2) = split(' ', $_, 3);
  68   }
  69
  70   if( /# Start of Non-Dia code #/ ) {
  71     my $line_number = 1;
  72     foreach ( @subcode ) {
  73       $line_number ++;
  74       next unless ( /\s*start $sub\s*$/ or $in_sub );
  75       if ( /\s*start $sub\s*$/ ) {
  76         $in_sub = 1;
  77         if( $package ne 'debug' and $use_debug_class ) {
  78           if ( $sub eq 'new' ) {
  79             push( @transfer, '        \'debug\' -> warn(level => 3, message => "Entering \t" . ref($this). \'-> '.$sub."\');\n" );
  80           } else {
  81             push( @transfer, '        \'debug\' -> warn(level => 3, message => "Entering \t" . ref($self). \'-> '.$sub."\');\n" );
  82           }
  83         }
  84         push ( @transfer,"# line $line_number \"$subcodefile\" \n" );
  85         next ;
  86       }
  87       if ( /\s*end $sub\s*$/ ) {
  88         $in_sub = 0;
  89         $diacode_line_number += scalar( @transfer ) + 1;
  90         my $local_diacode_file = $diacodefile;
  91         $local_diacode_file =~ s/_temp//;
  92         push ( @transfer,"# line $diacode_line_number $local_diacode_file \n" );
  93         if( $package ne 'debug' and $use_debug_class ) {
  94           $diacode_line_number ++;
  95           if ( $sub eq 'new' ) {
  96             push( @transfer, '        \'debug\' -> warn(level => 3, message => "Leaving \t" . ref($this). \'-> '.$sub."\');\n" );
  97           } else {
  98             push( @transfer, '        \'debug\' -> warn(level => 3, message => "Leaving \t" . ref($self). \'-> '.$sub."\');\n" );
  99           }
 100         }
 101         last;
 102       }
 103       push ( @transfer, $_ );
 104     }
 105   }
 106
 107
 108   if ( /# End of Non-Dia code #/ ) {
 109        $in_non_dia = 0;
 110        print NEWCODE @transfer;
 111        @transfer = ();
 112   }
 113   print NEWCODE;
 114 }
 115
 116 close ( NEWCODE );
 117
 118 system( "mv tmp.txt $diacodefile" );