p2h01.pl to HTML.

index -|- end

Generated: Tue Feb 2 17:54:47 2010 from p2h01.pl 2006/08/28 5.3 KB.

#!/Perl
print "Hello, World...\n";
my ($LF, $OF);
my $out_file = "tempout01.txt";
my $log_file = "tempp2h01.txt";
###my $in_file = "am2dsp5.pl";
my $in_file = "testiso2.pl";
# load perl.stx file
my $perlstx = 'C:/Program Files/EditPlus 2/perl.stx'; ### fix location - should maintain separate list???
my @ResWds = ();
my @BuiltIns = ();
my @lines = ();
my $line = '';
open $LF, ">$log_file" or die "ERROR: Unable to open LOG file $log_file ... aborting ...\n";
load_stx_file( $perlstx );
prt( "Got ".scalar @ResWds." Reserved Words, and ".scalar @BuiltIns." Built-in functions ...\n" );
process_file( $in_file );
prt( "Got ".scalar @lines." new lines ...\n" );
open $OF, ">$out_file" or die "ERROR: Unable to create $out_file ... aborting ...\n";
foreach $line (@lines) {
   print $OF $line;
}
close($OF);
close($LF);
############################
### sub below
sub add_class_a {
   my ($t) = shift;
   return ('<span class="a">'.$t.'</span>');
}
sub add_class_b {
   my ($t) = shift;
   return ('<span class="b">'.$t.'</span>');
}
sub add_class_c {
   my ($t) = shift;
   return ('<span class="c">'.$t.'</span>');
}
sub add_class_d {
   my ($t) = shift;
   return ('<span class="d">'.$t.'</span>');
}
sub add_class_e {
   my ($t) = shift;
   return ('<span class="e">'.$t.'</span>');
}
sub add_class_q {
   my ($t) = shift;
   return ('<span class="q">'.$t.'</span>');
}
sub in_res_words {
   my ($t) = shift;
   foreach my $rw (@ResWds) {
      if ($t eq $rw) {
         return 1;
      }
   }
   return 0;
}
sub in_built_in {
   my ($t) = shift;
   foreach my $rw (@BuiltIns) {
      if ($t eq $rw) {
         return 1;
      }
   }
   return 0;
}
sub process_file {
   my ($in_file) = shift;
   my ($IF);
   open $IF, "<$in_file" or die "ERROR: Unable to open $in_file ... aborting ...\n";
   my @lns = <$IF>; # slurp into line array
   close($IF);
   prt( "Got ".scalar @lns." to process ...\n" );
   my $st = 0; # current status
   foreach my $ln (@lns) {
      my $tok = '';
      my $ch = '';
      my $len = length($ln);
      my $nline = '';
      for (my $i = 0; $i < $len; $i++) {
         $ch = substr($ln, $i, 1);
         if ($st == 0) {
            # in white space territory
            if ($ch =~ /\S/) {
               # changed to NOT white space
               $nline .= $tok; # add any white space to new line
               $tok = '';
               if ($ch eq '#') {
                  # start of a COMMENT
                  $tok = $ch;
                  $i++;
                  for ( ; $i < $len ; $i++) {
                     $ch = substr($ln, $i, 1);
                     if (($ch eq "\r")||($ch eq "\n")) {
                        $tok = add_class_b($tok);
                        $tok .= $ch;
                        $i++;
                        if ($i < $len) {
                           $tok .= substr($ln, $i); 
                        }
                        $i = $len;
                        last;
                     }
                     $tok .= $ch;
                  }
                  $nline .= $tok;
                  $tok = '';
                  last;
               } elsif (($ch eq '"')||($ch eq "'")) {
                  my $bch = $ch;
                  $tok = $ch;
                  $i++;
                  for ( ; $i < $len; $i++ ) {
                     $ch = substr($ln, $i, 1);
                     if ($ch eq $bch) {
                        $tok .= $ch;
                        $nline .= add_class_q($tok);
                        $tok = '';
                        last;
                     }
                     $tok .= $ch;
                  }
                  next;
               }
               $tok = $ch;
               if ($ch =~ /\w/) {
                  $st = 1;
               } else {
                  $st = 2;
               }
               next;
            } else {
               # staying in white space
               $tok .= $ch;
               next;
            }
         } elsif ($st == 1) {
            # dealing with alphanumberic + _
            if ($ch =~ /\w/) {
               $tok .= $ch;
               next; # continue alphanumeric + _
            }
            # no longer an_
            if (length($tok)) {
               if (in_res_words($tok) ) {
                  $nline .= add_class_c($tok);
               } elsif (in_built_in($tok)) {
                  $nline .= add_class_d($tok);
               } else {
                  $nline .= $tok;
               }
            }
            $st = 2;
            $tok = $ch;
            next;
         } elsif ($st == 2) {
            # not space or an_
            if ($ch =~ /\s/) {
               # change back to space
               $nline .= $tok;
               $tok = $ch;
               $st = 0;
               next;
            } elsif ($ch =~ /\w/) {
               # change back to an_
               $nline .= $tok;
               $tok = $ch;
               $st = 1;
               next;
            }
            $tok .= $ch;
         }
      }
      $nline .= $tok;
      push(@lines, $nline);
   }
}
sub trim_line {
   my ($l) = shift;
   chomp $l;
   $l =~ s/\r$//; # and remove CR, if present
   $l =~ s/\t/ /g;
   $l =~ s/\s\s/ /g while ($l =~ /\s\s/);
   $l = substr($l,1) while ($l =~ /^\s/);
   $l = substr($l,0,length($l)-1) while (($l =~ /\s$/)&&(length($l)));
   return $l;
}
sub load_stx_file {
   my ($in_file) = shift;
   my ($IF);
   my @stx = ();
   my %dchk = ();
   open $IF, "<$in_file" or die "ERROR: Unable to open $in_file ... aborting ...\n";
   @stx = <$IF>; # slurp entire file into array
   close($IF);
   my $scnt = scalar @stx;
   prt( "Got $scnt lines in $in_file to process ...\n" );
   my $st = 0;
   foreach my $ln (@stx) {
      my $tln = trim_line($ln);
      my $ll = length($tln);
      next if ($ll == 0);
      if( $tln =~ /^\#KEYWORD=Reserved words/ ) {
         $st = 1;
         next;
      } elsif ($tln =~ /^\#KEYWORD=Built-in functions/ ) {
         $st = 2;
         next;
      } elsif (($tln =~ /^\#/) || ($tln =~ /^;/)) {
         $st = 0;
         next;
      }
      if (exists $dchk{$tln}) {
         prt( "Warning: Avoiding duplicate of [$tln] ...\n" );
         next;
      }
      $dchk{$tln} = 1;
      if( $st == 1 ) {
         push(@ResWds, $tln);
      } elsif ($st == 2) {
         push(@BuiltIns, $tln);
      }
   }
}
sub prt {
   my ($m) = shift;
   print $m;
   print $LF $m;
}

index -|- top

checked by tidy  Valid HTML 4.01 Transitional