Re: Perl 5 Classes for the Web (CGI and libwww)
Tim Bunce (Tim.Bunce@ig.co.uk)
Tue, 14 Mar 1995 20:29:25 +0000
----------
X-Sun-Data-Type: text
X-Sun-Data-Description: text
X-Sun-Data-Name: text
X-Sun-Content-Lines: 38
> From: James Casey <casey@ptsun00.cern.ch>
>
> In your message of Tue, 14 Mar 1995 17:07:37 GMT, you say:
>
> >The Mini-Server Concept:
>
> >The CGI::MiniSvr class is small and simple. It just overrides a few
> >methods from the CGI::Base class. It does *not* try to be a full
> >server. Anything an application doesn't want to handle can be passed on
> >to a main server with a single method call. The MiniSvr is not a
> >panacea but it does provide an excellent mechanism for some applications.
>
> This sounds great, and just what I need right now... Is it available ???
>
Yes, I think it would be good to bring libwww-perl into the development
process, at least till the first release. The more the merrier right
now. It's important that we at least identify major issues before it's
first full release.
I hope to release this stuff late on Friday with a couple of revisions
to the mailing lists before then.
It's alpha code so expect (and comment on) the rough edges :-)
After the first release anyone on libwww-perl who wants to play an
active role in the development and testing of the CGI code should
join cgi-perl@webstorm.com (via the usual -request address).
(It might be worth merging the lists at some point in the future but
lets see how things work out first.)
I look forward to all your comments.
> james.
>
Regards,
Tim.
----------
X-Sun-Data-Type: default
X-Sun-Data-Name: CGI-various-0.2.shar
X-Sun-Content-Lines: 1556
#!/bin/sh
# This is a shell archive (produced by shar 3.52.3)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 03/14/1995 01:56 UTC by timbo@lion
# Source directory /home/toad/timbo/perl/cgi
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length mode name
# ------ ---------- ------------------------------------------
# 16677 -rw-r--r-- CGI/Base.pm
# 10753 -rw-r--r-- CGI/MiniSvr.pm
# 4227 -rw-r--r-- CGI/Query.pm
# 1358 -rwxr-xr-x testbase.pl
# 3593 -rwxr-xr-x testmini.pl
#
touch -am 1231235999 $$.touch >/dev/null 2>&1
if test ! -f 1231235999 && test -f $$.touch; then
shar_touch=touch
else
shar_touch=:
echo 'WARNING: not restoring timestamps'
fi
rm -f 1231235999 $$.touch
#
# ============= CGI/Base.pm ==============
if test ! -d 'CGI'; then
echo 'x - creating directory CGI'
mkdir 'CGI'
fi
if test -f 'CGI/Base.pm' && test X"$1" != X"-c"; then
echo 'x - skipping CGI/Base.pm (File already exists)'
else
echo 'x - extracting CGI/Base.pm (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'CGI/Base.pm' &&
package CGI::Base;
X
# $Id: Base.pm,v 1.13 1995/03/14 01:53:11 timbo Exp $
X
=head1 NAME
X
CGI::Base - HTTP Daemon Common Gateway Interface (CGI) Base Class
X
X
=head1 SYNOPSIS
X
X use CGI::Base;
X
X $cgi = new CGI::Base;
X
X $cgi->get;
X
X $cgi->SendHeaders();
X
X $cgi->pass_thru($url);
X $cgi->redirect($url);
X
X $cgi->done;
X
X $cgi->exit;
X
X
=head1 DESCRIPTION
X
This file implements a CGI::Base object. This object represents the
I<interface> between the application and an HTTP deamon.
X
In a typical CGI scenario the I<interface> is just a collection of
environment variables. The CGI::Base class imports all CGI environment
variables into perl variables with the same names. These perl variables
are exported to users of the CGI::Base module. The CGI::Base class
will also transparently deal with POST and PUT submissions by reading
STDIN into $QUERY_STRING.
X
The CGI::Base class has been specifically designed to be subclassed to
implement alternative interfaces. For example the CGI::MiniSvr class
implements a 'mini http daemon' which can be spawned from a CGI script
in order to maintain state information for a client 'session'.
X
The CGI::Base class (and classes derived from it) are not designed to
understand the contents of the data they are handling. Only basic data
acquisition tasks and basic metadata parsing are performed by
CGI::Base. The $QUERY_STRING is not parsed.
X
Higher level query processing (parsing of QUERY_STRING and handling of
form fields etc) is performed by the CGI::Query module. Generally CGI
application developers will deal with the CGI::Query class and not the
CGI::Base class.
X
X
=head2 FEATURES
X
Well focused, fine grained object oriented and sub-classable.
X
Extensible attribute system for CGI environment variables.
X
Exporting of CGI environment variables as plain perl variables.
X
Supports pass_thru and redirection of URL's (incomplete)
X
X
=head2 PRINCIPLES and ASSUMPTIONS
X
These basic principles and assumptions apply to CGI::Base and can be
built into any application using CGI::Base. Any subclass of CGI::Base,
such as CGI::MiniSvr must uphold these principles.
X
STDIN, STDOUT are connected to the client, possibly via a server.
X
STDERR can be used for error logging (see open_log method).
X
%ENV should not be used. See ENVIRONMENT section below.
X
X
=head1 ENVIRONMENT
X
The CGI::Base module imports all the CGI/1.1 standard environment
variables into the CGI::Base package namespace as scalars, and in some
cases arrays and/or hashes. See the definition of %CgiEnv and @CgiEnv.
X
Any module which says 'use CGI::Base' has those variables imported
into it's namespace.
X
It is strongly recommended that these variables, and not $ENV{...},
should be used because alternative CGI interfaces, such as
CGI::MiniSvr, may not bother to maintain ENV consistent with the
internal values.
X
X
=head2 FUTURE DEVELOPMENTS
X
None of this is perfect. All suggestions welcome.
X
We need a good URL object class. What's happening with WWW::URL?
X
The header handling is poor - see CGI::MiniSvr for more info.
X
X
=head1 AUTHOR, COPYRIGHT and ACKNOWLEDGEMENTS
X
This code is Copyright (C) Tim Bunce 1995. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
X
This code includes ideas from the work of Steven E. Brenner
<S.E.Brenner@bioc.cam.ac.uk> (cgi-lib), Lincoln Stein
<lstein@genome.wi.mit.edu> (CGI.pm), Pratap Pereira
<pereira@ee.eng.ohio-state.edu> (phttpd) and possibly others.
X
X
=head1 SEE ALSO
X
CGI::MiniSvr, CGI::Query
X
=cut
X
X
use Carp;
use Exporter;
use Socket;
X
@ISA = qw(Exporter);
X
$Revision = '$Revision: 1.13 $';
($Version = $Revision) =~ s/.*(\d+\.\d+).*/$1/;
$LogFile = '';
$Debug = 1;
$TcpProto = (getprotobyname('tcp'))[2];
X
X
# List CGI Environment Variables and attributes
X
%CgiEnv = (
X AUTH_TYPE => { HDR=>'Authorization:' },
X CONTENT_LENGTH => { HDR=>'Content-Length:' },
X CONTENT_TYPE => { HDR=>'Content-Type:', },
X GATEWAY_INTERFACE => { SPLIT => '/' },
X HTTP_ACCEPT => { SPLIT => '\s*,\s*' },
X HTTP_USER_AGENT => {},
X PATH_INFO => {},
X PATH_TRANSLATED => {},
X QUERY_STRING => {},
X REMOTE_ADDR => {},
X REMOTE_HOST => {},
X REMOTE_IDENT => {},
X REMOTE_USER => {},
X REQUEST_METHOD => {},
X SCRIPT_NAME => {},
X SERVER_NAME => {},
X SERVER_PORT => {},
X SERVER_PROTOCOL => { SPLIT => '/' },
X SERVER_SOFTWARE => { SPLIT => '/' },
# Not strictly a CGI env var
X URI => {},
# We don't consider many extra HTTP_* possibilities yet
X HTTP_REFERER => {}
);
@CgiEnv = sort keys %CgiEnv;
X
X
@EXPORT = (
X map {'*'.$_} @CgiEnv, # export all forms of the names
X qw(ContentTypeHdr LocationHdr StatusHdr ServerHdr),
);
X
@EXPORT_OK = qw(
X LogFile
X *CgiEnv
);
X
X
%Request_Method_Dispatch = (
X 'GET' => 'method_GET',
X 'HEAD' => 'method_HEAD',
X 'PUT' => 'method_PUT',
X 'POST' => 'method_POST',
X 'DELETE'=> 'method_DELETE',
X 'LINK' => 'method_LINK',
X 'UNLINK'=> 'method_UNLINK',
X 'other' => 'method_other',
);
X
X
# --- Constructor ---
X
sub new {
X my $self = shift;
X bless { @_ }, $self;
}
X
X
# --- Attributes ---
X
sub port { "" } # see CGI::MiniSvr
X
X
X
# --- Main Interface Function ---
X
sub get {
X my($self, $timeout) = @_;
X my $result;
X
X do {
X
X $self->log("get cgi=$self, timeout=$timeout") if $Debug >= 2;
X
X # get CGI vars into perl vars
X $self->get_vars($timeout) or return undef; # timeout
X
X $self->log_request(); # log a summary of the request
X
X my $meth = $Request_Method_Dispatch{$REQUEST_METHOD}
X || $Request_Method_Dispatch{'other'};
X
X $result = $self->$meth();
X
X } while ($result eq 'NEXT');
X
X $result;
}
X
X
# Handler Methods for REQUEST_METHOD's
#
# These methods can return
# 1 Normal, pass request up to application.
# ERROR An non-fatal error occured.
# NEXT Request has been satisfied without needing to
# pass it up to the application. (Only applicable
# to CGI::MiniSvr or similar dynamic interfaces).
# Get next request.
# 0/undef Fatal error or Timeout (in MiniSvr)
#
# These methods are designed to be overridden in subclasses.
X
sub method_GET { 1 }
sub method_HEAD { 1 }
sub method_PUT { $_[0]->read_entity_body }
sub method_POST { $_[0]->read_entity_body }
sub method_DELETE { 1 }
sub method_LINK { 1 }
sub method_UNLINK { 1 }
sub method_other { 1 }
X
X
sub read_entity_body {
X # use $QUERY_STRING, $CONTENT_LENGTH to grab Entity-Body from STDIN
X my $self = shift;
X my $readlen = read(STDIN, $QUERY_STRING, $CONTENT_LENGTH);
X $QUERY_STRING =~ s/\r?\n/&/g;
X if ($readlen != $CONTENT_LENGTH){
X $self->log("read_entity_body: "
X ."read $readlen bytes, expected $CONTENT_LENGTH");
X return 0; # must be treated as failure
X }
X 1;
}
X
X
sub log_request { # Write summary of request to the log
X my $self = shift;
X $self->log("Request: $REQUEST_METHOD $URI $SERVER_PROTOCOL");
X $self->log("Script: '$SCRIPT_NAME', Query: '$QUERY_STRING'")
X if $Debug;
}
X
X
X
X
# --- CGI Variable Handlers ---
X
sub get_vars { # create new variables with same names as env var
X my($self) = @_; # ignore timeout argument
X
X $self->get_vars_from_env;
X $self->get_vars_by_debug unless $REQUEST_METHOD;
X
X # Create $URI from $SCRIPT_NAME and $QUERY_STRING if appropriate
X # CGI::MiniSvr does inverse.
X $URI = $SCRIPT_NAME;
X $URI.= '?'.$QUERY_STRING if ($QUERY_STRING
X and $REQUEST_METHOD !~ m/^(POST|PUT)$/);
X
X # Temporary workaround HACK for me (badly installed HTTPD I think)
X $SERVER_NAME = 'toad' if $SERVER_NAME eq 'toad.co.uk';
X
X $self->expand_vars unless $self->{'basic_vars'};
X
X 1; # must return success
}
X
X
sub get_vars_from_env { # Import from environment
X my($self, $prefix) = @_;
X $prefix = '' unless $prefix;
X map { ${"$prefix$_"} = $ENV{$_} } @CgiEnv;
}
X
X
sub put_vars {
X # Not recommended, included to allow alternative CGI interfaces
X # to be compatible with old CGI scripts. Not called by default.
X map { $ENV{$_} = ${$_} } @CgiEnv;
}
X
X
sub get_vars_by_debug { # Handy debugging modes
X # Set reasonable defaults for debugging
X # Don't define SERVER_SOFTWARE as indication of test mode
X $SERVER_PROTOCOL = 'HTTP/1.0';
X $SERVER_NAME = 'localhost';
X $SERVER_PORT = 80;
X $REMOTE_ADDR = '127.0.0.1';
X $REMOTE_HOST = 'localhost';
X $SCRIPT_NAME = $0;
X $REQUEST_METHOD = 'GET';
X
X if (@ARGV) { # Debugging off-line via command line args
X $QUERY_STRING = "@ARGV";
X $QUERY_STRING =~ tr/ /&/ if $QUERY_STRING =~ m/=/;
X
X } else { # Debugging off-line via standard input
X my @lines; print "(waiting for HTTP query on standard input)\n";
X chop(@lines = <>); # remove newlines
X $QUERY_STRING = join( ("@lines"=~/=/)?"&":"+" ,@lines);
X }
}
X
X
sub expand_vars { # perform basic parsing of $... into @... and %...
X my $self = shift;
X my($evv, $eva, $tmp); # environment value and attributes
X foreach (@CgiEnv){
X $evv = ${$_}; # get variable value
X $eva = $CgiEnv{$_};
X if ($tmp = $eva->{'SPLIT'}){
X @{$_} = (defined $evv) ? split(/$tmp/, $evv) : ();
X %{$_} = (); # cached as needed
X }
X # others here later maybe
X }
}
X
X
sub dump_vars {
X my $self = shift;
X print "\r\n<HR>\r\n";
X print "<B>CGI Environment Variables:</B> ";
X print "CGI::Base version $Version<PRE>\r\n";
X foreach(sort @CgiEnv){
X printf "%s = %s\r\n", $_, (defined ${$_})? "'${$_}'" : "undefined";
X }
X print "</PRE>\r\n";
X # XXX also output user id and cwd info ?
X print "<HR>\r\n";
}
X
X
X
X
# --- End response to client (does more in CGI::MiniSvr)
X
X
sub done { # mark the completion of a 'page'
X my $self = shift;
X my $dump = shift;
X $self->dump_vars if $dump; # show CGI vars to client
X $self->log("Done.\n");
X # it doesn't make such sense to close STDIN/OUT here
}
X
X
sub spawn { # See CGI::MiniSvr
X my $self = shift;
X $self->log("Can't spawn this interface (use CGI::MiniSvr)");
X 0;
}
X
X
sub exit { # Terminate, and optionally log a message
X my $self = shift;
X $self->log(@_) if @_;
X exit 0;
}
X
X
X
# --- Alternative Response Methods
X
# This function passes a request thru to the main HTTPD and passes
# the response back to the client. Although it's in the CGI::Base
# class it's only currently usable by CGI::MiniSvr.
X
sub pass_thru {
X my($self, $to_uri) = @_;
X my $url = $self->URL::change_port($to_uri,$SERVER_PORT);
X
X $self->log("Forwarding to $SERVER_NAME:$SERVER_PORT") if $Debug;
X
X my $svr_fh = $self->server_link or return 0;
X
X print $svr_fh $self->pass_thru_headers; # overridden in CGI::MiniSvr
X
X # Send QUERY_STRING and ensure everything is flushed out
X select((select($svr_fh), $|=1)[0]);
X print $svr_fh $QUERY_STRING;
X $self->log("Request passed thru, awaiting response on fd".fileno($svr_fh))
X if $Debug >= 2;
X
X print while (<$svr_fh>);
X close($svr_fh) or warn $!;
X $self->log("Pass-thru complete, connection closed") if $Debug;
X 1;
}
X
X
sub server_link {
X my($self, $host, $port) = @_;
X my $port_in;
X $host = $SERVER_NAME || 'localhost' unless $host;
X $port = $SERVER_PORT || 80 unless $port;
X
X my $fh = "CGI::Base::server_link_fh"; # XXX should autogen
X unless (socket($fh, AF_INET, SOCK_STREAM, $TcpProto)){
X $self->log("socket: $!");
X return 0;
X }
X unless ($port_in = $server_link_cache{"$host:$port"}){
X # get and cache connection details for main server
X my $host_in = (gethostbyname($host))[4];
X $port_in = pack('S n a4 x8', AF_INET, $port, $host_in);
X $server_link_cache{"$host:$port"} = $in;
X }
X unless (connect($fh, $port_in)){
X $self->log("connect($host:$port): $!");
X return 0;
X }
X # don't set to non-buffered yet
X $fh;
}
X
X
sub pass_thru_headers {
X my @h; # Construct a plausable set of HTTP headers
X push(@h, "$REQUEST_METHOD $URI $SERVER_PROTOCOL");
X push(@h, map { "Accept: $_" } @HTTP_ACCEPT);
X push(@h, "User-Agent: $HTTP_USER_AGENT");
X join("\r\n", @h, ''); # add blank line
}
X
X
# The alternative to pass_thru (above) is redirecting the HTTPD
# or client via a 3xx status and a Location: and/or URI: headers.
# This does not seem to work for CGI::MiniSvr. I've not tried
# it for CGI::Base.
X
sub redirect {
X my $self = shift;
X my $to_uri = shift;
X $self->log("Redirecting $REQUEST_METHOD $URI to '$to_uri'") if $Debug;
X my $msg = ServerHdr(302,"Moved Temporarily");
X $msg .= LocationHdr($to_uri);
X $self->log($msg);
X print $msg;
}
X
X
=head1 Method: accept
X
Without parameters, returns an array of the MIME types the browser
accepts.
X
With a single parameter equal to a MIME type, will return undef if the
browser won't accept it, 1 if the browser accepts it but doesn't give a
preference, or a floating point value between 0.0 and 1.0 if the
browser declares a quantitative score for it.
X
The parameter can also be a search pattern.
X
This handles MIME type globs correctly.
X
=cut
X
sub accept {
X my($self, $search) = @_;
X
X unless(keys %HTTP_ACCEPT){ # cached already ?
X my($pref, $mxb, $media);
X foreach (@HTTP_ACCEPT) {
X ($media) = m#(\S+/[^;]+)#;
X ($pref) = m/\bq=(\d\.\d+|\d+)/;
X ($mxb) = m/\bmxb=(\d+)/;
X $pref = 1 unless defined $pref;
X $mxb = '' unless defined $mxb;
X $HTTP_ACCEPT{$media} = {
X 'q'=>$pref, 'mxb'=>$mxb
X };
X }
X }
X
X return keys %HTTP_ACCEPT unless $search;
X
X # if a search type is provided, we may need to
X # perform a pattern matching operation.
X # The MIME types use a glob mechanism, which
X # is easily translated into a perl pattern match
X
X # First return the preference for directly supported types:
X return $HTTP_ACCEPT{$search}->{'q'} if $HTTP_ACCEPT{$search};
X
X # Didn't get it, so try pattern matching.
X my $pat;
X foreach (keys %HTTP_ACCEPT) {
X next unless /\*/; # not a pattern match
X $pat =~ s/([^\w*])/\\$1/g; # escape meta characters
X ($pat = $_) =~ s/\*/.*/g; # turn it into a pattern
X return $HTTP_ACCEPT{$_}->{'q'} if $search=~/$pat/;
X }
X 0;
}
X
X
# --- HTTP Translation Methods
X
# THIS BELONGS IN A PROPER URL CLASS
X
sub URL::decode {
X my $self = shift; # allow for future URL class
X my @url = @_;
X # This line gives Perl5.000 core dumping indigestion
X # map { tr/+/ /; s/%(..)/pack("c",hex($1))/ge } @url;
X foreach(@url){
X tr/+/ /;
X s/%(..)/pack("c",hex($1))/ge;
X }
X @url;
}
X
# This is a hack
X
sub URL::change_port {
X my($self, $url, $port) = @_;
X $port = $SERVER_PORT unless $port;
X my $new = "http://$SERVER_NAME:$port$url";
X $self->log("change_port($port) '$url' -> '$new'") if $Debug>=2;
X $new;
}
X
X
X
# --- Logging utility methods
X
sub open_log {
X my($self, $file, $trunc) = @_;
X return close_log() unless $file;
X $trunc = ($trunc) ? '>' : '>>';
X open(STDERR,"$trunc$file") or return $self->log("open($file) $!\n");
X select((select(STDERR), $|=1)[0]);
X print STDERR "\n###### ".×tamp."-$$: CGI::Base $Version\n"
X if $file ne $LogFile;
X $LogFile = $file;
}
X
sub close_log {
X open(STDERR,">/dev/null");
X $LogFile = '';
}
X
sub log {
X return unless $LogFile;
X my $self = shift;
X my $stamp = ×tamp."-$$: ";
X print STDERR $stamp,@_,"\n";
}
X
sub timestamp { # Efficiently generate a time stamp for log files
X package CGI::Base::timestamp; # keep our globals static
X my $time = time; # optimise for many calls in same second
X return $last_str if $time == $last_time;
X ($sec,$min,$hour,$mday,$mon,$year) = localtime($last_time = $time);
X $last_str = sprintf("%02d%02d%02d %02u:%02u:%02u",
X $year,$mon+1,$mday, $hour,$min,$sec);
}
X
sub LogFile { # non-method way to set logfile
X my($file) = @_;
X CGI::Base->open_log($file);
}
X
END { CGI::Base->log("Process TERMINATED") if $Debug }
X
X
# --- (handy but tacky) Functions supporting the output of Headers ---
X
# This all needs reworking. There are major outstanding issues relating
# to who should output headers and when.
X
sub SendHeaders { # e.g., SendHeaders() or SendHeaders(StatusHdr(400));
X my($self, @hdrs) = @_;
X push(@hdrs, ContentTypeHdr()) unless @hdrs;
X print join("", @hdrs);
X $| = 1; # flush the headers out to the client early
X print "\r\n";
X $| = 0;
}
X
# Header constructors:
X
sub ContentTypeHdr {
X "Content-type: ".((@_) ? $_[0] : 'text/html')."\r\n";
}
sub LocationHdr {
X "Location: $_[0]\r\n";
}
sub StatusHdr {
X my($status, $msg) = @_;
X sprintf("Status: %03d %s\r\n", $status, $msg);
}
sub ServerHdr {
X my($status, $msg) = @_;
X $status = 200 unless defined $status;
X unless ($msg){ # XXX lookup standard msgs for $status codes?
X $msg = "No reason text supplied";
X }
X "HTTP/1.0 $status $msg\r\n"
X ."Server: $SERVER_SOFTWARE\r\n";
}
X
X
X
1;
SHAR_EOF
$shar_touch -am 0314015595 'CGI/Base.pm' &&
chmod 0644 'CGI/Base.pm' ||
echo 'restore of CGI/Base.pm failed'
shar_count="`wc -c < 'CGI/Base.pm'`"
test 16677 -eq "$shar_count" ||
echo "CGI/Base.pm: original size 16677, current size $shar_count"
fi
# ============= CGI/MiniSvr.pm ==============
if test -f 'CGI/MiniSvr.pm' && test X"$1" != X"-c"; then
echo 'x - skipping CGI/MiniSvr.pm (File already exists)'
else
echo 'x - extracting CGI/MiniSvr.pm (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'CGI/MiniSvr.pm' &&
package CGI::MiniSvr;
X
# $Id: MiniSvr.pm,v 1.14 1995/03/14 01:53:11 timbo Exp $
X
=head1 NAME
X
CGI::MiniSvr - Adds to CGI::Base the ability to detach
X
X
=head1 SYNOPSIS
X
X use CGI::MiniSvr;
X
X $cgi = new CGI::MiniSvr;
X
X $cgi->get;
X
X $cgi->SendHeaders();
X
X $cgi->pass_thru($url);
X $cgi->redirect($url);
X
X
=head1 DESCRIPTION
X
This file implements the CGI::MiniSvr object. This object represents an
alternative B<interface> between the application and an HTTP deamon.
X
In a typical CGI scenario the I<interface> is just a collection of
environment variables passed to a process which then generated some
outout and exits. The CGI::Base class implements this standard
interface.
X
The CGI::MiniSvr class inherits from CGI::Base and extends it to
implement a 'mini http daemon' which can be spawned (forked) from a CGI
script in order to maintain state information for a client 'session'.
X
This is very useful! It neatly side-steps many of the painful issues
involved in writing real-world multi-screen applications using the
standard CGI interface (namely saving and restoring state between
screens).
X
Like the CGI::Base module the CGI::MiniSvr module does not do any
significant data parsing. Higher level query processing (forms etc) is
performed by the CGI::Query module.
X
X
=head2 FEATURES
X
It works! Proof of concept.
X
Object oriented and sub-classable.
X
Transparent low-level peer validation (no application involvement
but extensible through subclassing).
X
Transparent low-level pass_thru/redirecting of URL's the application
is not interested in (no application involvement but extensible
through subclassing).
X
Effective timeout mechanism with default and per-call settings.
X
Good emulation of standard CGI interface (for code portability).
X
X
=head2 FUTURE DEVELOPMENTS
X
None of this is perfect. All suggestions welcome.
X
More functionality (methods) may migrate down into CGI::Base as the
object model matures.
X
Control over the decision to pass_thru/redirect needs to be thought about
(see do_GET and think about subclassing).
X
Issue/problem - the handling of headers. Who outputs them and when? We
have a sequence of headers, body, end, read, headers, body, end, read
etc. A good solution will probably have to wait till we have better
tools for writing HTML and we get away from pages of print statements.
X
A method for setting PATH_INFO and PATH_TRANSLATED to meaningful values
is needed.
X
X
=head1 COPYRIGHT and ACKNOWLEDGEMENTS
X
This code is Copyright (C) Tim Bunce 1995. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
X
This module includes ideas from Pratap Pereira
<pereira@ee.eng.ohio-state.edu> and others.
X
=cut
X
use Carp;
use Socket;
use Exporter;
X
use sigtrap; # handy while debugging
X
use CGI::Base qw(:DEFAULT *CgiEnv);
X
@ISA = qw(CGI::Base);
$Exporter::Verbose = 1;
@EXPORT = (
X map {"*ORIG_$_"} @CgiEnv
);
X
X
$Revision = '$Revision: 1.14 $';
($Version = $Revision) =~ s/.*(\d+\.\d+).*/$1/;
$Debug = 1;
X
X
$PortBase = 10000; # lowest port number to use
$PortSearch = 500; # range to search over
X
# Define Timeouts (in fractional minutes)
$DefaultTimeout = 1; # timeout for accept() in get() [LOW WHILE DEBUGGING]
$MinTimeout = 1;
$MaxTimeout = 60 * 2;
X
# Copies of HTTPD CGI values taken when MiniSvr created
$Script_Name = undef;
X
X
X
sub new {
X my($self, $fh) = @_;
X
X # get a CGI::Base object
X my $cgi = new CGI::Base;
X
X # force immediate processing of environment from HTTPD
X # XXX (maybe this should just be a get_vars)
X $cgi->get;
X
X # Take a copy of the original values
X $cgi->get_vars_from_env('CGI::MiniSvr::ORIG_');
X
X $Script_Name = $SCRIPT_NAME; # to prevent pass_thru loops!
X
X # Create a socket for this MiniSvr instance to use.
X
X my $minisvrsocket = "${self}::SVR";
X socket($minisvrsocket, AF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2])
X or confess $!;
X
X # Generate random port number and search till we find a free one.
X # This scheme works quite well unless you have an _average_ of more
X # than 32 incoming connections per second :-)
X my $max_search = $PortSearch;
X my $minisvrport= $PortBase + (time & 0xFF)*32; # range of 8192 ports
X my $this;
X do {
X ++$minisvrport;
X if (--$max_search <= 0){
X close($minisvrsocket);
X $cgi->log("Unable to find a free port");
X return undef;
X }
X $this = pack('S n C4 x8', AF_INET, ++$minisvrport, 0,0,0,0);
X
X # note that leave SERVER_PORT unchanged (typically 80)
X
X } until bind($minisvrsocket, $this);
X
X listen($minisvrsocket, 5) or confess $!;
X
X $cgi->{'timeout'} = $DefaultTimeout;
X $cgi->{'socket'} = $minisvrsocket;
X $cgi->{'port'} = $minisvrport;
X
X bless $cgi, $self; # re-bless from CGI::Base
}
X
X
sub port { ":$_[0]->{'port'}" }
X
X
sub spawn {
X my $self = shift;
X $self->log("Spawning detached miniserver");
X $self->_close;
X my($pid, $tries);
X while ( ($pid = fork) < 0 ){
X $self->end("fork failed") if ++$tries > 10;
X $self->log("spawn: fork $!");
X sleep 1;
X }
X sleep 1 unless $pid; # give parent a head start
X $pid;
}
X
X
sub DESTROY {
X my $self = shift;
X my $class = ref $self;
X close($$cgi->{'socket'});
X $self->log("$class TERMINATING");
}
X
X
# --- This code implements the mini server
X
X
sub accept_timeout {
X # print STDERR "get: SIG@_\n";
}
X
X
sub connect {
X my($self, $timeout) = @_;
X my $peer;
X my $minisvrsocket = $self->{'socket'};
X $self->log("Awaiting connection on port $self->{'port'} "
X ."($timeout minute timeout) ...") if $Debug;
X
X local($SIG{'ALRM'}) = \&accept_timeout; # local for auto reset
X alarm($timeout * 60);
X $peer = accept(CLIENT, $minisvrsocket); # Block waiting for client
X alarm(0);
X
X unless ($peer){
X my $err = "accept() failed: $!";
X $err = 'Timeout' if $err =~ m/Interrupted/i;
X $self->log($err);
X return undef;
X }
X open(STDIN ,"<&".fileno(CLIENT)) or confess $!;
X open(STDOUT,">&".fileno(CLIENT)) or confess $!;
X close(CLIENT) or confess $!;
X $peer;
}
X
X
sub validate_peer {
X # protocol level check only, application checks are separate
X my($self, $peer, $dotquad, $hostname) = @_;
X
X return 1 if ( $dotquad eq $REMOTE_ADDR
X and $hostname eq $REMOTE_HOST);
X
X $self->log("validate_peer: $hostname ($dotquad) REFUSED,"
X ." expecting $REMOTE_HOST ($REMOTE_ADDR)");
X print ServerHdr();
X print StatusHdr(403, "Forbidden (not expected client)");
X $self->done;
X 0;
}
X
X
X
sub get_vars {
X my($self) = @_;
X my($peer, $dotquad, $hostname);
X
X $timeout = $self->{'timeout'} unless $timeout;
X $timeout = $MinTimeout if $timeout < $MinTimeout;
X $timeout = $MaxTimeout if $timeout > $MaxTimeout;
X
X $SERVER_SOFTWARE = "CGIMINISVR/$Version";
X $GATEWAY_INTERFACE = 'CGI/1.1';
X
NEXT_CONNECT:
X
X do {
X $peer = $self->connect($timeout) or return undef;
X
X my ($family, $port, @addr) = unpack("S n C4 x8", $peer);
X $dotquad = join('.', @addr);
X $hostname = (gethostbyaddr(pack("C4",@addr), AF_INET))[0];
X $hostname = $hostname unless $hostname;
X
X $self->log("Connection from $hostname ($dotquad:$port)");
X
X } until $self->validate_peer($peer, $dotquad, $hostname);
X
X print ServerHdr();
X
X $_ = <>; # read first line
X
X ($REQUEST_METHOD, $URI, $SERVER_PROTOCOL) = split;
X $SERVER_PROTOCOL = "HTTP/0.9" unless $SERVER_PROTOCOL;
X
X ($SCRIPT_NAME, $QUERY_STRING) = split(/\?/, $URI, 2);
X $QUERY_STRING = '' unless $QUERY_STRING;
X
X $self->get_vars_by_debug unless $REQUEST_METHOD;
X
X # Do we need $PATH_INFO and $PATH_TRANSLATED ?
X # Or just leave them untouched from original CGI values?
X
X @HTTP_ACCEPT = ();
X @HEADERS = ($_);
X
X my($key, $val, $last_key);
X while (<>) {
X push(@HEADERS, $_); # record for possible redirection
X s/\s+$//; # remove trailing whitespace
X last if $_ eq ''; # end of headers
X if (s/^\s+//){ # continuation line ?
X # Umm, what to do about this ?
X $self->log("Continuation line for '$last_key' skipped!");
X next;
X }
X # $self->log("read '$_'") if $Debug;
X # XXX handle split header lines
X ($key, $val) = m/^(.*?:)\s*(.*)/;
X if ($key eq 'Accept:'){
X push(@HTTP_ACCEPT, $val);
X } elsif ($key eq 'User-Agent:'){
X $HTTP_USER_AGENT = $val;
X } elsif ($key eq 'Referer:'){
X $HTTP_REFERER = $val;
X } else {
X $self->{$key} = $val;
X # $self->log("Attrib '$key' = '$val' not known") if $Debug;
X }
X $last_key = $key;
X }
X
=head1 Message Headers
X
Convert to HTTP_* variables ?
Accumulate repeats into array ?
Deal with split lines!
How to deal with non-'standard' case (upper/lower/mixed etc) ?
Note that HTTPD CGI will pass them as $ENV{'HTTP_*'} (uppercased name)
X
X General-Header = Date
X | Forwarded
X | Message-ID
X | MIME-Version
X | extension-header
X Request-Header = Accept
X | Accept-Charset
X | Accept-Encoding
X | Accept-Language
X | Authorization
X | From
X | If-Modified-Since
X | Pragma
X | Referer
X | User-Agent
X | extension-header
X Entity-Header = Allow
X | Content-Encoding
X | Content-Language
X | Content-Length
X | Content-Transfer-Encoding
X | Content-Type
X | Derived-From
X | Expires
X | Last-Modified
X | Link
X | Location
X | Title
X | URI-header
X | Version
X | extension-header
=cut
X $HTTP_ACCEPT = join(', ',@HTTP_ACCEPT);
X
X # Set CGI vars from headers (e.g., $CONTENT_LENGTH from 'Content-Length:')
X foreach (@CgiEnv){
X my $eva = $CgiEnv{$_};
X next unless $hdr = $eva->{'HDR'} and $self->{$hdr};
X ${$_} = $self->{$hdr};
X }
X
X $self->expand_vars unless $self->{'basic_vars'};
X
X 1;
}
X
X
X
sub done {
X my $self = shift;
X $self->CGI::Base::done(@_);
X $self->_close;
}
X
sub _close { # disconnect from client
X # safer to open to /dev/null than to close STDIN/OUT
X open(STDIN, "</dev/null");
X open(STDOUT,">/dev/null");
}
X
X
sub pass_thru_headers {
X @HEADERS;
}
X
X
# --- Handler Methods for REQUEST_METHOD's ---
#
# These methods can return 0 to indicate that the request has been
# satisfied without needing to pass it up to the application.
#
# We need to decide to handle the query ourselves or pass_thru it.
# If is _vital_ that we don't pass_thru a URI which would cause
# the HTTPD to launch this same application again!
X
sub method_GET {
X my $self = shift;
X # These tests will always tend to be application specific.
# if ($QUERY_STRING eq '' and $URI !~ m/\Q$Script_Name/){ # not a good test
# This is too risky here, we may be pass_thru things we want to process
# ourselves. We can always call $self->pass_thru($URI) from 'higher-up'.
X if ($SCRIPT_NAME =~ m/\.(gif|html|jpg)$/){ # just as an example for now
X $self->pass_thru($URI);
X $self->done;
X return 'NEXT';
X }
X 1;
}
X
X
X
1;
X
SHAR_EOF
$shar_touch -am 0314015595 'CGI/MiniSvr.pm' &&
chmod 0644 'CGI/MiniSvr.pm' ||
echo 'restore of CGI/MiniSvr.pm failed'
shar_count="`wc -c < 'CGI/MiniSvr.pm'`"
test 10753 -eq "$shar_count" ||
echo "CGI/MiniSvr.pm: original size 10753, current size $shar_count"
fi
# ============= CGI/Query.pm ==============
if test -f 'CGI/Query.pm' && test X"$1" != X"-c"; then
echo 'x - skipping CGI/Query.pm (File already exists)'
else
echo 'x - extracting CGI/Query.pm (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'CGI/Query.pm' &&
package CGI::Query;
X
# $Id: Query.pm,v 1.13 1995/03/14 01:56:25 timbo Exp timbo $
X
=head1 NAME
X
CGI::Query - Parse queries returned by a CGI interface
X
X
=head1 SYNOPSIS
X
X use CGI::Query;
X
X $query = new CGI::Query;
X
X print $query->param('FieldName');
X @selected = $query->param('SelectMultiField');
X
X # import form field names as perl variables!
X $query->import_names('main'); # specify package
X
X print $FieldName;
X print @SelectMultiField;
X
X
=head1 DESCRIPTION
X
This file implements the CGI::Query object. This object represents a
query/request/submission from a WWW user. The object understands the
concept of HTML forms and fields.
X
A CGI::Query object contains a reference to a CGI::Base object
(or an object derived from CGI::Base). It uses the services of
that object to get the basic data of the query.
X
Note that CGI::Query does not inherit from CGI::Base it just uses
an instance of a CGI::Base object.
X
=head2 FEATURES
X
Is object oriented and sub-classable.
X
Integrates with CGI::MiniSvr.
X
Can export form field names are normal perl variables.
X
X
=head1 FUTURE DEVELOPMENTS
X
None of this is perfect. All suggestions welcome.
X
Note that this module is *not* the place to put code which generates
HTML. We'll need separate modules for that.
X
X
=head1 COPYRIGHT and ACKNOWLEDGEMENTS
X
This code is Copyright (C) Tim Bunce 1995. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
X
=cut
X
use Carp;
use Exporter;
X
use CGI::Base; # share 'global' CGI variables
X
@ISA = qw(Exporter);
@EXPORT = qw(GetQuery);
X
$Revision = '$Revision: 1.13 $';
($Version = $Revision) =~ s/.*(\d+\.\d+).*/$1/;
$Debug = 1;
X
$DefaultInterface = undef;
$DefaultPackage = 'Q';
X
X
X
# GetQuery is the main entry point for simple applications
# It combines interface selection, query processing and
# importing of the resulting values
X
sub GetQuery {
X my($pkg, $timeout) = @_;
X my $cgi = Interface();
X my $query = CGI::Query->new($cgi, $timeout||0) || return undef;
X $query->import_names($pkg || $DefaultPackage);
X $query;
}
X
X
sub Interface { # get or set default interface
X if (@_) {
X $DefaultInterface = shift;
X } elsif (!$DefaultInterface) {
X $DefaultInterface = new CGI::Base;
X }
X return $DefaultInterface;
}
X
X
X
sub new {
X my($self, $cgi, $timeout) = @_;
X my %in;
X
X $timeout = 0 unless $timeout; # avoid warnings
X $cgi = Interface() unless $cgi; # default to CGI::Base
X
X # Read a query into the standard variables and perform basic
X # parsing of the metadata (but not the QUERY_STRING):
X $cgi->get(1, $timeout) or return undef; # timeout
X
X my $query = bless \%in, $self;
X
X $query->cgi($cgi); # stash CGI interface ref into query object
X
X $query->extract_values;
X
X $query;
}
X
X
sub extract_values {
X my($self) = @_;
X my $cgi = $self->cgi;
X
X my($tmp) = URL->decode($QUERY_STRING);
X @QUERY_STRING = split(/&/, $tmp);
X
X my($key, $val);
X foreach (@QUERY_STRING) { # Extract into key and value.
X ($key, $val) = split(/=/, $_, 2);
X $val = '' unless defined $val;
X
X $cgi->log("extract_values '$key' = '$val'") if $Debug;
X
X # store as a list of values
X push(@{$self->{$key} || ($self->{$key}=[])}, $val);
X }
X
}
X
X
=head1 Method: param
X
X Returns the value(s) of a named parameter.
X If invoked in a list context, returns the entire list.
X Otherwise returns the first member of the list.
X
X If more than one argument is provided, the second and subsequent
X arguments are used to set the value of the parameter.
X
=cut
X
sub param {
X my($self, $name, @values) = @_;
X $self->{$name} = [@value] if @values;
X my $va = $self->{$name};
X return $va->[0] unless wantarray;
X @$va;
}
X
X
# Convert all named form values into perl variables
# in the callers package
X
sub import_names {
X my($self, $pkg) = @_;
X $pkg = $DefaultPackage unless $pkg;
X my($key, $val, $ref);
X while( ($key, $val) = each %$self ){
X $ref = ref $val;
X if ($ref and $ref eq 'ARRAY'){
X $key =~ s/^-//;
X @{"${pkg}::$key"} = @$val;
X } else {
X ${"${pkg}::$key"} = $val;
X }
X }
}
X
X
sub cgi { # Handy method for $query->cgi->method(...)
X $DefaultInterface;
}
X
X
X
1;
SHAR_EOF
$shar_touch -am 0314015595 'CGI/Query.pm' &&
chmod 0644 'CGI/Query.pm' ||
echo 'restore of CGI/Query.pm failed'
shar_count="`wc -c < 'CGI/Query.pm'`"
test 4227 -eq "$shar_count" ||
echo "CGI/Query.pm: original size 4227, current size $shar_count"
fi
# ============= testbase.pl ==============
if test -f 'testbase.pl' && test X"$1" != X"-c"; then
echo 'x - skipping testbase.pl (File already exists)'
else
echo 'x - extracting testbase.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'testbase.pl' &&
#!/usr/local/bin/perl -w
X
# $Id: testbase.pl,v 1.5 1995/03/13 22:54:56 timbo Exp $
X
BEGIN {
X chdir "/home/timbo/perl/cgi" || die "chdir";
X unshift @INC, '.';
}
X
use CGI::Base;
use CGI::Query;
X
@Q::options = ();
X
CGI::Base::LogFile('cgi.log'); # set default log file
my $q = GetQuery('Q');
X
print "Content-type: text/html\r\n\r\n";
X
print "<HEAD><TITLE>$0 test ".`pwd; date`."</TITLE></HEAD>\r\n";
print "<BODY>\r\n";
X
unless ($QUERY_STRING){ # No query yet so just show the form...
X
X print <<END;
X <FORM method=POST action="$SCRIPT_NAME">
X <H2>Here's a simple form:</H2>
X
X To: <INPUT NAME="to"><P>
X Class: <SELECT NAME="class">
X <OPTION>First Class <OPTION>Second Class
X </SELECT><P>
X Options: <SELECT MULTIPLE NAME="options">
X <OPTION>Recorded Delivery
X <OPTION SELECTED>Pizza Delivery
X <OPTION>Insurance
X </SELECT><P>
X <TEXTAREA NAME="comments" ROWS=10 COLS=50></TEXTAREA><P>
X <INPUT TYPE="submit" VALUE="Send message">
X <INPUT TYPE="reset" VALUE="Erase message"><p>
X </Form>
X </BODY>
END
X # $q->cgi->dump_vars; # append CGI variables to the form
X exit 0;
}
X
X
# Note the use of 'natural' perl variable names here:
X
# $q->import_names('ucfirst');
X
print <<END;
<HR>
X $Q::class to: $Q::to <P>
X Options: @Q::options <P>
X Message: $Q::comments
<HR>
END
X
$q->cgi->dump_vars; # append CGI variables to the form
X
X
print "</BODY>\r\n";
SHAR_EOF
$shar_touch -am 0314015595 'testbase.pl' &&
chmod 0755 'testbase.pl' ||
echo 'restore of testbase.pl failed'
shar_count="`wc -c < 'testbase.pl'`"
test 1358 -eq "$shar_count" ||
echo "testbase.pl: original size 1358, current size $shar_count"
fi
# ============= testmini.pl ==============
if test -f 'testmini.pl' && test X"$1" != X"-c"; then
echo 'x - skipping testmini.pl (File already exists)'
else
echo 'x - extracting testmini.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'testmini.pl' &&
#!/usr/local/bin/perl -w
X
# $Id: testmini.pl,v 1.7 1995/03/14 01:53:11 timbo Exp $
X
BEGIN {
X open(STDERR, ">>&STDOUT");
X chdir "/home/timbo/perl/cgi" || die "chdir $!";
X unshift @INC, ".";
}
X
use CGI::Base;
use CGI::MiniSvr;
use CGI::Query;
X
X
CGI::Base::LogFile("cgi.log");
$q = GetQuery(); # fetch initial query from default interface (CGI::Base)
X
$q->cgi->SendHeaders();
X
$cgi = new CGI::MiniSvr;# were going to switch to CGI::MiniSvr later
$port = $cgi->port; # get our port number (as ':NNNN') for use in URL's
$me = "http://$SERVER_NAME$port$SCRIPT_NAME";
X
print "\n<HEAD><TITLE>CGI.pm test ".`pwd; date`."</TITLE></HEAD>\n";
X
print <<END;
<BODY>
<P>CGI mini-server starting on $SERVER_NAME$port.<P>
<A HREF="$me?INSIDE"> Step Inside ...</A>
</BODY>
END
X
$cgi->done(1);
X
$cgi->exit('Aborted - test mode (not running under HTTPD')
X unless $SERVER_SOFTWARE;
X
X
# --- Detach from HTTPD by forking child process and terminating the parent
X
$cgi->spawn and exit 0;
X
X
# --- Now running in child
X
# Tell CGI::Query to use our chosen interface by default. This just avoids
# the need to pass CGI::Query the reference each time.
X
CGI::Query::Interface($cgi);
X
X
# get results from previous prompt
X
$query = GetQuery() or $cgi->exit;
X
# Here's a trivial example of the sort of linear coding which
# you just can't do without the miniserver concept.
# Eventually we'll have constructors for compostite widgets
# and named forms in event loops
my $string1 = string_prompt($cgi, 'Example prompt 1', 'default text');
my $string2 = string_prompt($cgi, 'Example prompt 2', $string1);
X
X
while (1) {
X
X $cgi->SendHeaders();
X
X print "\n<HEAD><TITLE>CGI MiniSvr $$ ".`date`." $SCRIPT_NAME</TITLE></HEAD>\n";
X
X print <<END;
X <BODY>
X <ISINDEX>
X <A HREF="$me" > TEST1 </A> /
X <A HREF="$me?TEST2"> TEST2 </A> /
X <A HREF="$me/TEST3"> TEST3 </A> /
X <A HREF="$me?QUIT" > QUIT </A> /
X <A HREF="http://$SERVER_NAME$ORIG_SCRIPT_NAME" > START NEW MiniSvr </A>
X <P>Images: <IMG SRC="http://$SERVER_NAME:80/gifs/misc/Warning.gif"> Served direct from httpd
X <IMG SRC="http:/gifs/misc/Warning.gif"> Served via CGI::MiniSvr pass-thru!
X
X <FORM ACTION="$SCRIPT_NAME/FORM">
X String: <INPUT NAME="string">
X Number: <INPUT NAME="number" SIZE=5> <P>
X Pick <INPUT TYPE="radio" NAME="radio" VALUE="A" CHECKED> A or
X <INPUT TYPE="radio" NAME="radio" VALUE="B"> B <P>
X Option: <SELECT NAME="option"> <OPTION>One <OPTION>Two </SELECT>
X <INPUT TYPE="submit" VALUE="Submit">
X <INPUT TYPE="reset" VALUE="Reset">.
X
X </FORM>
X
END
X if ($SCRIPT_NAME =~ m:/FORM$:){
X print "<HR><H2>You selected:</H2><P><PRE>
String: $Q::string, Number: $Q::number, $Q::radio, $Q::option
</PRE>
"
X }
X
X $cgi->done(1);
X
X $query = GetQuery('Q') or $cgi->exit; # new query or timeout
X
X $cgi->log("$0: SCRIPT_NAME $SCRIPT_NAME, QUERY_STRING $QUERY_STRING, URI $URI");
X
X # user asked to quit [NOT WORKING CURRENTLY]
X if ($QUERY_STRING =~ /QUIT$/){
X # redirect to somewhere else
X $cgi->redirect('/');
X # $cgi->SendHeaders(ServerHdr(), LocationHdr("/"));
X $cgi->done;
X last;
X }
X
}
X
$cgi->exit;
X
X
# Self-contained dialogue function (currently very primitive)
X
sub string_prompt {
X my($cgi, $prompt, $default) = @_;
X $default = '' unless defined $default;
X
X $cgi->SendHeaders();
print <<END;
<HEAD><TITLE>Example simple prompt</TITLE></HEAD><FORM>
X $prompt: <INPUT NAME="string_prompt" TYPE=TEXT VALUE="$default">
X </FORM>
END
X $cgi->done(1);
X my $query = new CGI::Query or $cgi->exit; # new query or timeout
X $query->{'string_prompt'};
}
SHAR_EOF
$shar_touch -am 0314015595 'testmini.pl' &&
chmod 0755 'testmini.pl' ||
echo 'restore of testmini.pl failed'
shar_count="`wc -c < 'testmini.pl'`"
test 3593 -eq "$shar_count" ||
echo "testmini.pl: original size 3593, current size $shar_count"
fi
exit 0