chiark - git - mdw - sw-tools/blob - perl/SWCGI.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SWCGI.pm,v 1.3 2004/04/08 01:52:19 mdw Exp $
   4 #
   5 # Miscellaneous CGI support functions
   6 #
   7 # (c) 1999 EBI
   8 #
   9
  10 #----- Licensing notice -----------------------------------------------------
  11 #
  12 # This file is part of sw-tools.
  13 #
  14 # sw-tools is free software; you can redistribute it and/or modify
  15 # it under the terms of the GNU General Public License as published by
  16 # the Free Software Foundation; either version 2 of the License, or
  17 # (at your option) any later version.
  18 #
  19 # sw-tools is distributed in the hope that it will be useful,
  20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 # GNU General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with sw-tools; if not, write to the Free Software Foundation,
  26 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  27
  28 #----- Package header -------------------------------------------------------
  29
  30 package SWCGI;
  31
  32 use Exporter;
  33 use SWConfig;
  34
  35 @ISA = qw(Exporter);
  36 @EXPORT = qw(barf %Q $ref);
  37 @EXPORT_OK = qw(read sanitize);
  38 %EXPORT_TAGS = (layout => [qw(header footer)],
  39                 debug => [qw(dumphash)]);
  40
  41 Exporter::export_ok_tags(qw(layout debug));
  42
  43 #----- Layout control -------------------------------------------------------
  44
  45 $header = 0;
  46
  47 # --- @header(TITLE)@ --
  48 #
  49 # Emit an HTML header.  This can be customized as required.  Something
  50 # sensible happens if a header has already been emitted.
  51
  52 sub header($) {
  53   my ($title) = @_;
  54   if ($header) {
  55     print <<EOF;
  56 <hr><h1>
  57 $title
  58 </h1>
  59 EOF
  60   } else {
  61     print <<EOF;
  62 Content-Type: text/html
  63
  64 <!doctype html public "-//W3C//DTD HTML 3.2 Final//EN">
  65 <html><head><title>
  66 $title
  67 </title></head><body bgcolor=white>
  68 EOF
  69     $header = 1;
  70   }
  71 }
  72
  73 # --- @footer@ ---
  74 #
  75 # Emit an HTML footer to a page.
  76
  77 sub footer() {
  78   print <<EOF;
  79 <hr><div align=right><font size="-1"><i>
  80 sw.cgi ($C{pkg} $C{version})
  81 </i></font></div></body></html>
  82 EOF
  83 }
  84
  85 #----- Useful functions -----------------------------------------------------
  86
  87 # --- @barf(ERROR)@ ---
  88 #
  89 # Reports an error and exits.  The error is lovingly trapped in an HTML
  90 # wrapper so that it can appropriately terrify a user.
  91
  92 sub barf($) {
  93   my ($error) = @_;
  94   header("Internal error in sw.cgi");
  95   print <<EOF;
  96 <h3>
  97 Internal error in sw.cgi
  98 </h3>
  99
 100 <p>$error
 101
 102 <p>This may be a result of a broken link or a server misconfiguration,
 103 or it might be a bug in sw.cgi itself.  Please report this problem to
 104 your <a href="mailto:$ENV{SERVER_ADMIN}">server administrator</a> to
 105 sort out.
 106 EOF
 107   footer();
 108   exit;
 109 }
 110
 111 #----- Debugging ------------------------------------------------------------
 112
 113 # --- @dumphash(HASH)@ ---
 114 #
 115 # Dumps a hash out in a tabular format.
 116
 117 sub dumphash(\%) {
 118   my ($h) = @_;
 119   print "<table border=1 bgcolor=lightgrey>\n";
 120   foreach my $k (sort(keys(%$h))) {
 121     print "  <tr><th align=left>$k<td>$h->{$k}\n";
 122   }
 123   print "</table>\n";
 124 }
 125
 126 #----- Sanitizing links -----------------------------------------------------
 127
 128 sub sanitize($) {
 129   my ($l) = @_;
 130   $l =~ s/[+&%=]/"%" . sprintf("%02x", ord($&))/eg;
 131   $l =~ tr/ /+/;
 132   $l =~ s/[^!-~]/"%" . sprintf("%02x", ord($&))/eg;
 133   return $l;
 134 }
 135
 136 #----- Argument reading -----------------------------------------------------
 137
 138 %Q = ();
 139 $ref = "/cgi-bin/sw.cgi";
 140
 141 # --- @read([QUERY])@ ---
 142 #
 143 # Reads arguments from a web server.
 144
 145 sub read(;$) {
 146   my ($q) = @_;
 147
 148   # --- Read in the query string ---
 149   #
 150   # If a query is supplied as an argument then use that.  Otherwise use the
 151   # `REQUEST_METHOD' variable.  Accept `GET' or `POST', and use the
 152   # appropriate method for getting the data.  If the variable wasn't set,
 153   # read the command line arguments.  If it's something I don't understand,
 154   # raise an error.
 155
 156   unless (defined($q)) {
 157     my $meth = $ENV{"REQUEST_METHOD"};
 158     if ($meth eq "GET") {
 159       $q = $ENV{"QUERY_STRING"};
 160     } elsif ($meth eq "PUT") {
 161       local $/ = undef;
 162       $q = <STDIN>;
 163     } elsif (!defined($meth)) {
 164       $q = join("&", @ARGV);
 165     } else {
 166       barf("unsupported requst method `$meth'");
 167     }
 168   }
 169
 170   # --- Parse it up into little bits ---
 171
 172   foreach my $pair (split(/\&/, $q)) {
 173     my ($k, $v) = split(/\=/, $pair);
 174     $k =~ tr/+/ /; $k =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
 175     $v =~ tr/+/ /; $v =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
 176     $Q{$k} = $v;
 177   }
 178
 179   # --- Set other bits of data from this ---
 180
 181   $ENV{"SCRIPT_NAME"} and $ref = $ENV{"SCRIPT_NAME"};
 182 }
 183
 184 #----- That's all, folks ----------------------------------------------------
 185
 186 1;