p2html.pl to HTML.

index -|- end

Generated: Tue Feb 2 17:54:49 2010 from p2html.pl 2005/05/06 11.4 KB. 

#!/perl
use strict;
my $WHITE_PATTERN2 = "^[ \t\n\r]*\$"; # spacey if ($var =~ /$WHITE_PATTERN2/o ) { ...}
my $tab_stg = '   '; # replace tabs, with 3 spaces
my $verb2 = 0;
my $perlstx = 'C:/Program Files/EditPlus 2/perl.stx';
my $DELIMITER = ',(){}[]-+*/=~!&|<>?:;.';
my @stx = ();
my @stxc;
my $logfil = 'templog.txt';
my $infile = shift || '.';
my $outfil = shift || 'tempout.htm';
my ($OF, $IF, $LF, $STX);
my $name;
###               l.blue brown  l.br  s.gr pink   mauve  b.gr   l.br  blue wh    l.gr
my @TTColors = qw(match orange regex green color1 color2 color3 peach blue white grey);
for $name (@TTColors) {
   no strict 'refs';       # allow symbol table manipulation
    *$name = *{uc $name} = sub { "<TT class='$name'>@_</TT>" };
}
###my @colors = qw(red blue green yellow orange purple violet);
my @colors = qw(red yellow purple violet);
for $name (@colors) {
   no strict 'refs';       # allow symbol table manipulation
    *$name = *{uc $name} = sub { "<FONT COLOR='$name'>@_</FONT>" };
}
my $msg = '';
my ($line, $txt);
my $i = 0;
my ($cnt1, $cnt2);
if ($infile eq '.') {
   die "No input file given ...\n";
}
open $LF, ">$logfil" or die "Can NOT open LOG file $logfil!\n";
tolog ("$0 Started " . localtime(time()) . " ...\n");
if (! -f $infile) {
   die "Input file [$infile] NOT FOUND! ...\n";
}
tolog ("Opening $infile ...\n");
open $IF, "<$infile" or die "Can not OPEN $infile!\n";
tolog ("Loading $infile ...\n");
my @lines = <$IF>; # slurp whole file, to an array of lines
close($IF);
open $STX, "<$perlstx" or die "Can NOT locate $perlstx file...\n";
@stx = <$STX>;
close($STX);
open $OF, ">$outfil" or die "Can not create $outfil!\n";
$i = @stx;
tolog ("List of $i STX file lines...\n");
my %stxh;
my @ResWds = ();
my @BFuncs = ();
my %HResWds;
my %HBFuncs;
my $sw = 0; # no switch on
foreach $line (@stx) {
   chomp $line;
   my $ll = length($line); # get LENGTH of file line
   my @a;
   my $k;
   my $v;
   my $c = substr ($line, 0, 1);
   $msg = '';
   if ($c eq ';') { # comment
      $msg = 'comment only';
   } elsif ($c eq '#') { # hash item=value
      $msg = ' hash';
      @a = split('=', $line); # get key/value
      ($k, $v) = @a;
      $k = substr($k, 1);
      ###$stxh{$a[0]} = $a[1];
      if ( exists $stxh{$k} ) {
         if ($stxh{$k} eq $v) {
            $msg .= ' same ';
         } else {
            $msg .= ' new ';
         }
         $stxh{$k} .= '|' . $v;
         ###$v = $stxh{$k};
      } else {
         $stxh{$k} = $v;
      }
      ### $msg .= ' k=' . $a[0] . ' v=' . $a[1] . '-'; 
      ###$msg .= ' k=' . $k . ' v=' . $v . ' - '; 
      $msg .= ' k=' . $k . ' v=' . $stxh{$k} . ' - '; 
      #KEYWORD=Reserved words
      #KEYWORD=Built-in functions
#      if ($a[0] eq '#KEYWORD') {
#         if ($a[1] eq 'Reserved words') {
#            $sw = 1;
#            $msg .= '(ResWds)';
#         } elsif ($a[1] eq 'Built-in functions') {
#            $sw = 2;
#            $msg .= '(BFuncs)';
#         } else {
#            $sw = 0;
#         }
#      }
      if ($k eq 'KEYWORD') {
         if ($v eq 'Reserved words') {
            $sw = 1;
            $msg .= '(ResWds)';
         } elsif ($v eq 'Built-in functions') {
            $sw = 2;
            $msg .= '(BFuncs)';
         } else {
            $sw = 0;
         }
      }
   }
   if ($ll > 1) {
      if ($sw == 1) {
         push(@ResWds, $line);
         if ( exists $HResWds{$line} ) {
            die "Duplicate RESERVE WORD [$line]\n"
         }
         $HResWds{$line} = $line;
         $msg .= " - rw+";
      } elsif ($sw == 2) {
         push(@BFuncs, $line);
         if ( exists $HBFuncs{$line} ) {
            die "Duplicate BUILT-IN FUNCTION [$line]\n"
         }
         $HBFuncs{$line} = $line;
         $msg .= " - bf+";
      }
   }
   tolog ($line . $msg . "\n");
}
$line = 'new';
if ( ! exists $HBFuncs{$line} ) {
   $msg = ' ++Added';
   push(@BFuncs, $line);
   $HBFuncs{$line} = $line;
   tolog ($line . $msg . "\n");
}
$cnt1 = @ResWds;
$cnt2 = @BFuncs;
tolog ("END List of $i STX file lines...rw=$cnt1 bf=$cnt2 \n");
add_html_head( $OF, $infile );
### add_html_tail($OF);
my $lncnt = @lines; # get count
tolog ("Processing $infile ... $lncnt lines\n");
my $lc = 0;
my $dnpara = 1;
my @lnbits;
my $chk;
## my $func;
prt ("<p>\n");
foreach $line (@lines) {
   $txt = $line;
   chomp $txt;
   @lnbits = split(' ',$txt);
   $lc++;
   #$func = 0;
   if ($txt =~ /$WHITE_PATTERN2/o ) {
      $txt = "</p>\n<p>\n"; # CLOSE paragraph, and open
   } elsif ($txt =~ m/^\#/)  { ## [0] eq '#')
   ###if ($txt =~ m/^\#/)  { ## [0] eq '#')
      $txt .= " ";
      $txt .= red("(comment)");
      #$func = \&green;
      $txt = green($txt);
      $txt .= "<br>\n"; # set new line
   } else {
      $txt = htmlise($txt);
      $txt .= "<br>\n";
   }
   prt ($txt);
   do_line_parse ($line);
}
tolog ("Processed $lc lines of $infile ... written to $outfil ...\n");
prt ("</p>\n");
add_html_tail($OF);
close($OF);
 system $outfil;
