[sw-tools] / perl / SWCGI.pm

# -*-perl-*-
#
# $Id: SWCGI.pm,v 1.2 1999/08/24 12:15:33 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.2  1999/08/24 12:15:33  mdw
# Properly sanitize CGI arguments (like `gtk+').
#
# 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 sanitize);
%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";
}

#----- Sanitizing links -----------------------------------------------------

sub sanitize($) {
  my ($l) = @_;
  $l =~ s/[+&%=]/"%" . sprintf("%02x", ord($&))/eg;
  $l =~ tr/ /+/;
  $l =~ s/[^!-~]/"%" . sprintf("%02x", ord($&))/eg;
  return $l;
}

#----- 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;
Commit	Line	Data
961ce1c2	1	# --perl--
961ce1c2	2	#
fef14233	3	# $Id: SWCGI.pm,v 1.2 1999/08/24 12:15:33 mdw Exp $
961ce1c2	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 $
fef14233	31	# Revision 1.2 1999/08/24 12:15:33 mdw
	32	# Properly sanitize CGI arguments (like `gtk+').
	33	#
961ce1c2	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);
fef14233	47	@EXPORT_OK = qw(read sanitize);
961ce1c2	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
fef14233	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
961ce1c2	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;