#!/Perl

print "Hello, World...\n";
my ($LF, $OF);
my $out_file = "tempout01.txt";
my $log_file = "tempp2h01.txt";
###my $in_file = "am2dsp5.pl";
my $in_file = "testiso2.pl";

# load perl.stx file
my $perlstx = 'C:/Program Files/EditPlus 2/perl.stx'; ### fix location - should maintain separate list???
my @ResWds = ();
my @BuiltIns = ();
my @lines = ();
my $line = '';

open $LF, ">$log_file" or die "ERROR: Unable to open LOG file $log_file ... aborting ...\n";
load_stx_file( $perlstx );
prt( "Got ".scalar @ResWds." Reserved Words, and ".scalar @BuiltIns." Built-in functions ...\n" );
process_file( $in_file );
prt( "Got ".scalar @lines." new lines ...\n" );
open $OF, ">$out_file" or die "ERROR: Unable to create $out_file ... aborting ...\n";
foreach $line (@lines) {
	print $OF $line;
}
close($OF);
close($LF);
############################
### sub below
sub add_class_a {
	my ($t) = shift;
	return ('<span class="a">'.$t.'</span>');
}

sub add_class_b {
	my ($t) = shift;
	return ('<span class="b">'.$t.'</span>');
}

sub add_class_c {
	my ($t) = shift;
	return ('<span class="c">'.$t.'</span>');
}

sub add_class_d {
	my ($t) = shift;
	return ('<span class="d">'.$t.'</span>');
}

sub add_class_e {
	my ($t) = shift;
	return ('<span class="e">'.$t.'</span>');
}

sub add_class_q {
	my ($t) = shift;
	return ('<span class="q">'.$t.'</span>');
}


sub in_res_words {
	my ($t) = shift;
	foreach my $rw (@ResWds) {
		if ($t eq $rw) {
			return 1;
		}
	}
	return 0;
}

sub in_built_in {
	my ($t) = shift;
	foreach my $rw (@BuiltIns) {
		if ($t eq $rw) {
			return 1;
		}
	}
	return 0;
}

sub process_file {
	my ($in_file) = shift;
	my ($IF);
	open $IF, "<$in_file" or die "ERROR: Unable to open $in_file ... aborting ...\n";
	my @lns = <$IF>; # slurp into line array
	close($IF);
	prt( "Got ".scalar @lns." to process ...\n" );
	my $st = 0; # current status
	foreach my $ln (@lns) {
		my $tok = '';
		my $ch = '';
		my $len = length($ln);
		my $nline = '';
		for (my $i = 0; $i < $len; $i++) {
			$ch = substr($ln, $i, 1);
			if ($st == 0) {
				# in white space territory
				if ($ch =~ /\S/) {
					# changed to NOT white space
					$nline .= $tok; # add any white space to new line
					$tok = '';
					if ($ch eq '#') {
						# start of a COMMENT
						$tok = $ch;
						$i++;
						for ( ; $i < $len ; $i++) {
							$ch = substr($ln, $i, 1);
							if (($ch eq "\r")||($ch eq "\n")) {
								$tok = add_class_b($tok);
								$tok .= $ch;
								$i++;
								if ($i < $len) {
									$tok .= substr($ln, $i); 
								}
								$i = $len;
								last;
							}
							$tok .= $ch;
						}
						$nline .= $tok;
						$tok = '';
						last;
					} elsif (($ch eq '"')||($ch eq "'")) {
						my $bch = $ch;
						$tok = $ch;
						$i++;
						for ( ; $i < $len; $i++ ) {
							$ch = substr($ln, $i, 1);
							if ($ch eq $bch) {
								$tok .= $ch;
								$nline .= add_class_q($tok);
								$tok = '';
								last;
							}
							$tok .= $ch;
						}
						next;
					}
					$tok = $ch;
					if ($ch =~ /\w/) {
						$st = 1;
					} else {
						$st = 2;
					}
					next;
				} else {
					# staying in white space
					$tok .= $ch;
					next;
				}
			} elsif ($st == 1) {
				# dealing with alphanumberic + _
				if ($ch =~ /\w/) {
					$tok .= $ch;
					next; # continue alphanumeric + _
				}
				# no longer an_
				if (length($tok)) {
					if (in_res_words($tok) ) {
						$nline .= add_class_c($tok);
					} elsif (in_built_in($tok)) {
						$nline .= add_class_d($tok);
					} else {
						$nline .= $tok;
					}
				}
				$st = 2;
				$tok = $ch;
				next;
			} elsif ($st == 2) {
				# not space or an_
				if ($ch =~ /\s/) {
					# change back to space
					$nline .= $tok;
					$tok = $ch;
					$st = 0;
					next;
				} elsif ($ch =~ /\w/) {
					# change back to an_
					$nline .= $tok;
					$tok = $ch;
					$st = 1;
					next;
				}
				$tok .= $ch;
			}
		}
		$nline .= $tok;
		push(@lines, $nline);
	}
}

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;
}

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(@ResWds, $tln);
		} elsif ($st == 2) {
			push(@BuiltIns, $tln);
		}
	}
}


sub prt {
	my ($m) = shift;
	print $m;
	print $LF $m;
}

