#!/usr/bin/perl 

#  Declarations
#================================================================
use strict;
use warnings; no warnings 'uninitialized';
use CGI qw( :standard );

use lib qw( /home/apv/local/share/perl/5.8.4 );
use Syntax::Highlight::Perl;

#  Set-up
#================================================================
my $DEFAULT      = '_view_self';
my $VIEW_FILE    = '_view_file';
# get a safe version of the file param
my ( $FILE )     = param('file') =~ /(\w[-\w]*(?:\.\w+)?)$/;
my $FILE_REAL;

if ( not $FILE or $FILE eq 'perlview.cgi' ) {
    $FILE ||= 'perlview.cgi';
    $FILE_REAL    = "./$FILE";
} else {
    $FILE_REAL    = "./code/$FILE";
}

my $NO_HEAD = param('nohead');

my %LINE_OPTION  = map { $_ => 1 } qw( none all code );
my $LINE_STYLE   = param('line') 
    if exists $LINE_OPTION{ param('line') };

my @OFF_LIMITS   = qw( search_me );  # prohibited from viewing
my $NO_NO = join( '|', grep defined, @OFF_LIMITS );
$NO_NO = qr/$NO_NO/i;

my %DISPATCH = (
                $DEFAULT      => \&view_self,
                $VIEW_FILE    => \&view_file,
                );
my $EX = '_ex';

#  we want resonable defaults
my $ACTION = param($EX) || $FILE ? $VIEW_FILE : $DEFAULT;
my $TITLE = $FILE ? "Viewer: $FILE" : "Viewer";

my $URL  = '/perl/perlview.cgi'; # need for virtual includes
my $SELF = url(-relative => 1);  # relative file name out of $0

my $LINE_NUMBER_COLOR = '#99CCDD';

#  Program proper
#================================================================

print header();

print
    start_html(-title   => $TITLE,
               -style => { -src => '/css/perl.css' })
    unless $NO_HEAD;

error("Sorry, this one's off limits. &nbsp; <nobr>: )</nobr>") 
    if $FILE =~ $NO_NO;

if ( exists $DISPATCH{$ACTION} ) {  # valid action was specified

    eval {
        &{ $DISPATCH{$ACTION} };    # execute sub reference
    };
#  we use eval{} to catch *anything* that could go wrong

    $@ && error("Problem executing! Please shop with our ",
                "competitors while we fix the problem.", ul($@));
#  this error message is for satirical production use only

} else {  # altered GET in URL? a non-existent sub was specified

    print headline( red("Couldn't understand your request!", 
                        "Please back up and try again.") );
}
print end_html() unless $NO_HEAD;

exit 0;

#  Subroutines
#================================================================
sub view_self {

    print title_line($SELF);
    $FILE = $SELF;
    $FILE_REAL = "./perlview.cgi";
    print_file();
}
#================================================================
sub view_file {

    unless ( $FILE ) {

        &{ $DISPATCH{ $DEFAULT } };

    } elsif ( not -e $FILE_REAL or not -r _ ) {

        error("<i>$FILE</i> does not exist!");

    } else {

        print title_line($FILE) unless $NO_HEAD;
        print_file();
    }
}
#================================================================
sub title_line {

    my $title = shift;
    my @img_links;

    $LINE_STYLE ||= 'code';
    $FILE ||= $SELF;

    push @img_links, 
    "<a href=\"$URL?line=all&file=$FILE&$EX=$VIEW_FILE\"># All Lines</a>"
        if $LINE_STYLE ne 'all';

    push @img_links, 
    "<a href=\"$URL?line=code&file=$FILE&$EX=$VIEW_FILE\"># Code Lines</a>"
        if $LINE_STYLE ne 'code';

    push @img_links, 
    "<a href=\"$URL?line=none&file=$FILE&$EX=$VIEW_FILE\">No Line #s</a>"
        if $LINE_STYLE ne 'none';

    push @img_links, 
    "<a href=\"$URL?line=$LINE_STYLE\">View the Viewer</a>"
        if $FILE ne $SELF;

    my $img_links = join(' | ', @img_links);

    $title = ( $title eq $SELF ) || ( $title !~ /cgi|html$/ ) ?
        $title : "<a href=\"$title\">$title</a>";

    return <<JustSayMaybe
<div class="lead">
File: <b>$title</b>
</div>
<div style="float:right">
<b style="font-size:10px;">
    $img_links
</b>
</div>
JustSayMaybe
}
#================================================================
sub print_file {

    open F, '<', $FILE_REAL or error("Couldn't open '$FILE': $!");

    my $formatter = initialize_formatter();

    print "\n<pre>" unless $NO_HEAD;

    if ( ! $LINE_STYLE or $LINE_STYLE eq 'none' ) {

        while (<F>) { print $formatter->format_string($_); }

    } elsif ( $LINE_STYLE eq 'all' ) {

        my $count = 0;
        while (<F>) {
            printf qq|<span style="color:$LINE_NUMBER_COLOR">%3d</span> %s|,
            ++$count, $formatter->format_string($_);
        }

    } elsif ( $LINE_STYLE eq 'code' ) {

        my $count = 0;
        while (<F>) {
            printf "%s %s", 
            /^\s*(?!#)\s*\S/ ?
               (sprintf qq|<span style="color:$LINE_NUMBER_COLOR">%3d</span>|, 
                            ++$count )
                  : '   ',
                  $formatter->format_string($_);
        }
    }
    close F;
    print "</pre>\n" unless $NO_HEAD;
}
#================================================================
sub initialize_formatter {

    my $formatter = Syntax::Highlight::Perl->new()
        or error("Could not initialize the formatter!");

    $formatter->define_substitution('<' => '&lt;', 
                                    '>' => '&gt;',
                                    '"' => '&quot;',
                                    '&' => '&amp;'); # HTML escapes.

# CSS spec means #069 is same as #006699 for colors
    my $color_table = {
        'Variable_Scalar'   => 'color:#080;',
        'Variable_Array'    => 'color:#F70;',
        'Variable_Hash'     => 'color:#80F;',
        'Variable_Typeglob' => 'color:#F033',
        'Subroutine'        => 'color:#980;',
        'Quote'             => 'color:#F00;',
        'String'            => 'color:#00A;',
        'Comment_Normal'    => 'color:#069;font-style:italic;',
        'Comment_POD'       => 'color:#014;',
        'Bareword'          => 'color:#939;',
        'Package'           => 'color:#900;',
        'Number'            => 'color:#F0F;',
        'Operator'          => 'color:#000;',
        'Symbol'            => 'color:#000;',
        'Keyword'           => 'color:#000;',
        'Builtin_Operator'  => 'color:#300;',
        'Builtin_Function'  => 'color:#001;',
        'Character'         => 'color:#800;',
        'Directive'         => 'color:#399;font-style:italic;',
        'Label'             => 'color:#939;font-style:italic;',
    };

# install the formats set up above
    while ( my ( $type, $style ) = each %{$color_table} ) {

        $formatter->set_format($type, [ qq|<span style=\"$style\">|, 
                                        '</span>' ] );
    }
    return $formatter;
}
#================================================================
sub red {
    span({-style => "color:#A00;" },
         join(' ', @_)
         );
}
#================================================================
sub error {
    print
        p({-style => "font-size:130%;"},
          red(@_)
          ),
          end_html();
    exit;
}
#================================================================