Generated: Tue Feb 2 17:55:00 2010 from viewperl3.pl 2006/06/19 16.8 KB.
#!/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 _at_ hotmail _dot_ 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