p2html6.pl to HTML.

index -|- end

Generated: Tue Feb 2 17:54:51 2010 from p2html6.pl 2005/05/09 30.1 KB.

#!/perl
### #################################################
### p2html - perl code to HTML document format
### Works, mostly - still a SPACE-REPLACEMENT problem ...
### Geoff - geoffmclane.com - geoffair _at_ hotmail _dot_ com
### ##################################################
use strict;
use warnings;
### global variables
my $vers = '0.0.6'; # fourth iteration, expanding line array ... LOOKS GOOD - settled down - trim
my $WHITE_PATTERN2 = "^[ \t\n\r]*\$"; # spacey if ($var =~ /$WHITE_PATTERN2/o ) { ...}
my $tab_stg = '   '; # replace tabs, with 3 spaces
my $verb2 = 0;
my $dbgon = 0; # 1 DOUBLES HTML OUTPUT FOR COMPARISON
my $perlstx = 'C:/Program Files/EditPlus 2/perl.stx';
my $DELIMITER = '(){}[]-+*/=~!&|<>?:;.,';
my $logfil = 'templog.txt';
my @logmsgs = ();
my ($OF, $IF, $LF, $STX);
my $colorON = 1;
my $name;
my $lc = 0;
my $dnpara = 1;
my @lnbits;
my @spbits;
my @copybits; ## keep, for ORIGINAL space work 'replacement'
my $chk;
my $istxt = 1;
### start of program
####################
### Get command line input ...
my $infile = shift || '.';
my $outfil = shift || 'tempout.htm';
## my $func;
my @TTColrs = qw(l.blue brown   l.br   s.green pink   mauve     b.green l.brn blue     white l.grey);
my @TTTypes  = qw(array comment unass  s-quote scalar functions d-quote hash  reserved other punctuation);
my @TTAttrib = qw(match orange  regex  green   color1 color2    color3  peach blue     white grey);
for $name (@TTAttrib) {
   no strict 'refs';       # allow symbol table manipulation
    *$name = *{uc $name} = sub { "<TT class='$name'>@_</TT>" };
   ### *$name = *{uc $name} = sub { "<TT class='$name'>\n@_\n</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>" };
}
### is this everything ? ;=))
### see sub ispunctuat ($ch) service
my @PPunct = ("&", "&&", "&&=", "&=",
   "<", "<<", "<<=", "<&=", "<&",
   "<=", "<==>", ">", ">&", ">>",
   ">>=", ">=",
   "*", "**", "**=", "*=", "*?",
   "@", "@*,", "@_",
   "`", "\\",
   "!", "!=",
   "^", "^=",
   ":", ",", "\$",
   ".", "\"",
   "=", "=>", "==", "=~",
   ">", "#", "-", "->",
   "-*-", "-=", "--", "-|",
   "%", "%=", 
   "+", "+=", "++", "+?",
   "#", "?", "?:", "?...?",
   "'", "\"", ";", "#!",
   "/", "/=", "//", "/.../",
   "~", "~~",
   "_","|", "|=", "|-", "||", "||=",
   "/o"
   );
my $msg = '';
my ($line, $txt);
my $i = 0;
my ($cnt1, $cnt2);
my $inbraces = 0;
my $c;
my $c3;
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 $OF, ">$outfil" or die "Can not create $outfil!\n";
###### pre-process perl.stx file ######################################
open $STX, "<$perlstx" or die "Can NOT locate $perlstx file...\n";
my @stx = <$STX>;
close($STX);
$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;
   $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 ($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") if $verb2;
}
$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");
###### end-process perl.stx file ######################################
add_html_head( $OF, $infile );
### add_html_tail($OF);
my $lncnt = @lines; # get count
tolog ("Processing $infile ... $lncnt lines\n");
prt ("<p>\n");
foreach $line (@lines) {
   $txt = $line;
   chomp $txt;
   $lc++;
   $istxt = 1; # assume text
   if ($txt =~ /$WHITE_PATTERN2/o ) {
      $txt = "</p>\n<p>\n"; # CLOSE paragraph, and open
      $istxt = 0; # NOT text
   } else {
      ### $txt = white(htmlise($txt));
      $txt = htmlise($txt);
      $txt .= "<br>\n";
   }
   if ( $istxt ) {
      if ($dbgon) {
         tolog ("Simple WHITE-ised to HTML file ...\n") if $verb2;
         prt ($txt); # just for COMPARISON
      }
   } else { ## if (! $istxt) {
      tolog ("Simple WHITE-ised to HTML file ...\n") if $verb2;
      prt ($txt); # just for COMPARISON
   }
   if ($istxt) {
      ###do_line_parse ($line);
      tolog ("Per line component parsing to HTML file ...\n") if $verb2;
      do_line_parse ($line);
   }
}
tolog ("Processed $lc lines of $infile ... written to $outfil ... add tail ...\n");
prt ("</p>\n");
add_html_tail($OF);
showarrcnts();
tolog ("$0 Ended " . localtime(time()) . " ...\n");
close($OF);
 system $outfil;
