mdw@git.distorted.org.uk Git - sw-tools/blob - perl/SWCGI.pm

   1 # -*-perl-*-
   2 #
   3 # $Id: SWCGI.pm,v 1.2 1999/08/24 12:15:33 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 #----- Revision history -----------------------------------------------------
  29 #
  30 # $Log: SWCGI.pm,v $
  31 # Revision 1.2  1999/08/24 12:15:33  mdw
  32 # Properly sanitize CGI arguments (like `gtk+').
  33 #
  34 # Revision 1.1  1999/07/30 18:46:37  mdw
  35 # New CGI script for browsing installed software and documentation.
  36 #
  37
  38 #----- Package header -------------------------------------------------------
  39
  40 package SWCGI;
  41
  42 use Exporter;
  43 use SWConfig;
  44
  45 @ISA = qw(Exporter);
  46 @EXPORT = qw(barf %Q $ref);
  47 @EXPORT_OK = qw(read sanitize);
  48 %EXPORT_TAGS = (layout => [qw(header footer)],
  49                 debug => [qw(dumphash)]);
  50
  51 Exporter::export_ok_tags(qw(layout debug));
  52
  53 #----- Layout control -------------------------------------------------------
  54
  55 $header = 0;
  56
  57 # --- @header(TITLE)@ --
  58 #
  59 # Emit an HTML header.  This can be customized as required.  Something
  60 # sensible happens if a header has already been emitted.
  61
  62 sub header($) {
  63   my ($title) = @_;
  64   if ($header) {
  65     print <<EOF;
  66 <hr><h1>
  67 $title
  68 </h1>
  69 EOF
  70   } else {
  71     print <<EOF;
  72 Content-Type: text/html
  73
  74 <!doctype html public "-//W3C//DTD HTML 3.2 Final//EN">
  75 <html><head><title>
  76 $title
  77 </title></head><body bgcolor=white>
  78 EOF
  79     $header = 1;
  80   }
  81 }
  82
  83 # --- @footer@ ---
  84 #
  85 # Emit an HTML footer to a page.
  86
  87 sub footer() {
  88   print <<EOF;
  89 <hr><div align=right><font size="-1"><i>
  90 sw.cgi ($C{pkg} $C{version})
  91 </i></font></div></body></html>
  92 EOF
  93 }
  94
  95 #----- Useful functions -----------------------------------------------------
  96
  97 # --- @barf(ERROR)@ ---
  98 #
  99 # Reports an error and exits.  The error is lovingly trapped in an HTML
 100 # wrapper so that it can appropriately terrify a user.
 101
 102 sub barf($) {
 103   my ($error) = @_;
 104   header("Internal error in sw.cgi");
 105   print <<EOF;
 106 <h3>
 107 Internal error in sw.cgi
 108 </h3>
 109
 110 <p>$error
 111
 112 <p>This may be a result of a broken link or a server misconfiguration,
 113 or it might be a bug in sw.cgi itself.  Please report this problem to
 114 your <a href="mailto:$ENV{SERVER_ADMIN}">server administrator</a> to
 115 sort out.
 116 EOF
 117   footer();
 118   exit;
 119 }
 120
 121 #----- Debugging ------------------------------------------------------------
 122
 123 # --- @dumphash(HASH)@ ---
 124 #
 125 # Dumps a hash out in a tabular format.
 126
 127 sub dumphash(\%) {
 128   my ($h) = @_;
 129   print "<table border=1 bgcolor=lightgrey>\n";
 130   foreach my $k (sort(keys(%$h))) {
 131     print "  <tr><th align=left>$k<td>$h->{$k}\n";
 132   }
 133   print "</table>\n";
 134 }
 135
 136 #----- Sanitizing links -----------------------------------------------------
 137
 138 sub sanitize($) {
 139   my ($l) = @_;
 140   $l =~ s/[+&%=]/"%" . sprintf("%02x", ord($&))/eg;
 141   $l =~ tr/ /+/;
 142   $l =~ s/[^!-~]/"%" . sprintf("%02x", ord($&))/eg;
 143   return $l;
 144 }
 145
 146 #----- Argument reading -----------------------------------------------------
 147
 148 %Q = ();
 149 $ref = "/cgi-bin/sw.cgi";
 150
 151 # --- @read([QUERY])@ ---
 152 #
 153 # Reads arguments from a web server.
 154
 155 sub read(;$) {
 156   my ($q) = @_;
 157
 158   # --- Read in the query string ---
 159   #
 160   # If a query is supplied as an argument then use that.  Otherwise use the
 161   # `REQUEST_METHOD' variable.  Accept `GET' or `POST', and use the
 162   # appropriate method for getting the data.  If the variable wasn't set,
 163   # read the command line arguments.  If it's something I don't understand,
 164   # raise an error.
 165
 166   unless (defined($q)) {
 167     my $meth = $ENV{"REQUEST_METHOD"};
 168     if ($meth eq "GET") {
 169       $q = $ENV{"QUERY_STRING"};
 170     } elsif ($meth eq "PUT") {
 171       local $/ = undef;
 172       $q = <STDIN>;
 173     } elsif (!defined($meth)) {
 174       $q = join("&", @ARGV);
 175     } else {
 176       barf("unsupported requst method `$meth'");
 177     }
 178   }
 179
 180   # --- Parse it up into little bits ---
 181
 182   foreach my $pair (split(/\&/, $q)) {
 183     my ($k, $v) = split(/\=/, $pair);
 184     $k =~ tr/+/ /; $k =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
 185     $v =~ tr/+/ /; $v =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
 186     $Q{$k} = $v;
 187   }
 188
 189   # --- Set other bits of data from this ---
 190
 191   $ENV{"SCRIPT_NAME"} and $ref = $ENV{"SCRIPT_NAME"};
 192 }
 193
 194 #----- That's all, folks ----------------------------------------------------
 195
 196 1;