Perl
LISTING ONE



1     #!/usr/bin/perl -Tw
2     use strict;
3     
4     ## table: write a table or a <pre> based on browser type
5     
6     ## system stuff
7     $|++;
8     $ENV{PATH} = "/usr/ucb:/bin:/usr/bin";
9     
10    ## HTML stuff
11    print "Content-type: text/html\n\n";
12    
13    ## the main program (in eval so we can trap problems)
14    eval {
15    
16      ## get the CGI data
17      my $uri = $ENV{DOCUMENT_URI}; # valid only in SSI
18      my $path = $ENV{PATH_INFO};   # stuff after cgi name
19      my $agent = $ENV{HTTP_USER_AGENT}; # user agent
20    
21      ## validate this as an SSI
22      die "missing document_uri" unless $uri;
23    
24      ## split the URI up, so we know where the file was
25      my ($dir,$file) = $uri =~ m,(.*/)(.*),s;
26    
27      ## massage the directory to get the containing dir
28      if ($dir =~ m,^/~(\w+)/(.*)$,s) {
29        $dir = "/home/$1/public_html/$2"; # teleport specific
30      } else {
31        die "cannot translate dir";
32      }
33    
34      ## go there
35      chdir $dir or die "cannot cd to $dir: $!\n";
36    
37      ## open sourcefile
38      my ($filename) = $path =~ m!^/?([-\w.]+)!;
39      $filename .= ".table";        # ensure only "whatever.table"
40      die "missing filename in $path" unless $filename and -f 
$filename;
41      open F, $filename or die "cannot open $filename: $!";
42      my @max_in_col;
43      my @table;
44      my $text = $agent =~ /Emacs-W3|Lynx/i; # you may wish to 
extend this list
45      while (<F>) {
46        chomp;
47        my @row = split /\t/;
48    
49        if ($text) {
50          ## save maximums
51          for (0..$#row) {
52            my $tmp = $row[$_];
53            $tmp =~ s/<.*?>//g;     # don't count HTML markup
54            $tmp = length $tmp;
55            $max_in_col[$_] = $tmp if $max_in_col[$_] < $tmp;
56          }
57        }
58        push(@table, [@row]);
59      }
60      if ($text) {
61        my $format = join " | ", "", (map "%".(0-$_)."s", @max_in_col), 
"\n";
62        print "<pre>\n";
63        for (@table) {
64          printf $format, @$_;
65        }
66        print "</pre>\n";
67      } else {
68        print "<table border=1>\n";
69        for (@table) {
70          print "<tr>";
71          print map "<td>$_</td>", @$_;
72          print "</tr>\n";
73        }
74        print "</table>\n";
75      }
76    };
77    
78    ## if an error, say so:
79    if ($@) {
80      chomp $@;
81      $_ = "[error: $@]";
82      s/&/&amp;/g;
83      s/</&lt;/g;
84      s/>/&gt;/g;
85      s/\n/<br>/g;
86      print;
87    }