# system $logfil;
sub prt {
   tolog (@_);
   print $OF @_;
}
sub addTTitem {
   my ($fh, $nm, $bd, $bg) = @_;
   print $fh <<"EOF3";
.$nm { BACKGROUND-COLOR: $bg }
EOF3
}
sub addTTitem_full {
   my ($fh, $nm, $bd, $bg) = @_;
   print $fh <<"EOF3";
.$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",  "#909090", "#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>
<!-- P26.2005.05.10 geoffmclane.com perl
   HTML generated using p2html5.pl - 
  -->
<head>
<title>$hdr</title>
</head>
EOF
   # dynamic block of style - could be put to a file ...
   add_html_style($fh);
   print $fh <<"EOF";
<body>
<h1 align="center">$hdr</h1>
<p align="center"><a href="perl.htm">back</a></p>
<table align="center" width="90%" border="2" bgcolor="#eeeeff">
 <tr>
 <td>
EOF
}
sub add_html_tail {
   my ($fh) = @_;
   print $fh <<"EOF";
 </td>
 </tr>
</table>
EOF
   add_color_samp($fh);
   print $fh <<"EOF";
<p align="center"><a href="perl.htm">back</a></p>
</body>
</html>
EOF
}
my @TypeColors_NOTUSED = (
   ###if ($c eq '#') { # comment component - should be to end-of-line, or more ...
   "comment", ### $func = \&orange;
   ###} elsif ($c eq "'") { ## "' # does it start with quotes DOUBLE or SINGLE
   "s.quote", ### $func = \&green;
   ###   } elsif ($c eq '"') {
   "d.quote", ### $func = \&color3;
   ###} elsif ($c eq '$') { # start of scalar
   "scalar", ### $func = \&color1;
   ###} elsif ($c eq '@') { # start of array
   "array", ### $func = \&match;
   ###} elsif ($c eq '%') { # start of hash
   "hash", ### $func = \&peach;
   ###} elsif ( exists $HResWds{$tx2} ) {
   "reserved", ### $func = \&blue;
   ### } elsif ( exists $HBFuncs{$tx2} ) {
   "functions", ### $func = \&color2;
   ### } else {
   "other" ### $func = \&white;}
   );
