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