|
File: viewer.cgi
| # All Lines | No Line #s |
#!/usr/bin/perl
# Declarations
#=====================================================================
1 use strict;
2 use warnings; no warnings 'uninitialized';
3 use CGI qw( :standard );
4 use HTML::Entities;
# Set-up
#=====================================================================
5 my $DEFAULT = '_view_self';
6 my $VIEW_FILE = '_view_file';
# get a safe version of the file param
7 my ( $FILE ) = param('file') =~ /(\w[-\w]*(?:\.\w+)?)$/;
8 my $FILE_REAL;
9 if ( not $FILE or $FILE eq 'viewer.cgi' ) {
10 $FILE ||= 'viewer.cgi';
11 $FILE_REAL = "./$FILE";
12 } else {
13 $FILE_REAL = "./code/$FILE";
14 }
15 my $NO_HEAD = param('nohead');
16 my %LINE_OPTION = map { $_ => 1 } qw( none all code );
17 my $LINE_STYLE = param('line')
18 if exists $LINE_OPTION{ param('line') };
19 my @OFF_LIMITS = qw( search_me ); # prohibited from viewing
20 my $NO_NO = join( '|', grep defined, @OFF_LIMITS );
21 $NO_NO = qr/$NO_NO/i;
22 my %DISPATCH = (
23 $DEFAULT => \&view_self,
24 $VIEW_FILE => \&view_file,
25 );
26 my $EX = '_ex';
# we want resonable defaults
27 my $ACTION = param($EX) || $FILE ? $VIEW_FILE : $DEFAULT;
28 my $TITLE = $FILE ? "Viewer: $FILE" : "Viewer";
29 my $URL = '/perl/viewer.cgi'; # need so we can use virtual includes
30 my $SELF = url(-relative => 1); # relative file name out of $0
31 my $LINE_NUMBER_COLOR = '#99CCDD';
# Program proper
#=====================================================================
32 print header();
33 print
34 start_html(-title => $TITLE,
35 -style => { -src => '/css/perl.css' })
36 unless $NO_HEAD;
37 error("Sorry, this one's off limits. <nobr>: )</nobr>")
38 if $FILE =~ $NO_NO;
39 if ( exists $DISPATCH{$ACTION} ) { # a valid action was specified
40 eval {
41 &{ $DISPATCH{$ACTION} }; # execute sub reference
42 };
# we do it with eval{} to catch *anything* that could go wrong
43 $@ && error("Problem executing! Please shop with our ",
44 "competitors while we fix the problem.", ul($@));
# this error message is for satirical production use only
45 } else { # altered GET in URL? a non-existent sub was specified
46 print headline( red("Couldn't understand your request!",
47 "Please back up and try again.") );
48 }
49 print end_html() unless $NO_HEAD;
50 exit 0;
# Subroutines
#=====================================================================
51 sub view_self {
52 print title_line($SELF);
53 $FILE = $SELF;
54 my $FILE_REAL = "./viewer.cgi";
55 print_file();
56 }
#=====================================================================
57 sub view_file {
58 unless ( $FILE ) {
59 &{ $DISPATCH{ $DEFAULT } };
60 } elsif ( not -e $FILE_REAL or not -r _ ) {
61 error("<i>$FILE ($FILE_REAL)</i> does not exist!");
62 } else {
63 print title_line($FILE) unless $NO_HEAD;
64 print_file();
65 }
66 }
#=====================================================================
67 sub title_line {
68 my $title = shift;
69 my @nav_links;
70 $LINE_STYLE ||= 'code';
71 $FILE ||= $SELF;
72 push @nav_links,
73 "<a href=\"$URL?line=all&file=$FILE&$EX=$VIEW_FILE\"># All Lines</a>"
74 if $LINE_STYLE ne 'all';
75 push @nav_links,
76 "<a href=\"$URL?line=code&file=$FILE&$EX=$VIEW_FILE\"># Code Lines</a>"
77 if $LINE_STYLE ne 'code';
78 push @nav_links,
79 "<a href=\"$URL?line=none&file=$FILE&$EX=$VIEW_FILE\">No Line #s</a>"
80 if $LINE_STYLE ne 'none';
81 push @nav_links,
82 "<a href=\"$URL?line=$LINE_STYLE\">View the Viewer</a>"
83 if $FILE ne $SELF;
84 my $nav_links = join(' | ', @nav_links);
85 $title = ( $title eq $SELF ) || ( $title !~ /cgi|html$/ ) ?
86 $title : "<a href=\"$title\">$title</a>";
87 return <<JustSayMaybe
88 <table width=100% cellpadding=2 cellspacing=0 border=0><tr><td valign=top>
89 <div class=lead>
90 File: <b>$title</b>
91 </div>
92 </td><td align=right valign=top>
93 <b style="font-size:10px;">
94 $nav_links
95 </b>
96 </td></tr></table>
97 JustSayMaybe
98 }
#=====================================================================
99 sub print_file {
100 open F, '<', $FILE_REAL or error("Couldn't open '$FILE': $!");
101 print "\n<pre>" unless $NO_HEAD;
102 if ( ! $LINE_STYLE or $LINE_STYLE eq 'none' ) {
103 while (<F>) { print encode_entities($_) }
104 } elsif ( $LINE_STYLE eq 'all' ) {
105 my $count = 0;
106 while (<F>) {
107 printf "<span style=\"color:$LINE_NUMBER_COLOR\">%3d</span> %s",
108 ++$count, encode_entities($_);
109 }
110 } elsif ( $LINE_STYLE eq 'code' ) {
111 my $count = 0;
112 while (<F>) {
113 printf "%s %s",
114 /^\s*(?!#)\s*\S/ ?
115 ( sprintf "<span style=\"color:$LINE_NUMBER_COLOR\">%3d</span>",
116 ++$count )
117 : ' ',
118 encode_entities($_);
119 }
120 }
121 close F;
122 print "</pre>\n" unless $NO_HEAD;
123 }
#=====================================================================
124 sub red {
125 span({-style => "color:#A00;" },
126 join(' ', @_)
127 );
128 }
#=====================================================================
129 sub error {
130 print
131 p({-style => "font-size:130%;"},
132 red(@_)
133 ),
134 end_html();
135 exit;
136 }
#=====================================================================