#!/perl -w
#
# viewperl2  -  A simple program to quickly view syntax highlighted
#              Perl code quickly from the command-line
#
# This file is freely distributable under the same conditions as Perl itself.
# try to adjust some of the colours to try to match EditPlus ...
# geoff mclane - mailto: geoffair@hotmail.com - 2006-06-19

require 5.004;
use strict;


#=====================================================================
#                              Includes
#=====================================================================

use FileHandle;
use Getopt::Long;
use Syntax::Highlight::Perl 1.0;

#=====================================================================
#                          Global Variables
#=====================================================================
use vars qw(%OPTIONS $PAGER %ANSI_colors %ANSI_colors_ORG $formatter @FILES);

%OPTIONS = (
    'Lines'       => 0,   # Flag indicating whether we should display line-numbers.
    'Module'      => 0,   # Flag indicating that we've seen at least one module.
    'Name'        => 1,   # Flag indicating whether we should display file names.
    'POD'         => 0,   # Flag indicating whether or not to display in-line POD.
    'Reset'       => 1,   # Flag to supress resetting line-numbers and formatting between files.
    'Shift'       => 4,   # Width of expanded tabs (shift-width).
    'Expand Tabs' => 1,   # Flag to expand tabs or not.
);

### not available in my perl implementation
### $PAGER         = '| less -rF';

###
### establish a HTML text class
###
%ANSI_colors = (
    none      => "</tt>",

    red       => "<tt class='red'>",
    green     => "<tt class='green'>",
    yellow    => "<tt class='yellow'>",
    blue      => "<tt class='blue'>",
    magenta   => "<tt class='magenta'>",
    cyan      => "<tt class='cyan'>",
    white     => "<tt class='white'>",

    gray      => "<tt class='gray'>",
    bred      => "<tt class='bred'>",
    bgreen    => "<tt class='bgreen'>",
    byellow   => "<tt class='byellow'>",
    bblue     => "<tt class='bblue'>",
    bmagenta  => "<tt class='bmagenta'>",
    bcyan     => "<tt class='bcyan'>",
    bwhite    => "<tt class='bwhite'>",

    bgred     => "<tt class='bgred'>",
    bggreen   => "<tt class='bggreen'>",
    bgyellow  => "<tt class='bgyellow'>",
    bgblue    => "<tt class='bgblue'>",
    bgmagenta => "<tt class='bgmagenta'>",
    bgcyan    => "<tt class='bgcyan'>",
    bgwhite   => "<tt class='bgwhite'>",
);

#
# Could use Term::ANSIColor but it wasn't installed on my machine, and I "know" the
# colors anyway.  If this causes problems, replace with Term::ANSIColor data.
#
%ANSI_colors_ORG = (
    none      => "\e[0m",

    red       => "\e[0;31m",
    green     => "\e[0;32m",
    yellow    => "\e[0;33m",
    blue      => "\e[0;34m",
    magenta   => "\e[0;35m",
    cyan      => "\e[0;36m",
    white     => "\e[0;37m",

    gray      => "\e[1;30m",
    bred      => "\e[1;31m",
    bgreen    => "\e[1;32m",
    byellow   => "\e[1;33m",
    bblue     => "\e[1;34m",
    bmagenta  => "\e[1;35m",
    bcyan     => "\e[1;36m",
    bwhite    => "\e[1;37m",

    bgred     => "\e[41m",
    bggreen   => "\e[42m",
    bgyellow  => "\e[43m",
    bgblue    => "\e[44m",
    bgmagenta => "\e[45m",
    bgcyan    => "\e[46m",
    bgwhite   => "\e[47m",
);


$formatter = new Syntax::Highlight::Perl;

