File: perlview.cgi
1 #!/usr/bin/perl
2
3 # Declarations
4 #================================================================
5 use strict;
6 use warnings; no warnings 'uninitialized';
7 use CGI qw( :standard );
8
9 use lib qw( /home/apv/local/share/perl/5.8.4 );
10 use Syntax::Highlight::Perl;
11
12 # Set-up
13 #================================================================
14 my $DEFAULT = '_view_self';
15 my $VIEW_FILE = '_view_file';
16 # get a safe version of the file param
17 my ( $FILE ) = param('file') =~ /(\w[-\w]*(?:\.\w+)?)$/;
18 my $FILE_REAL;
19
20 if ( not $FILE or $FILE eq 'perlview.cgi' ) {
21 $FILE ||= 'perlview.cgi';
22 $FILE_REAL = "./$FILE";
23 } else {
24 $FILE_REAL = "./code/$FILE";
25 }
26
27 my $NO_HEAD = param('nohead');
28
29 my %LINE_OPTION = map { $_ => 1 } qw( none all code );
30 my $LINE_STYLE = param('line')
31 if exists $LINE_OPTION{ param('line') };
32
33 my @OFF_LIMITS = qw( search_me ); # prohibited from viewing
34 my $NO_NO = join( '|', grep defined, @OFF_LIMITS );
35 $NO_NO = qr/$NO_NO/i;
36
37 my %DISPATCH = (
38 $DEFAULT => \&view_self,
39 $VIEW_FILE => \&view_file,
40 );
41 my $EX = '_ex';
42
43 # we want resonable defaults
44 my $ACTION = param($EX) || $FILE ? $VIEW_FILE : $DEFAULT;
45 my $TITLE = $FILE ? "Viewer: $FILE" : "Viewer";
46
47 my $URL = '/perl/perlview.cgi'; # need for virtual includes
48 my $SELF = url(-relative => 1); # relative file name out of $0
49
50 my $LINE_NUMBER_COLOR = '#99CCDD';
51
52 # Program proper
53 #================================================================
54
55 print header();
56
57 print
58 start_html(-title => $TITLE,
59 -style => { -src => '/css/perl.css' })
60 unless $NO_HEAD;
61
62 error("Sorry, this one's off limits. <nobr>: )</nobr>")
63 if $FILE =~ $NO_NO;
64
65 if ( exists $DISPATCH{$ACTION} ) { # valid action was specified
66
67 eval {
68 &{ $DISPATCH{$ACTION} }; # execute sub reference
69 };
70 # we use eval{} to catch *anything* that could go wrong
71
72 $@ && error("Problem executing! Please shop with our ",
73 "competitors while we fix the problem.", ul($@));
74 # this error message is for satirical production use only
75
76 } else { # altered GET in URL? a non-existent sub was specified
77
78 print headline( red("Couldn't understand your request!",
79 "Please back up and try again.") );
80 }
81 print end_html() unless $NO_HEAD;
82
83 exit 0;
84
85 # Subroutines
86 #================================================================
87 sub view_self {
88
89 print title_line($SELF);
90 $FILE = $SELF;
91 $FILE_REAL = "./perlview.cgi";
92 print_file();
93 }
94 #================================================================
95 sub view_file {
96
97 unless ( $FILE ) {
98
99 &{ $DISPATCH{ $DEFAULT } };
100
101 } elsif ( not -e $FILE_REAL or not -r _ ) {
102
103 error("<i>$FILE</i> does not exist!");
104
105 } else {
106
107 print title_line($FILE) unless $NO_HEAD;
108 print_file();
109 }
110 }
111 #================================================================
112 sub title_line {
113
114 my $title = shift;
115 my @img_links;
116
117 $LINE_STYLE ||= 'code';
118 $FILE ||= $SELF;
119
120 push @img_links,
121 "<a href=\"$URL?line=all&file=$FILE&$EX=$VIEW_FILE\"># All Lines</a>"
122 if $LINE_STYLE ne 'all';
123
124 push @img_links,
125 "<a href=\"$URL?line=code&file=$FILE&$EX=$VIEW_FILE\"># Code Lines</a>"
126 if $LINE_STYLE ne 'code';
127
128 push @img_links,
129 "<a href=\"$URL?line=none&file=$FILE&$EX=$VIEW_FILE\">No Line #s</a>"
130 if $LINE_STYLE ne 'none';
131
132 push @img_links,
133 "<a href=\"$URL?line=$LINE_STYLE\">View the Viewer</a>"
134 if $FILE ne $SELF;
135
136 my $img_links = join(' | ', @img_links);
137
138 $title = ( $title eq $SELF ) || ( $title !~ /cgi|html$/ ) ?
139 $title : "<a href=\"$title\">$title</a>";
140
141 return <<JustSayMaybe
142 <div class="lead">
143 File: <b>$title</b>
144 </div>
145 <div style="float:right">
146 <b style="font-size:10px;">
147 $img_links
148 </b>
149 </div>
150 JustSayMaybe
151 }
152 #================================================================
153 sub print_file {
154
155 open F, '<', $FILE_REAL or error("Couldn't open '$FILE': $!");
156
157 my $formatter = initialize_formatter();
158
159 print "\n<pre>" unless $NO_HEAD;
160
161 if ( ! $LINE_STYLE or $LINE_STYLE eq 'none' ) {
162
163 while (<F>) { print $formatter->format_string($_); }
164
165 } elsif ( $LINE_STYLE eq 'all' ) {
166
167 my $count = 0;
168 while (<F>) {
169 printf qq|<span style="color:$LINE_NUMBER_COLOR">%3d</span> %s|,
170 ++$count, $formatter->format_string($_);
171 }
172
173 } elsif ( $LINE_STYLE eq 'code' ) {
174
175 my $count = 0;
176 while (<F>) {
177 printf "%s %s",
178 /^\s*(?!#)\s*\S/ ?
179 (sprintf qq|<span style="color:$LINE_NUMBER_COLOR">%3d</span>|,
180 ++$count )
181 : ' ',
182 $formatter->format_string($_);
183 }
184 }
185 close F;
186 print "</pre>\n" unless $NO_HEAD;
187 }
188 #================================================================
189 sub initialize_formatter {
190
191 my $formatter = Syntax::Highlight::Perl->new()
192 or error("Could not initialize the formatter!");
193
194 $formatter->define_substitution('<' => '<',
195 '>' => '>',
196 '"' => '"',
197 '&' => '&'); # HTML escapes.
198
199 # CSS spec means #069 is same as #006699 for colors
200 my $color_table = {
201 'Variable_Scalar' => 'color:#080;',
202 'Variable_Array' => 'color:#F70;',
203 'Variable_Hash' => 'color:#80F;',
204 'Variable_Typeglob' => 'color:#F033',
205 'Subroutine' => 'color:#980;',
206 'Quote' => 'color:#F00;',
207 'String' => 'color:#00A;',
208 'Comment_Normal' => 'color:#069;font-style:italic;',
209 'Comment_POD' => 'color:#014;',
210 'Bareword' => 'color:#939;',
211 'Package' => 'color:#900;',
212 'Number' => 'color:#F0F;',
213 'Operator' => 'color:#000;',
214 'Symbol' => 'color:#000;',
215 'Keyword' => 'color:#000;',
216 'Builtin_Operator' => 'color:#300;',
217 'Builtin_Function' => 'color:#001;',
218 'Character' => 'color:#800;',
219 'Directive' => 'color:#399;font-style:italic;',
220 'Label' => 'color:#939;font-style:italic;',
221 };
222
223 # install the formats set up above
224 while ( my ( $type, $style ) = each %{$color_table} ) {
225
226 $formatter->set_format($type, [ qq|<span style=\"$style\">|,
227 '</span>' ] );
228 }
229 return $formatter;
230 }
231 #================================================================
232 sub red {
233 span({-style => "color:#A00;" },
234 join(' ', @_)
235 );
236 }
237 #================================================================
238 sub error {
239 print
240 p({-style => "font-size:130%;"},
241 red(@_)
242 ),
243 end_html();
244 exit;
245 }
246 #================================================================