[sw-tools] / perl / SWCGI.pm

# -*-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;
Commit	Line	Data
961ce1c2	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;