Perl Index *|* Back to Perl 1 *|* Back to cv *|* To Home
#!/perl
use strict ;
use warnings ;
my $vers = '0.0.4'; # fourth iteration, expanding line array ... LOOKS GOOD !!!
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 $htmsps = 0 ; # set after htmlise()
my $htmnbs = '';
my $dbgon = 0 ; # 1 DOUBLES HTML OUTPUT FOR COMPARISON
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 { "@_" } ;
### *$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 { "@_" } ;
}
my $msg = '';
my ( $line, $txt ) ;
my $i = 0 ;
my ( $cnt1, $cnt2 ) ;
my $inbraces = 0 ;
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";
###### pre-process perl.stx file ######################################
$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") 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");
my $lc = 0 ;
my $dnpara = 1 ;
my @lnbits ;
my $chk ;
my $istxt = 1 ;
## my $func;
prt ( "
\n");
foreach $line ( @lines ) {
$txt = $line ;
chomp $txt ;
@lnbits = split ( ' ',$txt);
$lc++;
$istxt = 1 ; # assume text
if ( $txt =~ / $WHITE_PATTERN2 / o ) {
$txt = "
\n"; # CLOSE paragraph, and open
$istxt = 0 ; # NOT text
} else {
$txt = white ( htmlise ( $txt ) ) ;
$txt .= "
\n";
}
if ( $istxt ) {
if ( $dbgon ) {
tolog ( "Simple WHITE-ised to HTML file ...\n");
prt ( $txt ) ; # just for COMPARISON
}
} else { ## if (! $istxt) {
tolog ( "Simple WHITE-ised to HTML file ...\n");
prt ( $txt ) ; # just for COMPARISON
}
if ( $istxt ) {
###do_line_parse ($line);
tolog ( "Per line component parsing to HTML file ...\n");
do_line_parse ( $line ) ;
}
}
tolog ( "Processed $lc lines of $infile ... written to $outfil ...\n");
prt ( "
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";
. $nm
{
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: $bd
}
EOF3
}
sub add_html_style {
my ( $fh ) = @_ ;
print $fh < < "EOF1";
Perl Index *|* Back to Perl 1 *|* Back to cv *|* To Home