#
# Set up formatter to do ANSI colors.
#
$formatter->unstable(1);
$formatter->set_format(
    'Comment_Normal'   => [$ANSI_colors{'bblue'},    $ANSI_colors{'none'}],
    'Comment_POD'      => [$ANSI_colors{'bblue'},    $ANSI_colors{'none'}],
    'Directive'        => [$ANSI_colors{'magenta'},  $ANSI_colors{'none'}],
    'Label'            => [$ANSI_colors{'magenta'},  $ANSI_colors{'none'}],
    'Quote'            => [$ANSI_colors{'bwhite'},   $ANSI_colors{'none'}],
    'String'           => [$ANSI_colors{'bcyan'},    $ANSI_colors{'none'}],
    'Subroutine'       => [$ANSI_colors{'byellow'},  $ANSI_colors{'none'}],
    'Variable_Scalar'  => [$ANSI_colors{'bgreen'},   $ANSI_colors{'none'}],
    'Variable_Array'   => [$ANSI_colors{'bgreen'},   $ANSI_colors{'none'}],
    'Variable_Hash'    => [$ANSI_colors{'bgreen'},   $ANSI_colors{'none'}],
    'Variable_Typeglob'=> [$ANSI_colors{'bwhite'},   $ANSI_colors{'none'}],
    'Whitespace'       => ['',                       ''                  ],
    'Character'        => [$ANSI_colors{'bred'},     $ANSI_colors{'none'}],
    'Keyword'          => [$ANSI_colors{'bwhite'},   $ANSI_colors{'none'}],
    'Builtin_Function' => [$ANSI_colors{'bwhite'},   $ANSI_colors{'none'}],
    'Builtin_Operator' => [$ANSI_colors{'bwhite'},   $ANSI_colors{'none'}],
    'Operator'         => [$ANSI_colors{'white'},    $ANSI_colors{'none'}],
    'Bareword'         => [$ANSI_colors{'white'},    $ANSI_colors{'none'}],
    'Package'          => [$ANSI_colors{'green'},    $ANSI_colors{'none'}],
    'Number'           => [$ANSI_colors{'bmagenta'}, $ANSI_colors{'none'}],
    'Symbol'           => [$ANSI_colors{'white'},    $ANSI_colors{'none'}],
    'CodeTerm'         => [$ANSI_colors{'gray'},     $ANSI_colors{'none'}],
    'DATA'             => [$ANSI_colors{'gray'},     $ANSI_colors{'none'}],
    'Line'             => [$ANSI_colors{'byellow'},  $ANSI_colors{'none'}],
    'File_Name'        => [$ANSI_colors{'red'} . $ANSI_colors{'bgwhite'}, $ANSI_colors{'none'}],
);

@FILES = ();

#=====================================================================
#                          Initializations
#=====================================================================

$SIG{PIPE} = sub { };  # Supress broken pipe error messages.

Getopt::Long::Configure('bundling');
GetOptions(
    'c|code=s'   => sub { push @::FILES, \$_[1] },
    'l|lines'    => sub { $::OPTIONS{'Lines'}       =    1  },
    'L|no-lines' => sub { $::OPTIONS{'Lines'}       =    0  },
    'n|name'     => sub { $::OPTIONS{'Name'}        =    1  },
    'N|no-name'  => sub { $::OPTIONS{'Name'}        =    0  },
    'p|pod'      => sub { $::OPTIONS{'POD'}         =    1  },
    'P|no-pod'   => sub { $::OPTIONS{'POD'}         =    0  },
    'r|reset'    => sub { $::OPTIONS{'Reset'}       =    1  },
    'R|no-reset' => sub { $::OPTIONS{'Reset'}       =    0;
                          $::OPTIONS{'Name'}        =    0  },
    's|shift=i'  => sub { $::OPTIONS{'Shift'}       = $_[1] },
    't|tabs'     => sub { $::OPTIONS{'Expand Tabs'} =    0  },
    'T|no-tabs'  => sub { $::OPTIONS{'Expand Tabs'} =    0  },
    'm|module=s' => sub {
        my $fn = mod2file($_[1]);
        if(defined $fn) { push @::FILES, $fn } else { warn "Module not found: $_[1]\n" }
    },
    'help'       => \&show_help,
    '<>'         => sub { push @::FILES, $_[0] },
);

my $ss = 6;
my %Type2Color = (
	'Comment_Normal'   => 'bblue',
    'Comment_POD'      => 'bblue',
    'Directive'        => 'magenta',
    'Label'            => 'magenta',
    'Quote'            => 'bwhite',
    'String'           => 'bcyan',
    'Subroutine'       => 'byellow',
    'Variable_Scalar'  => 'bgreen',
    'Variable_Array'   => 'bgreen',
    'Variable_Hash'    => 'bgreen',
    'Variable_Typeglob'=> 'bwhite',
    'Whitespace'       => '',
    'Character'        => 'bred',
    'Keyword'          => 'bwhite',
    'Builtin_Function' => 'bwhite',
    'Builtin_Operator' => 'bwhite',
    'Operator'         => 'white',
    'Bareword'         => 'white',
    'Package'          => 'green',
    'Number'           => 'bmagenta',
    'Symbol'           => 'white',
    'CodeTerm'         => 'gray',
    'DATA'             => 'gray',
    'Line'             => 'byellow',
    'File_Name'        => 'red'
	);

my @CCSet = qw(bblue magenta bwhite bcyan byellow bgreen bred white green gray red);

