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; }