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