my @TTset = (
	 "match",  "#0066ff", "#e8e8ff",    "array",       "l.blue",  "bgreen",
	 "orange", "#ff6600", "#ffcc99",    "comment",     "brown",   "bblue",
	 "regex",  "#66ff00", "#fff4e8",    "unass" ,      "l.brown", "bwhite",
	 "green",  "#006400", "#ccffcc",    "s-quote",     "s.green", "bmagenta",
	 "color1", "#663300", "#ff99cc",    "scalar",      "pink",	  "bred",
	 "color2", "#333366", "#cc99ff",    "functions",   "mauve",   "white",
	 "color3", "#00a000", "#ccff99",    "d-quote",     "b.green", "byellow",
	 "peach",  "#003366", "peachpuff",  "hash",        "l.brn",   "bcyan",
	 "blue",   "blue",    "powderblue", "reserved",    "blue",    "magenta",
	 "white",  "#606060", "#ffffff",    "other",       "white",   "red",
	 "grey",   "#303030", "#cccccc",    "punctuation", "l.grey",  "gray"
);


process_files();

system 'tempout.htm';

#=====================================================================
#                            Subroutines
#=====================================================================

sub show_help {

    my $self = $0;  $self =~ s/^.*\///;

    print << "END_OF_HELP";
Usage: $self [OPTION]... FILE...
View a Perl source code file, syntax highlighted.

  -c, --code=CODE       view CODE, syntax highlighted
  -l, --lines           display line numbers
  -L, --no-lines        supress display of line numbers (default)
  -m, --module=FILE     consider FILE the name of a module, not a file name
  -n, --name            display the name of each file (default)
  -N, --no-name         supress display of file names (implied by --no-reset)
  -p, --pod             display inline POD documentation (default)
  -P, --no-pod          hide POD documentation (line numbers still increment)
  -r, --reset           reset formatting and line numbers each file (default)
  -R, --no-reset        supress resetting of formatting and line numbers
  -s, --shift=WIDTH     set tab width (default is 4)
  -t, --tabs            translate tabs into spaces (default)
  -T, --no-tabs         supress translating of tabs into spaces

      --help            display this help and exit

Note that module names should be given as they would appear after a Perl `use' or
`require' statement.  `Getopt::Long', for example.

Each string given using -c is considered a different file, so line number and
formatting resets will apply.
END_OF_HELP

    exit;

}


