--- /dev/null
+# -*-perl-*-
+#
+# $Id: SWCGI.pm,v 1.1 1999/07/30 18:46:37 mdw Exp $
+#
+# Miscellaneous CGI support functions
+#
+# (c) 1999 EBI
+#
+
+#----- Licensing notice -----------------------------------------------------
+#
+# This file is part of sw-tools.
+#
+# sw-tools is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# sw-tools is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with sw-tools; if not, write to the Free Software Foundation,
+# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+#----- Revision history -----------------------------------------------------
+#
+# $Log: SWCGI.pm,v $
+# Revision 1.1 1999/07/30 18:46:37 mdw
+# New CGI script for browsing installed software and documentation.
+#
+
+#----- Package header -------------------------------------------------------
+
+package SWCGI;
+
+use Exporter;
+use SWConfig;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(barf %Q $ref);
+@EXPORT_OK = qw(read);
+%EXPORT_TAGS = (layout => [qw(header footer)],
+ debug => [qw(dumphash)]);
+
+Exporter::export_ok_tags(qw(layout debug));
+
+#----- Layout control -------------------------------------------------------
+
+$header = 0;
+
+# --- @header(TITLE)@ --
+#
+# Emit an HTML header. This can be customized as required. Something
+# sensible happens if a header has already been emitted.
+
+sub header($) {
+ my ($title) = @_;
+ if ($header) {
+ print <<EOF;
+<hr><h1>
+$title
+</h1>
+EOF
+ } else {
+ print <<EOF;
+Content-Type: text/html
+
+<!doctype html public "-//W3C//DTD HTML 3.2 Final//EN">
+<html><head><title>
+$title
+</title></head><body bgcolor=white>
+EOF
+ $header = 1;
+ }
+}
+
+# --- @footer@ ---
+#
+# Emit an HTML footer to a page.
+
+sub footer() {
+ print <<EOF;
+<hr><div align=right><font size="-1"><i>
+sw.cgi ($C{pkg} $C{version})
+</i></font></div></body></html>
+EOF
+}
+
+#----- Useful functions -----------------------------------------------------
+
+# --- @barf(ERROR)@ ---
+#
+# Reports an error and exits. The error is lovingly trapped in an HTML
+# wrapper so that it can appropriately terrify a user.
+
+sub barf($) {
+ my ($error) = @_;
+ header("Internal error in sw.cgi");
+ print <<EOF;
+<h3>
+Internal error in sw.cgi
+</h3>
+
+<p>$error
+
+<p>This may be a result of a broken link or a server misconfiguration,
+or it might be a bug in sw.cgi itself. Please report this problem to
+your <a href="mailto:$ENV{SERVER_ADMIN}">server administrator</a> to
+sort out.
+EOF
+ footer();
+ exit;
+}
+
+#----- Debugging ------------------------------------------------------------
+
+# --- @dumphash(HASH)@ ---
+#
+# Dumps a hash out in a tabular format.
+
+sub dumphash(\%) {
+ my ($h) = @_;
+ print "<table border=1 bgcolor=lightgrey>\n";
+ foreach my $k (sort(keys(%$h))) {
+ print " <tr><th align=left>$k<td>$h->{$k}\n";
+ }
+ print "</table>\n";
+}
+
+#----- Argument reading -----------------------------------------------------
+
+%Q = ();
+$ref = "/cgi-bin/sw.cgi";
+
+# --- @read([QUERY])@ ---
+#
+# Reads arguments from a web server.
+
+sub read(;$) {
+ my ($q) = @_;
+
+ # --- Read in the query string ---
+ #
+ # If a query is supplied as an argument then use that. Otherwise use the
+ # `REQUEST_METHOD' variable. Accept `GET' or `POST', and use the
+ # appropriate method for getting the data. If the variable wasn't set,
+ # read the command line arguments. If it's something I don't understand,
+ # raise an error.
+
+ unless (defined($q)) {
+ my $meth = $ENV{"REQUEST_METHOD"};
+ if ($meth eq "GET") {
+ $q = $ENV{"QUERY_STRING"};
+ } elsif ($meth eq "PUT") {
+ local $/ = undef;
+ $q = <STDIN>;
+ } elsif (!defined($meth)) {
+ $q = join("&", @ARGV);
+ } else {
+ barf("unsupported requst method `$meth'");
+ }
+ }
+
+ # --- Parse it up into little bits ---
+
+ foreach my $pair (split(/\&/, $q)) {
+ my ($k, $v) = split(/\=/, $pair);
+ $k =~ tr/+/ /; $k =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
+ $v =~ tr/+/ /; $v =~ s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
+ $Q{$k} = $v;
+ }
+
+ # --- Set other bits of data from this ---
+
+ $ENV{"SCRIPT_NAME"} and $ref = $ENV{"SCRIPT_NAME"};
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;
~mdw / sw-tools / blobdiff