# system $logfil;
sub prt {
   tolog (@_);
   print $OF @_;
}
sub addTTitem {
   my ($fh, $nm, $bd, $bg) = @_;
   print $fh <<"EOF3";
TT.$nmm
{
    BORDER-TOP: $bd 1px solid;
    BORDER-LEFT-WIDTH: 1px;
    BORDER-LEFT-COLOR: $bd;
    PADDING-BOTTOM: 1px;
    PADDING-TOP: 1px;
    BORDER-BOTTOM: $bd 1px solid;
    WHITE-SPACE: nowrap;
    BACKGROUND-COLOR: $bg;
    BORDER-RIGHT-WIDTH: 1px;
    BORDER-RIGHT-COLOR: $bdd
}
EOF3
}
sub add_html_style {
   my ($fh) = @_;
   print $fh <<"EOF1";
<style><!--
TT
{
    FONT-FAMILY: 'Andale Mono', 'Lucida Console', monospace
}
EOF1
#################################
###my @TTset = qw( match #0066ff #e8f4ff string #0000ff #ccccff );
 my @TTset = (
    "match", "#0066ff", "#e8f4ff",
    "string", "#0000ff", "#ccccff",
    "orange", "#ff6600", "#ffcc99",
    "regex",  "#ff6600", "#fff4e8",
    "green",  "#006400", "#ccffcc",
    "color1", "#ff6600", "#ff99cc",
    "color2", "#0066ff", "#cc99ff",
    "color3", "#00a000", "#ccff99",
    "peach",  "#0066ff", "peachpuff",
    "blue",   "blue",    "powderblue",
    "white",  "#ffffff", "#ffffff",
    "grey",   "#909090", "#dddddd" );
 my $nm;
 my $bd;
 my $bg;
 my $mx = @TTset;
 tolog ("Processing $mx / 3 styles ...\n");
 tolog ( @TTset . "\n" );
 my $i;
 ## ??while (($nm, $bd, $bg) = @TTset) {
 for ($i = 0; $i < ($mx / 3); $i++) {
    $nm = $TTset[($i*3)+0];
    $bd = $TTset[($i*3)+1];
    $bg = $TTset[($i*3)+2]; 
    addTTitem ($fh, $nm, $bd, $bg);
 }
###################################
   print $fh <<"EOF2";
--></style>
EOF2
}
sub add_html_head {
   my ($fh, $hdr) = @_;
   print $fh <<"EOF";
<html>
<head>
<title>$hdr</title>
</head>
EOF
   add_html_style($fh);
   print $fh <<"EOF";
<body>
<h1 align="center">$hdr</h1>
EOF
}
sub add_html_tail {
   my ($fh) = @_;
   add_color_samp($fh);
   print $fh <<"EOF";
</body>
</html>
EOF
}
sub add_color_samp {
   my ($fh) = @_;
### my @TTColors = qw(match orange regex green color1 color2 color3 peach blue white grey);
   print $fh "<p> Colours ";
   foreach $name (@TTColors) {
      ###no strict 'refs'; # allow symbol table manipulation
      my $func = \&$name; ## get the function - the auto-generated sub
      ###$txt = \&$name($name);
      $txt = $func->($name); # suround the text
      print $fh "[";
      ###print $fh match($name);
      print $fh $txt;
      print $fh "]";
   }
   print $fh "</p>\n";
}
sub tolog {
   print @_;
   print $LF @_;
}
sub do_line_parse {
   my ($tx) = @_;
   my $tx2;
   my $tx3;
   my $tx4 = htmlise($tx);
   my $c1 = substr ($tx, 0, 1); # get and keep first char
   @lnbits = split (' ', $tx); # initial split spaces
   my $cnt = @lnbits; # count of componets, so far
   my $i = 0;
   if ($tx =~ /$WHITE_PATTERN2/o ) {
      $cnt = 0;
   }
   if ($cnt) {
      if ($lnbits[0] =~ m/^\#/) {
         # is comment
         tolog ("Is comment - try ...\n");
         $tx3 = green($tx4);
         $tx3 .= "<br>\n";
         prt ($tx3);
      } else {
         # multi-components
         my $i2 = 0;
         my $i3 = 0;
         tolog ("{ comps $cnt\n");
         foreach $tx2 (@lnbits) {
            $i2++;
            $msg = $tx2;
            my $ln = length($tx2);
            my $ch = substr ($tx2, 0, 1);
            $i = 0;
            ### special +?.*^$()[]{}|\
            if ($tx2 =~ /^['"]/ ) { ## "' # does it start with quotes d or s
            #### if (($ch eq '"')||($ch eq "'")) {
               ### $msg .= " begin quote";
               $i = 1;
               if ($ln > 1) {
                  if (substr ($tx2, 1, $ln - 1) =~ /$ch/) {
                     $msg .= " begin [$1] and end [$2] same quotes";
                     $i = 0;
                  } else {
                     $i = 1;
                  }
               }
               if ($i) {
                  # should JOIN until the END
                  $i3 = 0;
                  for ($i = $i2; $i < $cnt; $i++) {
                     $tx3 = $lnbits[$i]; # get next
                     $tx2 .= ' '; # add back space
                     $tx2 .= $tx3; ### $lnbits[$i];
                     $i3++;
                     if ($tx3 =~ /$ch/) {
                        last; # exit when terminator found
                     }
                  }
                  $lnbits[$i2 - 1] = $tx2; # put back single quoted message
                  ###splice (@lnbits, $i2, $cnt - $i2); # collapse following items
                  splice (@lnbits, $i2, $i3); # collapse following items
                  $msg = $tx2;
                  $msg .= ", now joined, to its end";
               }
            } elsif ($ch eq '#') { # if starts with a comment
               ## should join to end of line
               $i3 = 0;
               for ($i = $i2; $i < $cnt; $i++) {
                  $tx3 = $lnbits[$i];
                  $tx2 .= ' ';
                  $tx2 .= $tx3; ### $lnbits[$i];
                  $i3++;
               }
               $lnbits[$i2 - 1] = $tx2; # put back single quoted message
               ###splice (@lnbits, $i2, $cnt - $i2); # collapse following items
               splice (@lnbits, $i2, $i3); # collapse following items
               $msg = $tx2;
               $msg .= ", line comment";
            } else {
               ## not begin quote, nor begin # ...
               if ( exists $HResWds{$tx2} ) {
                  $msg .= 'B'; ### blue('R');
                  $i3++;
               }
               if ( exists $HBFuncs{$tx2} ) {
                  $msg .= 'P';
                  $i3++;
               }
            }
            tolog ($msg . "\n");
         } # for array list of line components
         tolog ("} end comps $cnt\n");
         if ($i3) {
            my $nct = @lnbits;
            tolog ("{{ $nct");
            $tx3 = ''; # clear output
            if ($c1 eq ' ') {
               $tx3 = '&nbsp; ';
            }
            foreach $tx2 (@lnbits) {
               my $c = substr ($tx2, 0, 1);
               $tx3 .= ' ' if length($tx3);
               $msg = $tx2;
               if ($tx2 =~ /^['"]/ ) { ## "' # does it start with quotes d or s
                  if ($c eq "'") {
                     $tx3 .= green($tx2);
                  } else {
                     $tx3 .= color3($tx2);
                  }
               } elsif ( exists $HResWds{$tx2} ) {
                  $msg = blue($tx2);
                  $tx3 .= blue($tx2);
               } elsif ( exists $HBFuncs{$tx2} ) {
                  $msg = color2($tx2); ## purple($tx2);
                  $tx3 .= color2($tx2); ## purple($tx2);
               } else {
                  $tx3 .= $tx2;
               }
               tolog (' [' . $msg . ']');
            }
            tolog ("}}\n");
            $tx3 .= "<br>\n";
            prt ($tx3);
         }
      }
   } else {
      chomp $tx;
      tolog ("all space - no components - [$tx]\n");
   }
}
sub htmlise {
   my ($txt) = @_;
   # convert to HTML
   $txt =~ s/\t/$tab_stg /g; # substitute TAB characters
   $txt =~ s/"/&quot;/g; # sub double quotes
   $txt =~ s/\</&lt;/g; # sub less than tag beginning
   $txt =~ s/\>/&gt;/g; # and html/xml tag ending
   my $ln = length($txt); # get the final length
   if (substr ($txt, 0, 1) eq ' ') { # if starts with a space
      my $sps = 0;
      my $nbs = '&nbsp;';
      for ($sps = 1; $sps < $ln; $sps++) {
         if (substr ($txt, $sps, 1) ne ' ') {
            last;
         }
         $nbs .= '&nbsp;' if $sps > 1;
      }
      $sps-- if $sps > 1; # back off last space, if more than 1
      tolog ("Replacing $sps with [$nbs] ...\n") if $verb2;
      $txt =~ s/ {$sps}/$nbs/; # replace (N) spaces with '&nbsp; x N
      if ($verb2) {
         my (@vals) = split;
         while (@vals) {
            my ($vc) = shift (@vals);
            tolog ("[$vc] ");
         }
         tolog ("\n");
      }
   } # if it was space beginning
   #if ($func) {
   #   $txt = $func->($txt);
   #}
   #$txt .= "<br>\n";
   return $txt;
}

index -|- top

checked by tidy  Valid HTML 4.01 Transitional