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

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