# -*-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;
