#!/Perl
###########################################################################
# p2h04.pl - 28 August, 2006 - Geoff McLane
# (normally run through my p2h.bat batch file)
# 03/09/2010 - Add the 'code' section, and the paragraph class="nmb"
#
# 20/10/2013 - Update location of perl.stx file
# 06/02/2009 - try to fix '$$item' be shown as a hash, not an array
# Note the TAB = 3 chars, and did some re-lining to try to understand (again)
# but gave up for now.
#
# 21/08/2007 - added simple COMMAND LINE input
# 2007.06.08 minor update - remove from use Time::HiRes, usleep ualarm and nanosleep - not used
# This is an update on p2h03.pl of April, 2006.
#
# Another attempt at 'converting' perl scripts to a colour coded HTML page.
# The previous attempt got too unwieldy - abandoned at p2html12.pl ...
# This works on a line by line, character by character, decode,
# and colour encode ... a modest file can grow to 4 or more times
# its original size ... adding colour coding COSTS!
#
# NOTE: While this conversion to coloured HTML produces a 'pretty
# picture' of the original perl script file, often it MAY NOT be copied
# exactly by others. Asside from some big spacing differences, entities
# such as $tok .= '&'; MAY NOT translate correctly. In a copy-and-
# paste operation, this MAY be 'translated' as $tok .= '&';, which
# produces ERRANT perl code! Other ERRORS are $ln =~ s/</g;
# MAY become $ln =~ s/... block
# this option REALLY adds weight to certain files
my $add_uvars = 1; # colour code user variables
# this load the output result into a browser
my $load_html = 1; # load the final HTML
# special DEBUG variables
my $debug_on = 0; # heavy DEBUG ONLY output
my $out_lists = 0; # output the lists in qw form
#####################
# PROGRAM VARIABLES #
#####################
my ($LF, $OF);
my @ResWords = ();
my @BuiltIns = ();
# load perl.stx file, or use this local list
if ($use_local) {
@ResWords = qw/ continue do else elsif for foreach goto if last local lock map my next package redo
require return sub unless until use while STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG TRUE FALSE __FILE__
__LINE__ __PACKAGE__ __END__ __DATA__ lt gt le ge eq ne cmp x not and or xor q qq qx qw $ @ % /;
@BuiltIns = qw(abs accept alarm atan2 bind binmode bless caller chdir chmod chomp chop chown chr
chroot close closedir connect cos crypt dbmclose dbmopen defined delete die dump each eof eval exec exists
exit exp fcntl fileno flock fork format formline getc getlogin getpeername getpgrp getppid getpriority
getpwnam getgrnam gethostbyname getnetbyname getprotobyname getpwuid getgrgid getservbyname gethostbyaddr
getnetbyaddr getprotobynumber getservbyport getpwent getgrent gethostent getnetent getprotoent
getservent setpwent setgrent sethostent setnetent setprotoent setservent endpwent endgrent endhostent
endnetent endprotoent endservent getsockname getsockopt glob gmtime grep hex import index int ioctl
join keys kill lc lcfirst length link listen localtime log lstat mkdir msgctl msgget msgsnd msgrcv no oct
open opendir ord pack pipe pop pos print printf prototype push quotemeta rand read readdir readlink recv
ref rename reset reverse rewinddir rindex rmdir scalar seek seekdir select semctl semget semop send setpgrp
setpriority setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep socket socketpair sort
splice split sprintf sqrt srand stat study substr symlink syscall sysopen sysread sysseek system syswrite
tell telldir tie tied time times truncate uc ucfirst umask undef unlink unpack untie unshift utime values
vec wait waitpid wantarray warn write );
}
my @lines = (); # final output line gathered here
my $line = '';
my $last_builtin = '';
my $last_resword = '';
my $doc_total = 0;
my $out_total = 0;
# these are really just DEBUG counters
my $a_cnt = 0;
my $b_cnt = 0;
my $c_cnt = 0;
my $d_cnt = 0;
my $e_cnt = 0;
my $f_cnt = 0;
my $o_cnt = 0;
my $v_cnt = 0;
my $q_cnt = 0;
# TIME VARIABLES
my ($t0, $t1, $elapsed);
# set to default - over-ridden with COMMAND LINE arguments
my $out_file = $def_out_file; # set users ouput, or default
my $in_file = ''; #$def_in_file; # set users INPUT, or default
my $out_ln_count = 0;
my $max_ln_count = 50;
my $load_log = 0;
#####################################################################
# This is the small MAIN part of the script
$t0 = [gettimeofday];
# logging file, if possible
my $out_log = 1;
if (open $LF, ">$log_file") {
$out_log = 1;
prt( "Output also being written to LOG file $log_file ... \n" );
} else {
$out_log = 0;
prt( "WARNING: Unable to create LOG file $log_file ... \n" );
}
if ( !$use_local) { load_stx_file( $perlstx ); }
prt( "Got ".scalar @ResWords." Reserved Words, and ".scalar @BuiltIns." Built-in functions ...\n" );
process_args(@ARGV);
process_file( $in_file ); # main processing of the file lines
prt( "Got ".scalar @lines." new lines out to $out_file ...\n" );
write_out_file(); # write out results, using HTML format ...
$t1 = [gettimeofday];
$elapsed = tv_interval ( $t0, $t1 );
prt( "$0 processing took $elapsed seconds ...\n" );
if ($load_html) {
system( $out_file );
}
if ($out_log) {
close($LF);
if ($out_ln_count > $max_ln_count) {
$load_log = 1;
}
if ($load_log) {
system($log_file);
}
}
exit 0;
#####################################################################
#######################
### only subs below ###
#######################
sub get_code_section() {
my $code = <
code:
EOF
return $code;
}
##########################################################################
# The main file OUTPUT - that is the HTML file.
# It establishes the HTML header, which includes the CSS style
# information. then outputs each of the 'converted' lines ...
##########################################################################
sub write_out_file {
# this is what it is all about - to generate a HTML document
open $OF, ">$out_file" or die "ERROR: Unable to create $out_file ... aborting ...\n";
print $OF <
$in_file - Generated HTML from Perl Script
EOF
print $OF "File [$in_file] to HTML.
\n";
if ($add_table) {
print $OF ''."\n";
} elsif ($add_pre) {
print $OF get_code_section();
print $OF '';
}
# actual output of generated lines
foreach $line (@lines) {
$out_total += length($line);
print $OF $line;
}
if ($add_table) {
print $OF ' |
'."\n";
} elsif ($add_pre) {
print $OF ''."\n";
}
if ($add_chart) {
# mainly only for DEBUG
add_color_chart($OF);
my $tot = ($a_cnt+$b_cnt+$c_cnt+$d_cnt+$e_cnt+$f_cnt+$o_cnt+$v_cnt+$q_cnt);
my $diff = $out_total - $doc_total;
print $OF "This use of $tot colour span sequences added $diff bytes. In=$doc_total Out=$out_total
\n";
}
print $OF 'Generated: ' . localtime(time()) . " from [$in_file].
\n";
print $OF "\n";
close($OF);
}
#########################################################
# A small set of 9 services which add in the CSS class,
# using .thetext.
#
# Each one does a different class, and the class
# is extracted to variables set above. This means
# they can easily be adjusted to new, different
# values ...
#
# They also accumulate statistic information on how
# many time each is used ...
#########################################################
# built-in functions
sub add_red {
my ($t) = shift;
$a_cnt++;
return (''.$t.'');
}
# perl comments
sub add_class_b {
my ($t) = shift;
$b_cnt++;
return (''.$t.'');
}
# perl reserved words
sub add_blue {
my ($t) = shift;
$c_cnt++;
return (''.$t.'');
}
# perl qw set
sub add_class_d {
my ($t) = shift;
$d_cnt++;
return (''.$t.'');
}
sub add_class_e {
my ($t) = shift;
$e_cnt++;
return (''.$t.'');
}
sub add_class_f {
my ($t) = shift;
$f_cnt++;
return (''.$t.'');
}
sub add_class_o {
my ($t) = shift;
$o_cnt++;
return (''.$t.'');
}
sub add_class_v {
my ($t) = shift;
$v_cnt++;
return (''.$t.'');
}
sub add_quote {
my ($t) = shift;
$q_cnt++;
return (''.$t.'');
}
#########################################################
# search the @ResWord array for an entry
sub in_res_words {
my ($t) = shift;
foreach my $rw (@ResWords) {
if ($t eq $rw) {
$last_resword = $rw;
return 1;
}
}
return 0;
}
# search the @BuiltIns array for an entry
sub in_built_in {
my ($t) = shift;
foreach my $rw (@BuiltIns) {
if ($t eq $rw) {
$last_builtin = $rw;
return 1;
}
}
return 0;
}
sub is2lt {
my $t = shift;
$t =~ s/</= 2 ) && ( $t =~ /<<$/ ) ) {
prt( "test is2lt on [$t] ... return 1\n" ) if $debug_on;
return 1;
}
prt( "test is2lt on [$t] ... return NOT\n" ) if $debug_on;
return 0;
}
sub sans_quotes { # for sure
my $t = shift;
##$t =~ s/\"//g; # why???
$t =~ s/"//g;
$t =~ s/'//g;
return $t;
}
######################################################
# Converting SPACES to ' '
# Of course this could be done just using perl's
# powerful search and replace, but this handles
# any number of spaces, only converting the number
# minus 1 to ... not sure how to have
# this level of control with regex replacement
######################################################
sub conv_spaces {
my $t = shift;
my ($c, $i, $nt, $ln, $sc, $sp);
$nt = ''; # accumulate new line here
$ln = length($t);
for ($i = 0; $i < $ln; $i++) {
$c = substr($t,$i,1);
if ($c eq ' ') {
$i++; # bump to next
$sc = 0;
$sp = '';
for ( ; $i < $ln; $i++) {
$c = substr($t,$i,1);
if ($c ne ' ') {
last; # exit
}
$sc++;
$sp .= $c;
}
if ($sc) {
$sp =~ s/ / /g;
$nt .= $sp;
}
$i--; # back up one
$c = ' '; # add back the 1 space
}
$nt .= $c;
}
prt( "conv_space: from [$t] to [$nt] ...\n" ) if $debug_on;
return $nt;
}
###########################################################################
# VERY IMPORTANT SERVICE
# This converts the 'text' into HTML text, but only does a partial job!
# 1. Convert '&' to '&' to avoid interpreting as replacement
# 2. Convert '<' to '<' to avoid interpreting as HTML
# 3. Convert '"' to '"'
# 4. Convert '\t' to SPACES
# 5. Finally, if there are double or more SPACES, convert to ' '
###########################################################################
sub html_line {
my $t = shift;
my $ot = $t;
$t =~ s/&/&/g; # all '&' become '&'
$t =~ s/</g; # make sure all '<' is/are swapped out
$t =~ s/\"/"/g; # and all quotes become "
$t =~ s/\t/$tab_space/g; # tabs to spaces
if ($t =~ /\s\s/) { # if any two consecutive white space
return conv_spaces($t);
}
prt( "html_line: from [$ot] to [$t] ...\n" ) if $debug_on;
return $t;
}
##########################################################
# The following two functions 'convert' scalar variables
# to colour codes spans, in the print <; # slurp into line array
close($IF);
prt( "Got ".scalar @lns." to process from $in_file ...\n" );
my $st = 0; # current status
my $nst = 0;
my $pc = '';
my $pc2 = '';
my $ch = '';
my $tok = '';
my $ltok = ''; # last token
my $ltok1 = '';
my $ltok2 = '';
my $qtok = ''; # print <<"EOF" or ANY <<'until_end', token
my $end_qw = '/';
my $i = 0;
foreach my $ln (@lns) {
$doc_total += length($ln);
chomp $ln;
$ln = fix_email($ln);
$ln =~ s/\r$//; # and remove CR, if present
my $len = length($ln);
my $nline = '';
prt( "\nline=[$ln] ...\n" ) if $debug_on;
$pc = '';
$pc2 = '';
$tok = '';
$ltok = ''; # last token
$ltok1 = ''; # token stack
$ltok2 = '';
$i = 0;
$nst = 0; # if fall through, next status is IN space
if ($st == 3) {
# locked in a 'print' string to end token
if ($add_uvars) {
$nline = get_uform( $ln );
} else {
$nline = add_class_f(html_line($ln));
}
add_2_lines($nline);
if ($ln =~ /^$qtok/) {
$st = 0;
}
next; # next LINE of file
} elsif ($st == 4) {
# processing a 'qw' block - only if $brown_qw is ON
$tok = '';
for ( ; $i < $len; $i++) {
$ch = substr($ln, $i, 1);
if ($ch eq $end_qw) { # either '/' or ')' depending on start
$nline .= add_class_d(html_line($tok)) if (length($tok));
$tok = '';
last;
}
$tok .= $ch;
}
if ($i < $len) {
$nst = 2; # fall through to continue line
} else {
$nline = add_class_d(html_line($ln));
add_2_lines($nline);
next;
}
} # dealing with status 3 or 4
$st = $nst;
for ( ; $i < $len; $i++) {
$ch = substr($ln, $i, 1);
# make a BIG exception of '<' ...
if (($ch eq '&') && (($i + 3) < $len)) {
$ch1 = substr($ln, $i, 4);
if ($ch1 eq '<') {
$tok .= $ch1;
$i += 3;
$st = 2;
$pc = ';';
next;
}
}
if ($st == 0) {
# IN white space territory
if ($ch =~ /\S/) {
prt( "IN ws, changed to NOT with [$ch] ".
"\$tok=[$tok] \$ltok[$ltok] \$ltok1[$ltok1] \$ltok2[$ltok2] html\n" ) if $debug_on;
$nline .= html_line($tok); # add any white space to new line
$ltok2 = $ltok1;
$ltok1 = $ltok;
$ltok = $tok;
$tok = '';
# if NOT escape, or escaped escape character
if ( ($pc ne '\\') || (($pc eq '\\') && ($pc2 eq '\\')) ){
if ($ch eq '#') {
# start of a COMMENT
prt( "start of a COMMENT [$ch] ".
"tok=[$tok] ltok[$ltok] ltok1[$ltok1] ltok2[$ltok2] html\n" ) if $debug_on;
$tok = substr($ln, $i);
$nline .= add_class_b(html_line($tok));
$tok = '';
$st = 0;
last;
} elsif (($ch eq '"')||($ch eq "'")) {
my $bch = $ch;
prt( "start of a QUOTE [$ch] ".
"tok=[$tok] ltok[$ltok] ltok1[$ltok1] ltok2[$ltok2]\n" ) if $debug_on;
$tok = $ch;
$i++;
$pc2 = '';
for ( ; $i < $len; $i++ ) {
$ch = substr($ln, $i, 1);
# if the PREVIOUS is NOT an ESCAPE, OR the previous and previous ARE
# that is a ESCAPED ESCAPE character, which is NOT an escape at all ;=))
if ( ($pc ne '\\') || (($pc eq '\\')&&($pc2 eq '\\')) ) {
if ($ch eq $bch) {
$tok .= $ch;
prt( "End of a QUOTE [$ch] ".
"tok=[$tok] ltok[$ltok] ltok1[$ltok1] ltok2[$ltok2] html\n" ) if $debug_on;
if ($add_uvars && ($bch eq '"')) {
$nline .= add_quote2($tok);
} else {
$nline .= add_quote(html_line($tok));
}
$tok = '';
$pc2 = $pc;
$pc = $ch;
last;
}
}
$tok .= $ch;
$pc2 = $pc;
$pc = $ch;
}
$pc = $ch;
next;
}
}
$tok = $ch;
if ($ch =~ /\w/) {
prt( "Start tok with $ch ... sw st [$st] to 1\n" ) if $debug_on;
$st = 1;
} else {
prt( "Start tok with $ch ... sw st [$st] to 2\n" ) if $debug_on;
$st = 2;
}
$pc2 = $pc;
$pc = $ch;
next;
} else {
# staying in white space
$tok .= $ch;
$pc2 = $pc;
$pc = $ch;
next;
}
} elsif ($st == 1) {
# dealing with alphanumberic + _
if ($ch =~ /\w/) {
$tok .= $ch;
$pc2 = $pc;
$pc = $ch;
next; # continue alphanumeric + _
}
prt( "IN an_, no longer an_ with [$ch] ... tok=[$tok]\n" ) if $debug_on;
if (length($tok)) {
if (in_res_words($tok) ) {
$nline .= add_blue(html_line($tok));
if ($brown_qw && (($ch eq '(')||($ch eq '/')) && ($last_resword eq 'qw')) {
# entering a qw list
$end_qw = '/';
$end_qw = ')' if ($ch eq '(');
prt( "Excepting a qw list ... Begin $ch, End $end_qw ...\n" ) if $debug_on;
$i++;
$nline .= $ch;
$tok = ''; # no token
for ( ; $i < $len ; $i++) {
$ch = substr($ln,$i,1);
if ($ch eq $end_qw) { # end on '/' or ')' depending on start
$nline .= add_class_d(html_line($tok)) if (length($tok));
$nline .= $ch;
$tok = '';
last;
}
$tok .= $ch;
}
if ($i < $len) {
next; # get next character
} # else, we have ended the line, still in a 'qw' ...
$nline .= add_class_d(html_line($tok)) if (length($tok));
$tok = '';
$st = 4;
last; # end of THIS line
}
} elsif (in_built_in($tok)) {
$nline .= add_red(html_line($tok));
} else {
if ($add_uvars) { # colour code user variables
$ch1 = substr($tok,0,1);
if ($ch1 eq '$') {
$nline .= add_class_e(html_line($tok));
} elsif ($ch1 eq '@') {
$nline .= add_class_o(html_line($tok));
} elsif ($ch1 eq '%') {
$nline .= add_class_v(html_line($tok));
} else {
$nline .= html_line($tok);
}
} else {
$nline .= html_line($tok);
}
}
$ltok2 = $ltok1;
$ltok1 = $ltok;
$ltok = $tok;
$tok = '';
}
$tok = $ch;
if ($ch =~ /\s/) {
$st = 0; # goto SPACE mode
} elsif ($ch =~ /\w/) {
$st = 1; # goto AN_ mode
} else {
$st = 2; # goto NOT SPACE or AN_ mode
}
$pc2 = $pc;
$pc = $ch;
next;
} elsif ($st == 2) {
# not IN space or IN an_
if ($ch =~ /\s/) {
prt( "IN 2 - change back to space with [$ch] ... tok=[$tok]\n" ) if $debug_on;
if ( is2lt($tok) ) {
$ch1 = get_balance(substr($ln,$i)); # get balance of line
$ch1 =~ s/\s+$//; # remove any trailing white space
##if ( ($ch1 =~ /;$/) && ($ltok =~ /=/) ) { mod20060829 add ltok2 also
if ( ($ch1 =~ /;$/) && (($ltok =~ /=/)||($ltok1 =~ /=/)) ) {
$ch1 =~ s/^\s+//; # remove any leading spaces
$ch1 =~ s/;$//; # remove colon
$ch1 =~ s/\s+$//; # now again remove any trailing white space
if ( !($ch1 =~ /\s/) ) {
$qtok = sans_quotes($ch1); # STORE THE END MARKER !!!
prt( "Got <= 2) &&
is2lt($ltok) &&
length($qtok) ) {
$qtok = sans_quotes($qtok); # strip any DOUBLE/SINGLE quotes
prt( "Got print [$last_builtin] ltok[$ltok] qtok[$qtok] ...\n" ) if $debug_on;
$i++;
$nline .= html_line(substr($ln,$i));
$tok = '';
$st = 3;
last; # done this line
}
$pc2 = $pc;
$pc = $ch;
next;
}
}
if ($add_uvars && (($ch eq '$')||($ch eq '@')||($ch eq '%'))) {
prt( "In add_uvars and got \$\@\% [$ch] add tok 2 line ... reset tok\n" ) if $debug_on;
$nline .= html_line($tok); # add in current token
$ltok2 = $ltok1;
$ltok1 = $ltok;
$ltok = $tok;
$tok = '';
} else {
prt( "NOT space or alphanumeric, including _, or special, or \$\@\% [$ch] add2tok ...\n" ) if $debug_on;
}
$tok .= $ch;
}
$pc2 = $pc;
$pc = $ch;
}
$nline .= html_line($tok);
add_2_lines($nline); # push(@lines, $nline); after appending EOL
} # foreach my $ln (@lns) {
} # end of function
####################################
# Reducing a line to bare bones
# Only presently used when loading
# the EditPlus 2 perl.stx file.
####################################
sub trim_line {
my ($l) = shift;
chomp $l;
$l =~ s/\r$//; # and remove CR, if present
$l =~ s/\t/ /g;
$l =~ s/\s\s/ /g while ($l =~ /\s\s/);
$l = substr($l,1) while ($l =~ /^\s/);
$l = substr($l,0,length($l)-1) while (($l =~ /\s$/)&&(length($l)));
return $l;
}
########################################
# Loading the reserved words, and
# perl built-in functions from a
# special EditPlus 2, perl.stx file,
# but there are arrays already included
# if you do not have this file.
########################################
sub load_stx_file {
my ($in_file) = shift;
my ($IF);
my @stx = ();
my %dchk = ();
open $IF, "<$in_file" or die "ERROR: Unable to open $in_file ... aborting ...\n";
@stx = <$IF>; # slurp entire file into array
close($IF);
my $scnt = scalar @stx;
prt( "Got $scnt lines in $in_file to process ...\n" );
my $st = 0;
foreach my $ln (@stx) {
my $tln = trim_line($ln);
my $ll = length($tln);
next if ($ll == 0);
if( $tln =~ /^\#KEYWORD=Reserved words/ ) {
$st = 1;
next;
} elsif ($tln =~ /^\#KEYWORD=Built-in functions/ ) {
$st = 2;
next;
} elsif (($tln =~ /^\#/) || ($tln =~ /^;/)) {
$st = 0;
next;
}
if (exists $dchk{$tln}) {
prt( "Warning: Avoiding duplicate of [$tln] ...\n" );
next;
}
$dchk{$tln} = 1;
if( $st == 1 ) {
push(@ResWords, $tln);
} elsif ($st == 2) {
push(@BuiltIns, $tln);
}
}
# this was ONLY used to get the internal list
# so this file becomes unneccessary ...
if ($out_lists) {
my $max = 85;
my $cnt = 20;
prt( '@ResWords = qw(' );
foreach my $ln (@ResWords) {
prt( $ln.' ' );
$cnt += length($ln);
if ($cnt > $max) {
prt("\n");
$cnt = 0;
}
}
prt( ");\n" );
$cnt = 20;
prt( '@BuiltIns = qw(' );
foreach my $ln (@BuiltIns) {
prt( $ln.' ' );
$cnt += length($ln);
if ($cnt > $max) {
prt("\n");
$cnt = 0;
}
}
prt( ");\n" );
}
}
sub add_color_chart {
my ($fh) = shift;
print $fh <<"EOF";
Chart of Colours Used
Class | Ref | Colour | Use | Count |
class='$a_class' |
$a_color |
RED |
Built-in Functions |
$a_cnt |
class='$b_class' |
$b_color |
BLUEGREEN |
Comments (following #) |
$b_cnt |
class='$c_class' |
$c_color |
BLUE |
Reserved Words |
$c_cnt |
class='$d_class' |
$d_color |
BROWN |
Inside qw(...) |
$d_cnt |
class='$e_class' |
$e_color |
DARKBLUE |
Scalar Variables |
$e_cnt |
class='$f_class' |
$f_color |
GREY |
Inside >>EOF thingy |
$f_cnt |
class='$o_class' |
$o_color |
ORANGE |
Array Variables |
$o_cnt |
class='$v_class' |
$v_color |
OLIVE |
Hash Variables |
$v_cnt |
class='$t_class' |
$t_color |
GREEN |
Single and Double Quotes |
$q_cnt |
End of chart
EOF
}
################################################
# sadly, this is to mangle my email, so
# it does not 'appear' to web scrapers
################################################
sub fix_email {
my ($eml) = shift;
my $nem = $eml;
if ($eml =~ /$emreg/i) {
my $nm = $1.$2;
my $sm = mangled_email($nm);
my $ind = index($eml, $nm);
if (!($ind == 1)) {
$nem = substr($eml,0,$ind);
$nem .= $sm;
$nem .= substr($eml, $ind+length($nm));
$efix_cnt++;
}
print "got [$nm] ... now [$sm] ... ind $ind ...\n" if $dbgem;
} else {
print "failed\n" if $dbgem;
}
return $nem;
}
sub mangled_email {
my ($em) = shift;
$em =~ s/geoffmclane/geoffair/i;
$em =~ s/\./ _dot_ /;
$em =~ s/\@/ _at_ /;
return $em;
}
################################################
# A small 'print' service, that not only
# sends the output to STDOUT, but also
# directs it to a LOG file. I find it
# quite difficult to watch the console
# messages FLASH by ... Of course the
# output can be command line RE-DRIECTED,
# IF you are running it from the command
# line ... most of the time I run it
# from withing the Editor tool, thus thus
# provides a convenient look-back at what
# happend ... this is especially true when
# $debug_on is set ...
################################################
sub prt {
my ($m) = shift;
print $m;
print $LF $m if $out_log;
$out_ln_count++;
}
sub mydie {
my ($m) = shift;
prt($m);
die "CRTICAL ERROR\n";
}
sub process_args {
my (@av) = @_;
my $cnt = 0;
while (@av) {
if( $cnt == 0 ) {
$in_file = $av[0];
prt( "Set input file to [$in_file] ...\n" );
} elsif ($cnt == 1) {
$out_file = $av[0];
prt( "Set output file to [$out_file] ...\n" );
} else {
mydie( "ERROR: Only in_file and out_file arguments allowed!\n" );
}
shift @av;
$cnt++;
}
if (length($in_file) == 0) {
mydie("ERROR: No input file found in command\n");
}
if (! -f $in_file) {
mydie("ERROR: Can NOT locate input file $in_file\n");
}
}
# eof - p2h04.pl