#!/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;

}