sub a2f {
   my ($f,$t) = @_;
   print $f $t;
}
sub n_row {
   ###my ($f) = @_;
   a2f (@_, " <tr>");
}
sub n_col {
   ###my ($f) = @_;
   a2f (@_, "  <td>");
}
sub c_row {
   ###my ($f) = @_;
   a2f (@_, " </tr>");
}
sub c_col {
   ###my ($f) = @_;
   a2f (@_, "  </td>");
}
## my $func;
### my @TTColrs = qw(l.blue brown   l.br   s.green pink   mauve     b.green l.brn blue     white l.grey);
### my @TTTypes  = qw(array comment unass  s-quote scalar functions d-quote hash  reserved other punctuation);
### my @TTAttrib = qw(match orange  regex  green   color1 color2    color3  peach blue     white grey);
sub add_color_samp {
   my ($fh) = @_;
   $i = 0;
   print $fh <<EOF;
<p>Colour Key :<br>Function, Description., Colour<br>
<table border="1" bgcolor="#eeeeff">
EOF
   ### out attributes
   n_row $fh; # add " <tr>\n"; # open ROW
   n_col $fh; # add "  <td>\n"; # open COLUMN
   a2f $fh, "Style";
   c_col $fh; # add "  </td>\n"; # close COLUMN
   n_col $fh; # add "  <td>\n"; # open COLUMN
   a2f $fh, "Description";
   c_col $fh; # add "  </td>\n"; # close COLUMN
   n_col $fh; # add "  <td>\n"; # open COLUMN
   a2f $fh, "Colour";
   c_col $fh; # add "  </td>\n"; # close COLUMN
   c_row $fh; ### " </tr>\n"; # close ROW
   foreach $name (@TTAttrib) {
      ###no strict 'refs'; # allow symbol table manipulation
      my $fun = \&$name; ## get the function - the auto-generated sub
      n_row $fh; # add " <tr>\n"; # open ROW
      n_col $fh; # add "  <td>\n"; # open COLUMN
      ### a2f $fh, "Attributes";
      $msg = $name;
      $txt = $fun->($msg);
      a2f $fh, $txt;
      c_col $fh; # add "  </td>\n"; # close COLUMN
      n_col $fh; # add "  <td>\n"; # open COLUMN
      ### a2f $fh, "Function";
      $msg = $TTTypes[$i];
      $txt = $fun->($msg);
      a2f $fh, $txt;
      c_col $fh; # add "  </td>\n"; # close COLUMN
      n_col $fh; # add "  <td>\n"; # open COLUMN
      ### a2f $fh, "Colour"; @TTColrs
      $msg = $TTColrs[$i];
      $txt = $fun->($msg);
      a2f $fh, $txt;
      c_col $fh; # add "  </td>\n"; # close COLUMN
      c_row $fh; ### " </tr>\n"; # close ROW
      $i++; # bump to next
   }
   ### end if all
   print $fh <<EOF;
</table>
</p>
EOF
   ### all done ...
}
sub tolog {
   print @_;
   print $LF @_;
}
sub xceptchr {
   my ($chr) = @_;
   if (($chr eq ':') || ($chr eq '=') || ($chr eq '|') || ($chr eq ',')) {
      return 1;
   }
   return 0;
}
### NOT passed an ALL-SPACEY line
sub do_line_parse {
   my ($tx) = @_;
   chomp $tx;
   ### my @copybits; ## keep, for ORIGINAL space work 'replacement'
   my $tx2 = $tx;
   my $tx3;
   my $tx4 = htmlise($tx); ## the HTML'ISED string
   my $txsp = ''; # frontend SPACEY stuff
   ### no way ! my $txsp = $htmnbs; # frontend SPACEY stuff
   my $tx5;
   my $tx6;
   my $c1 = substr ($tx, 0, 1); # get and keep first char
   @lnbits = split (' ', $tx); # initial split spaces
   my $c2 = substr ($lnbits[0], 0, 1); # get POTENTIAL new first char
   my $pos1 = index ($tx, $c2); # get pos of first array char, in string
   my $gotfes = 0; # no frontend space
   if ($pos1 > 0) {
      $gotfes = 1; # mark, got frontend space
      $txsp = substr($tx, 0, $pos1); # get SPACEY at FRONT
   }
   my $cnt = @lnbits; # count of componets, so far
   my $cntorg = $cnt; # keep original SIZE, $cnt is 'adjusted' during ...
   my $i = 0;
   my $i2 = 0;
   my $i3 = 0;
   my @sp11;
   my $nct = 0; # count AFTER array 'adjustments' ...
   my $ln = length($tx2); # get length of line, not soooo important
   my $ch = substr ($tx2, 0, 1); # get first char, for fast decisions
   my $c = $ch; ### copy of FIRST char
   if ($lnbits[0] =~ m/^\#/) {
      #######################################################
      # is comment
      tolog ("Is comment - try ...\n");
      ###$tx3 = green($tx4);
      $tx3 = orange($tx4);
      $tx3 .= "<br>\n";
      prt ($tx3);
      #######################################################
   } else {
      tolog ("########### parse run one ###############################\n") if $verb2;
      ## does not START with a # comment char
      $i2 = 0;
      $i3 = 0;
      my $ichg = 0; ### count of bit changes
      ### first run - to re-combine quoted text within LINE ARRAY
      $i2 = 0; ### init line 'bits' counter
      $ichg = 0;
      @logmsgs = (); ### clear LOG message stack
      ###tolog ("{ comps $cntorg\n"); # log COUNT at start
      $msg = ("{ comps $cntorg\n"); # log COUNT at start
      push(@logmsgs,$msg); ## accumulate
      foreach $tx2 (@lnbits) {
         $i2++; # PRE-BUMP THE COUNT
         $msg = $tx2; # set line bit
         $ln = length($tx2);
         $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; # set JOIN
            if ($ln > 1) {
               $tx3 = substr ($tx2, 1, $ln - 1); # get past quote 
               if ( $tx3 =~ /$ch/) {
                  $pos1 = index ($tx3, $ch); # get position of next quote
                  $i = 0;
               }
            }
            if ($i) {
               ### JOIN, until the END OF QUOTE
               $i3 = 0;
               for ($i = $i2; $i < $cnt; $i++) {
                  $tx3 = $lnbits[$i]; # get next
                  $tx2 .= ' '; # add back space
                  $tx2 .= $tx3; ### $lnbits[$i];
                  $i3++; ### count 'bits' to DELETE
                  $ichg++; ### count a CHANGE
                  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 .= ", now joined, to its end";
               $cnt = @lnbits; ### UPDATE THE COUNT
            }
         } 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++;
               $ichg++;
            }
            $msg .= ' joined ';
            $msg .= $lnbits[$i2 - 1];
            $msg .= ' to ';
            $msg .= $tx2;
            $lnbits[$i2 - 1] = $tx2; # put back single quoted message
            $msg .= ' sp ' . $i2 . ' ' . $i3 . '[';
            splice (@lnbits, $i2, $i3); # collapse following items
            $msg .= "], line comment";
            $cnt = @lnbits;
            $i3++;
         } else {
            ## not begin quote ' or ", nor begin # ...
            ## dealt with on NEXT iteration of line bits - left for diagnostic only ###
            $c = 0;
            $tx3 = substr($tx2,1);
            if (($ch eq '$') || ($ch eq '@') || ($ch eq '%')) {
               # start of a scalor, array, hash ... move on to next letter
               $c = gotdelim($tx3); ### any more in this line
               if ( length($tx3) && ($c) && ! xceptchr($c) ) {  # got first split point, AFTER $var ...
                  $pos1 = index ($tx3,$c);
               }
            } else {
               $tx3 = $tx2; ### check full line
               $c3 = gotdelim($tx3);
               if ( length($tx3) && ($c3) ) {  # got first split point
                  $pos1 = index ($tx3,$c3);
               } # process $tx3
            }
            if ($c && ! xceptchr($c) ) {
               $msg .= ' *D ';
               $msg .= $c;
               $msg .= '* ';
            }
            if ( exists $HResWds{$tx2} ) {
               $msg .= ' *B*'; ### blue('R');
            }
            if ( exists $HBFuncs{$tx2} ) {
               $msg .= ' *P*';
            }
         }
         ###tolog ($msg . "\n");
         $msg .= "\n"; # add end of line
         push(@logmsgs, $msg); ### store the LOG
      } # for array list of line components === ONLY DOING JOINING
      $nct = @lnbits;
      if ($cnt != $nct) {
         die "***FIX a COUNT UPDATE $cnt $nct $cntorg ????\n";
      }
      if ($cntorg == $nct) {
         $msg = "} end comps $cntorg\n";
      } else {
         $msg = ("} end comps $cntorg, adj. $nct " . ($cntorg - $nct) . "\n");
      }
      push(@logmsgs, $msg);
      if ($ichg || $verb2) {
         tolog ( "Run 1 made " . $ichg . " changes in line - CHECK CHANGE\n" );
         foreach $msg (@logmsgs) {
            tolog($msg);
         }
      } else {
         ### no change
         if ($verb2) {
            tolog ("No change\n");
         }
      }
      @copybits = @lnbits; ### take a SNAP of this QUOTE ONLY EXPANSION
      ### want to RETURN the line to this SPACING, if possible ###
      tolog ("########### parse run two ###############################\n") if $verb2;
      #################### DO THE REST NOW ###################
      ###tolog ("{ comps $nct\n"); # log COUNT at start
      @logmsgs = ();
      $msg = ("{ comps $nct\n"); # log COUNT at start
      push(@logmsgs,$msg); ## accumulate
      $i2 = 0; ### init line 'bits' counter
      $ichg = 0;
      foreach $tx2 (@lnbits) {
         $i2++; # PRE-BUMP THE COUNT
         $msg = $tx2;
         $ln = length($tx2);
         $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; # set JOIN
            if ($ln > 1) {
               $tx3 = substr ($tx2, 1, $ln - 1); # get past quote 
               if ( $tx3 =~ /$ch/) {
                  $pos1 = index ($tx3, $ch); # get position of next quote
                  if ($pos1 > 0) {
                     $tx5 = substr ($tx2, 0, ($pos1 + 1 + 1)); # get WHOLE QUOTE
                     $tx3 = substr ($tx3, ($pos1 + 1)); # get ending text, if ANY
                     if (length($tx3)) {
                        $msg .= ' DONE WOULD SPLIT ';
                        $msg .= '[';
                        $msg .= $tx5;
                        $msg .= ']';
                        $msg .= '[';
                        $msg .= $tx3;
                        $msg .= ']?';
                        $lnbits[$i2 - 1] = $tx5; # put back adjusted first
                        splice (@lnbits, $i2, 0, $tx3); # insert 1 new items
                        $cnt = @lnbits; ### ADJUST COUNT ITERATOR
                        $ichg++;
                     }
                  }
                  $msg .= " b&e same quotes";
                  $i = 0;
               }
            }
            if ($i) {
               # should ALREADY BE JOIN until the END OF QUOTE
            }
            ### should already been JOINED, until the END of quotes
            #########################################
         } elsif ($ch eq '#') { # if starts with a comment
            #########################################
            ## should already be joined, to end of line
            #########################################
         } else {
            #########################################
            ## not begin quote ' or ", nor begin # ...
            $c = 0;
            $tx3 = substr($tx2,1); 
            if (($ch eq '$') || ($ch eq '@') || ($ch eq '%')) {
               # start of a scalor, array, hash ... move on to next
               $c = gotdelim($tx3);
               if ( length($tx3) && ($c) && ! xceptchr($c) ) {  # got first split point, AFTER $var ...
                  $pos1 = index ($tx3,$c);
                  if ($pos1 > 0) {
                     $i3 = 0;
                     $tx5 = $ch; # put first char back
                     $tx5 .= substr ($tx3, 0, $pos1); # get up to CHAR
                     @sp11 = ($c);
                     $tx3 = substr ($tx3, ($pos1 + 1)); # get ending text, if any
                     if (length($tx3)) {
                        push(@sp11, $tx3); # put in slurp
                        if ((($c eq '(') && (substr($tx3,0,1) eq ')')) ||
                           (($c eq '+') && (substr($tx3,0,1) eq '+')) ) { # eg check *split* [$sock->accept][(][);]
                           $i3 = 1; # some EXCEPTIONS
                        }
                     }
                     if ($i3) {
                        $msg = '*NO* *split* [';
                     } else {
                        $msg = 'DONE *split* [';
                     }
                     $msg .= $tx5 . '][';
                     $msg .= $c . ']';
                     if (length($tx3)) {
                        $msg .= '[';
                        $msg .= $tx3 . ']';
                     }
                     $msg .= "\n";
                     push(@logmsgs,$msg);
                     ###tolog ($msg . "\n");
                     if ($i3 == 0) {
                        $lnbits[$i2 - 1] = $tx5; # put back first split
                        splice (@lnbits, $i2, 0, @sp11); # insert 1 or 2 new items
                        $cnt = @lnbits; ### ADJUST COUNT ITERATOR
                        $ichg++;
                     }
                  }
                  $msg = $tx2; # put original message back
               }
            } else {
            ## not begin quote ' or ", nor begin # ...
               ### and is NOT if (($ch eq '$') || ($ch eq '@') || ($ch eq '%')) {
               $tx3 = $tx2;
               $c3 = gotdelim($tx3);
               ###if ( length($tx3) && ($c3) ) {  # got first split point
               if ( ($ln) && ($c3) ) {  # got first split point
                  $pos1 = index ($tx3,$c3);
                  if ( $pos1 > 0 ) { # if the first char, or ...
                     ### we have something, a million other variations
                     ##my $ts = '\\';
                     ##$ts .= $c3;
                     ##@sp11 = split ($ts, $tx3);
                     $tx5 = substr ($tx3, 0, $pos1); # get up to CHAR
                     ###@sp11 = ($tx5, $c3);
                     @sp11 = ($c3);
                     $tx3 = substr ($tx3, ($pos1 + 1)); # get ending text, if any
                     if (length($tx3)) {
                        push(@sp11, $tx3); # put in slurp
                     }
                     ###if (($c3 ne ':') && ($c3 ne '=') && ($c3 ne '|')) {
                     if ( ! xceptchr($c3) ) {
                        $msg = 'done Split [';
                        $msg .= $tx5 . '][';
                        $msg .= $c3 . ']';
                        if (length($tx3)) {
                           $msg .= '[';
                           $msg .= $tx3 . ']';
                        }
                        tolog ($msg . "\n");
                        $lnbits[$i2 - 1] = $tx5; # put back first split
                        ###splice (@lnbits, $i2, 0, $c3);
                        ###if (length($tx3)) {
                        ###   splice (@lnbits, ($i2+1), 0, $tx3);
                        ###}
                        splice (@lnbits, $i2, 0, @sp11); # insert 1 or 2 new items
                        ##splice (@lnbits, ($i2 - 1), 1, @sp11); # INSERT into array at this pos
                        $cnt = @lnbits; ### ADJUST COUNT ITERATOR
                        $ichg++;
                     }
                  } elsif ( $pos1 == 0 ) {
                     $tx3 = substr ($tx3, ($pos1 + 1)); # get ending text, if any
                     if (length($tx3)) {
                        @sp11 = ($c3, $tx3); # put in slurp
                        ### if (($c3 ne ':') && ($c3 ne '=') && ($c3 ne '|')) {
                        if ( ! xceptchr($c3) ) {
                           $msg = 'DONE SPLIT [';
                           $msg .= $c3 . '][';
                           $msg .= $tx3 . ']';
                           ##tolog ($msg . "\n");
                           $msg .= "\n";
                           push(@logmsgs,$msg);
                           ###tolog (@sp11 . "\n");
                           ##splice (@lnbits, ($i2 - 1), 1, @sp11); # INSERT into array at this pos
                           $lnbits[$i2 - 1] = $c3; # put back first split
                           splice (@lnbits, $i2, 0, $tx3);
                           $ichg++;
                           $cnt = @lnbits; ### ADJUST COUNT ITERATOR
                        }
                     }
                  } else {
                     ###   last;
                     die "ERROR: Unresolved POSITION - can not happen ...\n";
                  }
               } # process $tx3
            }
            #########################################
            $msg = $tx2;
            if ($c && ! xceptchr($c) ) {
               $msg .= ' *D ';
               $msg .= $c;
               $msg .= '* ';
            }
            if ( exists $HResWds{$tx2} ) {
               $msg .= ' *B*'; ### blue('R');
               $i3++;
            }
            if ( exists $HBFuncs{$tx2} ) {
               $msg .= ' *P*';
               $i3++;
            }
            if ( $ln < 3 ) {
               ### tolog ( "*PUNC* CHECK [" . $tx2 . "]\n" );
               if ( ispunctuat ( $tx2 ) ) {
                  $msg .= ' *PUNC*';
               }
            }
            #########################################
         }
         ### tolog ($msg . "\n");
         $msg .= "\n";
         push(@logmsgs,$msg);
      } # for array list of line components
      $nct = @lnbits;
      if ($cnt != $nct) {
         die "***FIX a COUNT UPDATE $cnt $nct $cntorg ????\n";
      }
      if ($cntorg == $nct) {
         $msg = ("} end comps $cntorg\n");
      } else {
         $msg = ("} end comps $cntorg, adj. $nct " . ($cntorg - $nct) . "\n");
      }
      push(@logmsgs,$msg);
      if ($ichg || $verb2) {
         tolog ( "Run 2 Made " . $ichg . " changes in line - CHECK CHANGE\n" );
         foreach $msg (@logmsgs) {
            tolog($msg);
         }
      } else {
         ### no change
         if ($verb2) {
            tolog ("Run 2 - No change\n");
         }
      }
      tolog ("########### output run ###############################\n") if $verb2;
      ### tolog ("{{ $nct");
      @logmsgs = ();
      $msg = ("{{ $nct");
      push(@logmsgs,$msg);
      ### perpare for HTML output
      ###########################
      $tx3 = ''; # clear FRONTEND output
      ### $tx3 = $txsp; # get the FRONTEND SPACE
      if (($c1 eq ' ') || ($c1 eq "\t")) {
         die "ERROR: Missed a case above ...\n" if ! $gotfes; # MISS FRONTEND SPACE
         ### $tx3 .= ' '; # add last space back
         $tx3 = white(htmlise($txsp));
         ## $tx3 = '&nbsp; ';
         ## $tx3 = htmlise($txsp); # space to HTML
         if ($verb2) {
            $msg = "\nSpace=[\n";
            $msg .= $txsp;
            $msg .= "]\n[";
            $msg .= $tx3;
            $msg .= ']';
            tolog ($msg . "\n");
         }
      } else {
         die "ERROR: Missed a case above ...\n" if $gotfes; # MISS FRONTEND SPACE
      }
      #############################################
      $i3 = 0; # init COUNTER
      my $func;
      $i2 = 0;
      $i = 0;
      $ln = 0;
      foreach $tx2 (@lnbits) { # process for OUTPUT
         ### we have @copybits = @lnbits; ### take a SNAP of this QUOTE ONLY EXPANSION
         if ($i3) { # was (length($tx3)) {
            ### this should REMEMBER the original 'line-spacing', and re-apply it now
            $tx6 = substr ($tx6, $ln); ### get next line 'bit'
            ### note, no actual CHECK that they are the EQUAL!!!
            ### if ($msg eq $tx2) { ### should work also ...
            if (length($tx6)) {
               $nct = 0; ### no SPACE addition yet
            } else {
               $i2++; ### bump to NEXT
               $tx6 = $copybits[$i2]; ### get the 'copy', for 'formatting'
               $i = length($tx6); ## len of COPY
               $c1 = substr ($tx6, 0, 1); ### and first char
               $nct = 1; ### add back SPACE, per original file
            }
            if ($nct) {
               ###$tx3 .= white(' '); # add back 'space' between LINE components
               $tx3 .= ' '; # add back 'space' between LINE components/bits
            }
         } else {
            ## first, so no space added = START 'spacer' 
            $tx6 = $copybits[$i2]; ### get the 'copy', for 'formatting'
            $i = length($tx6); ## len of COPY
            $c1 = substr ($tx6, 0, 1); ### and first char
         }
         $ln = length($tx2); # length this line 'bit'
         $c = substr ($tx2, 0, 1); # get FIRST CHAR
         $msg = $tx2; # get copy of the line
         $tx5 = htmlise($msg); # make it HTML form
         ### case of the first CHARACTER - established TYPE of this line bit
         if ($c eq '#') { # comment component - should be to end-of-line, or more ...
            $func = \&orange;
         } elsif ($c eq "'") { ## "' # does it start with quotes DOUBLE or SINGLE
            $func = \&green;
         } elsif ($c eq '"') {
            $func = \&color3;
         } elsif ($c eq '$') {
            # start of scalar
            $func = \&color1;
         } elsif ($c eq '@') {
            # start of array
            $func = \&match;
         } elsif ($c eq '%') {
            # start of hash
            $func = \&peach;
         } elsif ( exists $HResWds{$tx2} ) {
            $func = \&blue;
         } elsif ( exists $HBFuncs{$tx2} ) {
            $func = \&color2;
         } else {
            $func = \&white; # set default, white
            if ($ln < 4) { # if it is a short 'bit' of the line
               if ( ispunctuat ($tx2) ) { # check if punc
                  $func = \&grey; # yup, switch to grey
               }
            }
         }
         $msg = $func->($tx5); # get the HTML form mainly '<' -> '&lt;' changes
         $tx3 .= $msg;
         ###tolog (' [' . $msg . ']');
         ###tolog (' [' . $tx2 . ']');
         $msg = (' [' . $tx2 . ']');
         push(@logmsgs,$msg);
         $i3++; ## count a line item
         $msg = $tx2; ### keep LAST line 'bit' ...
      } ### loop while line 'bits'
      ##### done line output #####
      ### tolog ("}}\n");
      $msg = ("}}\n");
      push(@logmsgs,$msg);
      foreach $msg (@logmsgs) {
         tolog($msg);
      }
      $tx3 .= "<br>\n";
      ### tolog ($tx3);
      prt ($tx3);
      #######################################################
   } ### comment line summarily dealt with ...
}
sub htmlise {
   my ($txt) = @_;
   my $htmsps = 0;
   my $htmnbs = '';
   # 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 $htmsps = 0;
      ### my $htmnbs = '&nbsp;';
      ## $htmsps = 0;
      $htmnbs = '&nbsp;';
      for ($htmsps = 1; $htmsps < $ln; $htmsps++) {
         if (substr ($txt, $htmsps, 1) ne ' ') {
            last;
         }
         $htmnbs .= '&nbsp;' if $htmsps > 1;
      }
      $htmsps-- if $htmsps > 1; # back off last space, if more than 1
      tolog ("Replacing $htmsps with [$htmnbs] ...\n") if $verb2;
      $txt =~ s/ {$htmsps}/$htmnbs/; # 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
   return $txt;
}
sub gotdelim {
   my ($tx) = @_;
   my $c;
   my $mx = length($DELIMITER); ### = '(){}[]-+*/=~!&|<>?:;.,';
   my @ar = split (//, $DELIMITER);
   my $i = 0;
   foreach $c (@ar) {
      my $ts = '\\';
      $ts .= $c;
      if ($tx =~ /$ts/) {
         # return 1;
         return $c;
      }
      $i++;
   }
   return 0;
}
sub ispunctuat {
   my ($cp) = @_;
   foreach my $cc (@PPunct) {
      ###tolog ("Comaring [$cc] with [$cp]...\n");
      if ($cc eq $cp) {
         return 1;
      }
   }
   return 0;
}
my @PPairs = (
   "<", ">",
   "<%", "%>",
   "{", "}",
   "[", "]",
   "(", ")",
   );
my @DolVars = ( "\$1", "\$2", "\$3",
   "\$&", "\$<", "\$>", "\$'", "\$*",
   "\$@", "\$`", "\$\\", "\$!", "\$[",
   "\$]", "\$^", "\$^A", "\$^F",
   "\$^H", "\$^I", "\$^L", "\$^M",
   "\$^O", "\$^P", "\$^T", "\$^W", "\$^X",
   "\$:", "\$,", "\$.", "\$=", "\$-",
   "\$(", "\$)", "\$%", "\$+", "\$?",
   "\$\"", "\$;", "\$/", "\$~",
   "\$_", "\$|"
   );
my @PBPunc = (
   "(?!)", "(?!...", "(?:)",
   "(?...)", "(?=)", "(?#)", "(?i)"
   );
sub showarrcnts {
   my $i = @PPunct;
   tolog ("PPunct array count = $i\n");
   $i = @PPairs;
   tolog ("PPairs array count = $i\n");
   $i = @DolVars;
   tolog ("DolVars array count = $i\n");
   $i = @PBPunc;
   tolog ("PBPunc array count = $i\n");
}
### EOF

index -|- top

checked by tidy  Valid HTML 4.01 Transitional