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 = ' '; } 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/"/"/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 $sps = 0; my $nbs = ' '; for ($sps = 1; $sps < $ln; $sps++) { if (substr ($txt, $sps, 1) ne ' ') { last; } $nbs .= ' ' 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 ' 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; }