3 # $Id: SWCGI.pm,v 1.2 1999/08/24 12:15:33 mdw Exp $
5 # Miscellaneous CGI support functions
10 #----- Licensing notice -----------------------------------------------------
12 # This file is part of sw-tools.
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.
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.
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.
28 #----- Revision history -----------------------------------------------------
31 # Revision 1.2 1999/08/24 12:15:33 mdw
32 # Properly sanitize CGI arguments (like `gtk+').
34 # Revision 1.1 1999/07/30 18:46:37 mdw
35 # New CGI script for browsing installed software and documentation.
38 #----- Package header -------------------------------------------------------
46 @EXPORT = qw(barf
%Q $ref);
47 @EXPORT_OK = qw(read sanitize
);
48 %EXPORT_TAGS = (layout
=> [qw(header footer
)],
49 debug
=> [qw(dumphash
)]);
51 Exporter
::export_ok_tags
(qw(layout debug
));
53 #----- Layout control -------------------------------------------------------
57 # --- @header(TITLE)@ --
59 # Emit an HTML header. This can be customized as required. Something
60 # sensible happens if a header has already been emitted.
72 Content-Type: text/html
74 <!doctype html public "-//W3C//DTD HTML 3.2 Final//EN">
77 </title></head><body bgcolor=white>
85 # Emit an HTML footer to a page.
89 <hr><div align=right><font size="-1"><i>
90 sw.cgi ($C{pkg} $C{version})
91 </i></font></div></body></html>
95 #----- Useful functions -----------------------------------------------------
97 # --- @barf(ERROR)@ ---
99 # Reports an error and exits. The error is lovingly trapped in an HTML
100 # wrapper so that it can appropriately terrify a user.
104 header
("Internal error in sw.cgi");
107 Internal error in sw.cgi
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
121 #----- Debugging ------------------------------------------------------------
123 # --- @dumphash(HASH)@ ---
125 # Dumps a hash out in a tabular format.
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";
136 #----- Sanitizing links -----------------------------------------------------
140 $l =~ s/[+&%=]/"%" . sprintf("%02x", ord($&))/eg;
142 $l =~ s/[^!-~]/"%" . sprintf("%02x", ord($&))/eg;
146 #----- Argument reading -----------------------------------------------------
149 $ref = "/cgi-bin/sw.cgi";
151 # --- @read([QUERY])@ ---
153 # Reads arguments from a web server.
158 # --- Read in the query string ---
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,
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") {
173 } elsif (!defined($meth)) {
174 $q = join("&", @ARGV);
176 barf
("unsupported requst method `$meth'");
180 # --- Parse it up into little bits ---
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;
189 # --- Set other bits of data from this ---
191 $ENV{"SCRIPT_NAME"} and $ref = $ENV{"SCRIPT_NAME"};
194 #----- That's all, folks ----------------------------------------------------