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 = ' '; ## $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 '<' -> '<' 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/"/"/g; # sub double quotes $txt =~ s/\</</g; # sub less than tag beginning $txt =~ s/\>/>/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 = ' '; ## $htmsps = 0; $htmnbs = ' '; for ($htmsps = 1; $htmsps < $ln; $htmsps++) { if (substr ($txt, $htmsps, 1) ne ' ') { last; } $htmnbs .= ' ' 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 ' 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