sub process_files {

    #
    # Don't read from STDIN if modules were specified and not found.
    #  (They've already seen the error and we should put them back to the command-line.)
    #
    return if not @FILES and $OPTIONS{'Module'};

    my $INPUT  = new FileHandle;
    my $OUTPUT = new FileHandle;

    #
    # Open the pager if our STDOUT is attached to a tty but *not* if STDIN is also
    # attached to a tty (unless we're not going to be reading from STDIN, ie @ARGV
    # has values and none of them are '-') because then both we and the pager are
    # trying to read from the tty (STDIN) at the same time.  And that's bad mojo.
    # (Besides, if they're typing data in from a tty by hand, they don't need it
    # to be paged since we process each line they enter as soon as they hit return.)
    #
    # If both in and out _are_ tty's, just dup STDOUT and make them page it themselves.
    #
##    if(-t STDOUT and (not -t STDIN or (@FILES and join("\n", @FILES) !~ /^-$/ms))) {
##        $OUTPUT->open($PAGER) or die "$0: can't open pager '$PAGER': $!\n";
##    } else {
##        $OUTPUT->open('>& STDOUT') or die "$0: can't dup STDOUT: $!\n";
##    }
    $OUTPUT->open('>tempout.htm') or die "$0: can't create tempout.htm $!\n";

    ###push @FILES, '-' unless(@FILES);  # Use STDIN if nothing specified.
    push @FILES, "$0" unless(@FILES);  # Use SELF if nothing specified.

    foreach my $file (@FILES) {

        my $use_code = 0;
        my @CODE;

        #
        # Ref's are code passed in via -c
        #
        if(ref $file) {
            $use_code = 1;
            push @CODE, $$file;
        } else {
            $INPUT->open(" $file") or die "$0: can't open $file: $!\n";
        }

        #
        # Reset so that line numbers start over and un-ended PODs, string, etc
        # don't carry over into the next file.
        #
        if($OPTIONS{'Reset'}) {

            $formatter->reset();

        };


		#
        # Display the name of the current file.
        #
        if($OPTIONS{'Name'}) {
            my $fn = ref $file ? "CODE" : $file;
			###print $OUTPUT $formatter->format_token("<html>\n<head>\n<title> $fn </title>\n", 'Whitespace');
	        print $OUTPUT "\n   ", $formatter->format_token("<html>\n<head>\n<title>  -- $fn --  </title>\n", 'Whitespace'), "\n\n";
			
			add_html_style ( $OUTPUT );

			print $OUTPUT $formatter->format_token("</head>\n<body>\n", 'Whitespace');

			prt ($OUTPUT, "<h1 align='center'>\n");
            print $OUTPUT "\n", $formatter->format_token("<b>  -- $fn --  <b>", 'File_Name'), "\n\n";
			prt ($OUTPUT, "</h1>\n");

			add_html_table($OUTPUT); ### like <table align="center" width="90%" border="2" bgcolor="#eeeeee"> <tr> <td>
			prt ($OUTPUT, "<tr>\n");
			prt ($OUTPUT, "<td>\n");

        }

        while($_ = $use_code ? shift(@CODE) : <$INPUT>) {
            chomp;

            #
            # Expand tabs.
            #
            if($OPTIONS{'Expand Tabs'}) {
                1 while s/\t+/' ' x (length($&) * $OPTIONS{'Shift'} - length($`) % $OPTIONS{'Shift'})/e;
            }

            #
            # Do formatting.
            #
            my $line = $formatter->format_string($_);

            if($OPTIONS{'POD'} or not $formatter->was_pod()) {

                if($OPTIONS{'Lines'}) {
                    print $OUTPUT $formatter->format_token(sprintf("%5s ", $formatter->line_count()), 'Line');
                }

                print $OUTPUT "$line<br>\n";

            }

        }

		prt ($OUTPUT, "</td>\n");
		prt ($OUTPUT, "</tr>\n");
		prt ($OUTPUT, "</table>\n");

		print $OUTPUT $formatter->format_token("</body>\n</html>\n", 'Whitespace');

        unless($use_code) {
            $INPUT->close or die "$0: can't close $file: $!\n";
        }

    }

    unless($OUTPUT->close() or $! =~ /Broken pipe/) {
        die "$0: can't close output stream: $!\n";
    }

}


#
# Convert module names (eg, Syntax::Highlight::Perl) to
# fully qualified file names using current state of @INC.
#
# Returns undef on error (file-not-found).
#
sub mod2file {

    my $modname = shift or return undef;

    my $filename = ($modname !~ m|^(.*/)?[^/]*\.[^/]*$|) ? "$modname.pm" : $modname;

    $filename =~ s|^(.*/)||; # Strip leading path info ...
    my $startpath = $1;      # ... but save it in $startpath (we'll look there first).

    $filename =~ s|::|/|g;

    return "$startpath$filename" if($modname =~ m|/| and -e "$startpath$filename");


    foreach my $basedir ('.', @INC) {
        return "$basedir/$filename" if(-e "$basedir/$filename");
    }

    return undef;

}

#
# HTML file output additions

# establish a SYTLE - stuff between <style><!-- and --></style>, in <head>
sub addTTitem_bkgrd {
	my ($fh, $nm, $bd, $bg) = @_;
	print $fh <<"EOF3";
.$nm { BACKGROUND-COLOR: $bg }
EOF3
}


#################################
###    FONT-FAMILY: 'Andale Mono', 'Lucida Console', monospace
###   FONT-FAMILY: 'Courier New';
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 ... );
my $nm;
my $bd;
my $bg;
my $mx = @TTset;
#### my $ss = 6;
##tolog ("Processing $mx / 3 styles ...\n");
##tolog ( @TTset . "\n" );
my $i;
## my $additem = \&addTTitem_bkgrd;
## my $additem = \&addTTitem_full;
## my $add_item = \&addTTitem_simp;
## ??while (($nm, $bd, $bg) = @TTset) {
for ($i = 0; $i < ($mx / $ss); $i++) {
	 ###$nm = $TTset[($i*$ss)+0];
	 $bd = $TTset[($i*$ss)+1];
	 $bg = $TTset[($i*$ss)+2]; 
	 #$des1 = $TTset[($i*$ss)+3];
	 #$des2 = $TTset[($i*$ss)+4];
	 $nm = $TTset[($i*$ss)+5];

	 ##addTTitem_full ($fh, $nm, $bd, $bg);
	 addTTitem_bkgrd($fh, $nm, $bd, $bg);
	 ##addTTitem_simp ($fh, $nm, $bd, $bg);
}
###################

print $fh <<"EOF2";
-->
</style>

EOF2

### add_body_style ($fh); ### add little to the above ..

} ### end of sub #########################


# was <table align="center" width="96%" border="0" bgcolor="#eeeeee">
# then <table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse; border:none' 
#	align="center" width="96%" border="0" bgcolor="#eeeeee">
# color ? <table border="1" width="98%" style="font-family: Courier New; font-size: 10pt; color: #0000FF" cellpadding="0" cellspacing="0">
sub add_html_table {
	my ($fh) = @_;
	print $fh <<EOF;

<table align="center" border="0" width="80%" cellpadding="0" cellspacing="0" bgcolor="#eeeeee">

EOF

}


sub prt {
	my ($fh,$t) = @_;
	print $t;
	print $fh $t;
}


### EOF
