#!/usr/bin/perl 

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

#  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 'viewer.cgi' ) {
    $FILE ||= 'viewer.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/viewer.cgi'; # need so we can use 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} ) {  # a valid action was specified

    eval {
        &{ $DISPATCH{$ACTION} };        # execute sub reference
    };
#  we do it with 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;
    my $FILE_REAL = "./viewer.cgi";
    print_file();
}
#=====================================================================
sub view_file {

    unless ( $FILE ) {

        &{ $DISPATCH{ $DEFAULT } };

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

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

    } else {

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

    my $title = shift;
    my @nav_links;

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

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

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

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

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

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

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

    return <<JustSayMaybe
<table width=100% cellpadding=2 cellspacing=0 border=0><tr><td valign=top>
<div class=lead>
File: <b>$title</b>
</div>
</td><td align=right valign=top>
<b style="font-size:10px;">
    $nav_links
</b>
</td></tr></table>
JustSayMaybe
}
#=====================================================================
sub print_file {

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

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

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

        while (<F>) { print encode_entities($_) }

    } elsif ( $LINE_STYLE eq 'all' ) {

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

    } elsif ( $LINE_STYLE eq 'code' ) {

        my $count = 0;
        while (<F>) {
            printf "%s %s", 
            /^\s*(?!#)\s*\S/ ?
                  ( sprintf "<span style=\"color:$LINE_NUMBER_COLOR\">%3d</span>",
                    ++$count )
                  : '   ',
                  encode_entities($_);
        }
    }
    close F;
    print "</pre>\n" unless $NO_HEAD;
}
#=====================================================================
sub red {
    span({-style => "color:#A00;" },
         join(' ', @_)
         );
}
#=====================================================================
sub error {
    print
        p({-style => "font-size:130%;"},
          red(@_)
          ),
          end_html();
    exit;
}
#=====================================================================