#!/usr/bin/perl -w # # viewperl - 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. # 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 $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. ); $PAGER = '| less -rF'; # # 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 = ( 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] }, ); process_files(); #===================================================================== # 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"; } push @FILES, '-' unless(@FILES); # Use STDIN 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 "\n ", $formatter->format_token(" -- $fn -- ", 'File_Name'), "\n\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\n"; } } 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; }