[sw-tools] / perl / SWCGI.pm

# -*-perl-*-
#
# $Id: SWCGI.pm,v 1.3 2004/04/08 01:52:19 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.

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