#!/usr/local/bin/perl

# CGI::Response
# Marc Hedlund <hedlund@best.com>

# Documentation for CGI::Response is provided at the bottom of
# this file in pod format.  Type 'perldoc Response.pm' while in
# the same directory as this file to view the docs in manpage format.

package CGI::Response;

# use strict;

use Carp;
use Exporter;
use SelfLoader;

@ISA         = qw( Exporter );
@EXPORT_OK   = qw( ContentType NoCache NoContent Redirect RetryAfter );
%EXPORT_TAGS = ( Simple => 
		[ qw( ContentType NoCache NoContent Redirect RetryAfter ) ]
	       );

$CGI::Response::VERSION = '0.03';
$CGI::Response::eol     = "\n";

### Simple Interface

sub ContentType {
  $| = 1;
  "Content-Type: " .
    ( (@_) ? ($_[0]) : 'text/html' ) .
      ("$eol" x 2);
}

sub Redirect {
  croak ("Redirect requested but destination URL not specified")
    unless $_[0];
  $| = 1;
  "Status: " . 
    ( $_[1] ? '301 Moved Permanently' : '302 Moved Temporarily' ) . "$eol" .
	"Content-Type: text/html$eol" .
	  "Location: $_[0]" . "$eol" .
	    "URI: <$_[0]>" . ("$eol" x 2) . <<"END";
<html><head><title>This Resource Has Moved</title></head>
<body><h1>This Resource Has Moved</h1><hr>
<p>This resource has moved to 
<a href="$_[0]">\&lt;URL:$_[0]\&gt;</a>.
</p></body></html>
END
}

sub NoCache {
  $| = 1;
  "Pragma: no-cache" . "$eol" .
    "Content-Type: " . ( @_ ? $_[0] : 'text/html' ) . "$eol" .
      "Expires: " . &_date_string . ("$eol" x 2);
}

sub NoContent {
  $| = 1;
  "Status: 204 No Content" . ("$eol" x 2);
}

# sub RetryAfter {
#   $| = 1;
#   "Retry-After: " . &_date_string( @_ ? $_[0] : '300' ) . 
#     "$eol" .
#       "Status: 503 Service Unavailable" . ("$eol" x 2);
# }

### Subroutine declarations for SelfLoader
#   Generated by Devel::SelfStubber

sub CGI::Response::new;
sub CGI::Response::status;
sub CGI::Response::date;
sub CGI::Response::forwarded;
sub CGI::Response::mime_version;
sub CGI::Response::pragma;
sub CGI::Response::location;
sub CGI::Response::public;
sub CGI::Response::retry_after;
sub CGI::Response::server;
sub CGI::Response::www_authenticate;
sub CGI::Response::allow;
sub CGI::Response::content_encoding;
sub CGI::Response::content_language;
sub CGI::Response::content_transfer_encoding;
sub CGI::Response::content_type;
sub CGI::Response::expires;
sub CGI::Response::link;
sub CGI::Response::uri;
sub CGI::Response::as_string;
sub CGI::Response::Interface;
sub CGI::Response::cgi;
sub CGI::Response::_one;
sub CGI::Response::_many;
sub CGI::Response::_date_string;
sub CGI::Response::_my_uri;
sub CGI::Response::_no_default;

1;

__DATA__

#   SelfLoading begins here.

### Full Interface

sub new {
  require HTTP::Headers;
  
  my( $class ) = shift;
  my $self = {};
  bless $self;
  $self->{'_header'} = new HTTP::Headers;
  
  my( $status )  = ( shift || '' );
  return $self unless $status;
  my( $message ) = ( shift || '' );
  $self->status("$status", "$message");
  $self;
}

sub status {
  require HTTP::Status;

  my( $self )    = shift;
  my( $status )  = ( shift || '' );
  unless ("$status") {
    return ( $self->{'_header'}->header('Status') || '200 OK' );
  }
  my( $message ) = ( shift || '' );
  unless ("$message") {
    $message = HTTP::Status::statusMessage("$status");
  }
  $self->_one( 'Status' => "$status $message" );
}

# General Headers

sub date {
  my( $self ) = shift;
  my( $date ) = &_date_string;
  $self->_one( 'Date' => "$date" );
}

sub forwarded {
  my( $self ) = shift;
  my( $value ) = ( shift || 
		  ( 'by ' . $self->_my_uri .
		   ' for ' . 
		   ( $ENV{"REMOTE_HOST"} ||
		    '[host unknown]' ) ) );
  $self->_many( 'Forwarded' => "$value" );
}

sub mime_version {
  my( $self ) = shift;
  my( $value ) = ( shift || '1.0');
  $self->_one( 'MIME-Version' => "$value" );
}

sub pragma {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Pragma' => 'no-cache, max-age=[seconds]');
  }
  $self->_many( 'Pragma' => "$value" );
}

# Response Headers

sub location {
  my( $self ) = shift;
  my( $value ) = ( shift || $self->_my_uri );
  $self->_one( 'Location' => "$value" );
}

sub public {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Public' => 'OPTIONS, MGET, MHEAD');
  }
  $self->_many( 'Public' => "$value" );
}

sub retry_after {
  my( $self ) = shift;
  my( $delta ) = ( shift || '300');
  my( $value ) = &_date_string("$delta");
  $self->_one( 'Retry-After' => "$value" );
}

sub server {
  my( $self )   = shift;
  my( $value ) = ( shift || 
		  $ENV{"SERVER_SOFTWARE"} ||
		  ('CGI-Response/' . "$VERSION") );
  $self->_one( 'Server' => "$value" );
}

sub www_authenticate {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('WWW-Authenticate' => 'Basic [realm]');
  }
  $self->_one( 'WWW-Authenticate' => "$value" );
}

# Entity Headers

sub allow {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Allow' => 'GET, HEAD, PUT');
  }
  $self->_many( 'Allow' => "$value" );
}

sub content_encoding {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Content-Encoding' => 'gzip');
  }
  $self->_many( 'Content-Encoding' => "$value" );
}

sub content_language {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Content-Language' => 'en, dk, mi');
  }
  $self->_many( 'Content-Language' => "$value" );
}

# sub content_length {
# 	my( $self ) = shift;
# 	my( $ ) = ( shift || '');
# 	$self->_one( '' => "$" );
# }

sub content_transfer_encoding {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Content-Transfer-Encoding' =>
		       'quoted-printable');
  }
  $self->_one( 'Content-Transfer-Encoding' => "$value" );
}

sub content_type {
  my( $self ) = shift;
  my( $value ) = ( shift || 'text/html');
  $self->_one( 'Content-Type' => "$value" );
}

sub expires {
  my( $self )  = shift;
  my( $delta ) = ( shift || '0' );
  my( $value ) = &_date_string("$delta");
  $self->_one( 'Expires' => "$value" );
}

# sub last_modified {
# 	my( $self ) = shift;
# 	my( $ ) = ( shift || '');
# 	$self->_one( '' => "$" );
# }

sub link {
  my( $self ) = shift;
  my( $value ) = ( shift || '');
  unless ("$value") {
    $self->_no_default('Link', '<mailto:timbl@w3.org>; rev="Made"');
  }
  $self->_many( 'Link' => "$value" );
}

# sub title {
# 	my( $self ) = shift;
# 	my( $title ) = ( shift || '');
# 	unless ("$title") {
# 		$self->_no_default('Title', 'My Home Page');
# 	}
# 	my( $getit ) = ( shift || '' );
# 	if ("$getit") {
# 		my( @contents, $contents, $title );
# 		open(FILE, "$file") ||
# 			croak "Couldn\'t open $file to get its title:\n$!\n";
# 		@contents = <FILE>;
# 		close(FILE);
# 		
# 		$contents = join('', @contents);
# 		$contents =~ /<title>([^<]*)<\/title>/im ||
# 			croak "Couldn\'t find a title in $file:\n$!\n";
# 		$title = "$1";
# 		$title =~ s/\n//g;
# 	}
# 	$self->_one( 'Title' => "$title" );
# }

sub uri {
  my( $self ) = shift;
  my( $value ) = ( shift || 
		  '<' . $self->_my_uri . '>' );
  $self->_many( 'URI' => "$value" );
}

# Header Output

sub as_string {
  my( $self )     = shift;
  my( $nph )      = ( shift || '' );
  my( $response ) = '';
  if ("$nph") {
    my( $status ) = '';
    $status = ( $self->{'_header'}->header('Status') || '200 OK' );
    $response = "HTTP/$http_version " . "$status" . "$eol";
    $self->{'_header'}->removeHeader('Status');
    $response .= $self->{'_header'}->asString("$eol");
    $self->_one( 'Status' => "$status" ) unless ( $status =~ /^200/ );
  } else {
    $response = $self->{'_header'}->asString("$eol");
  }
  $response .= "$eol";
  $response;
}

# sub as_hash {
# 
# }

### Utilites

sub Env {
  my( $cgi ) = Interface();
  $cgi->get_vars_from_env;
  $self->cgi($cgi);
}

sub Interface {
  use CGI::Base;

  if (!$DefaultInterface) {
    $DefaultInterface = new CGI::Base;
  }
  return $DefaultInterface;
}

sub cgi {
  $DefaultInterface;
}

### Private Methods

sub _one {
  my( $self, $header, $value ) = @_;
  $self->{'_header'}->header( "$header" => "$value" );
}

sub _many {
  my( $self, $header, $value ) = @_;
  $self->{'_header'}->pushHeader( "$header" => "$value" );
}

sub _date_string {
  use HTTP::Date;

  my( $delta ) = ( shift || '0' );
  my( $value );
  if ( $delta =~ /^\d+$/ ) {
    $value = time2str( time + $delta );
  } else {
    $value = "$delta";
  }
  return "$value";
}

sub _my_uri {
  my( $self ) = shift;
  my( $uri );
  if ( $ENV{'HTTP_ORIG_URI'} ) {
    $uri = $ENV{'HTTP_ORIG_URI'};
  } elsif ( $ENV{'SERVER_NAME'} ) {
    $uri = 	'http://'.$ENV{'SERVER_NAME'};
    if ( $ENV{'SERVER_PORT'} != (80|0) ) {
      $uri .= ':'.$ENV{'SERVER_PORT'};
    }
    $uri .= $ENV{'SCRIPT_NAME'};
    if ( $ENV{'QUERY_STRING'} ) {
      $uri .= '?'.$ENV{'QUERY_STRING'};
    }
  } else {
    $uri = '[URI unknown]';
  }
  return $uri;
}

sub _no_default {
  use Carp;
  my( $self )   = shift;
  my( $header ) = shift;
  my( $values ) = shift;
  my( $method ) = $header;
  $method =~ tr/[A-Z]-/[a-z]_/;
  croak("CGI::Response::$method() must be called with a value;\n" .
	"no default value is provided for it.\n" .
	"Legal values for $header include: $values.\n" . 
	"See the HTTP/$http_version specification, section 8, " .
	"for more information.\n" .
	"$header was added to your header without a value:\n"
	# croak will now insert location of error, "at..."
       );
}

__END__

=head1 NAME

B<CGI::Response> - Respond to CGI requests

=head1 SYNOPSIS

=head2 Simple Interface

  use CGI::Response qw(:Simple);
  print ContentType;
  print "<html><head>\n"; # .....

=head2 Full Interface

  use CGI::Response;
  $response = new CGI::Response;
  $response->content_type;
  print $response->as_string;
  print "<html><head>\n"; # .....

=head1 DESCRIPTION

B<CGI::Response> is a Perl5 module for constructing responses to Common
Gateway Interface (CGI) requests.  It is designed to be light-weight
and efficient for the most common tasks, and also to provide access to
all HTTP response features for more advanced CGI applications.

There are two ways to use CGI::Response.  For basic applications, the
B<Simple Interface> provides a number of plain functions that cover the
most commonly-used CGI response headers.  More advanced applications
may employ the B<Full Interface> object methods to access any HTTP
header, or to add experimental or non-standard headers.  Both
interfaces try to generate reasonable defaults whenever possible.

For efficiency, just the Simple Interface functions are compiled on
start-up.  Full Interface methods are compiled only when they are
called.  This helps to make CGI::Response usable in a variety of
applications.  [See L<SelfLoader> for more information.]

=head2 Simple Interface

The Simple Interface methods are B<not> exported by default.  In order
to use them, you must import them explicitly.  You can import all of
the methods at once by saying:

   use CGI::Response qw(:Simple);

Or, you can import just one function by listing it by name, as in:

   use CGI::Response qw(ContentType);

Only one Simple Interface function should be called in a response,
since all of these functions terminate the response header (that is,
send the blank line denoting the end of the header) immediately upon
execution.  If you need to use a combination of headers not provided
by the Simple Interface, use the Full Interface instead.

All of the Simple Interface functions force a flush on the
currently-selected output channel (that is, they set C<$| = 1>).  This
is done to prevent a common probelm in CGI scripts, where a
C<system()> or C<exec()> call causes output before the response
header, and generates a server error.  If you do not want C<$| = 1>,
you should either set it back to 0 after using the Simple Interface,
or you should employ the Full Interface, which does not have this side
effect.

For reference, below is a list of the headers sent by each function,
and the default header values, if any.  Arguments are listed in the
order they should appear.  Square brackets ([]) indicate optional
arguments; angled brackets (<>) indicate required arguments.

   Function      Argument(s)      Header(s)      Default(s)
   --------      -----------      ---------      ----------
   &ContentType  [content-type]   Content-Type   text/html

   &Redirect     <Location/URI>   Location       [none]
                 [permanent?]     URI            [none]
                                  Content-Type   text/html
                                  Status         302 Moved Temporarily

   &NoCache      [content-type]   Content-Type   text/html
                                  Pragma         no-cache
                                  Expires        [now]

   &NoContent                     Status         204 No Content

Each of these functions is documented more completely below, and
examples for each are provided.

=over 4

=item &ContentType

This is the most commonly-used function.  It identifies the Internet
Media Type of the entity that follows.  If you call it without an
argument, it will send C<text/html> as the content-type.

   use CGI::Response qw(:Simple);
   print &ContentType;   # defaults to text/html

Otherwise, you can specify some other content-type:

   use CGI::Response qw(:Simple);
   print &ContentType('image/gif');

This function should be called as early as possible to prevent server
errors (see the note on C<$|> above).

=item &Redirect

A redirect causes the user-agent to make a follow-up request for some
other resource.  Some user-agents will be better than others at
complying with a redirect, so this function tries to be as explicit as
possible.

You are required to give one argument, specifying the URL which the
user-agent should request.  A second argument is accepted as a Boolean
value -- if any second argument is present, the browser will be told
that the requested resource has moved permanently to a new URL (that
is, future requests for the document should be to the new URL, not to
the one which was first requested).  

   use CGI::Response qw(:Simple);
   print &Redirect('http://www.company.com/', 'permanent');
   # this resource has moved permanently, status 301

If no second argument is given, the redirect will be specified as
temporary.

   use CGI::Response qw(:Simple);
   print &Redirect('http://www.company.com/');   
   # this resource has moved temporarily, status 302

A brief HTML page is output after the header so that users whose
user-agents fail to recognize the redirect will get an informative
message with a link to the redirect.  Use the Full Interface to supply
some other page or none at all.

=item &NoCache

This function tries to inform user-agents and proxy servers that the
included resource should not be cached.  It does so by sending both an
C<Expires> header, set for immediate expiration, and a C<Pragma:
no-cache> header, which older user-agents and servers might not
recognize.

Preventing caching is important to CGI applications which produce
output based on some factor of the request (such as which user-agent
made the request).  For instance, a shopping-basket application would
not want to allow caching of an order information page, which may
contain user-specific information.

It must be noted, however, that caches prevent excess network load and
cache-friendly applications are always preferable to use of the
&NoCache function.  This function should only be used when there is no
other alternative.

&NoCache takes one optional argument, the content-type of the entity
to follow.  Therefore, its call is nearly identical to the
&ContentType function, and the two functions may be interchanged
easily.  As with &ContentType, if you call &NoCache without an
argument, it will send C<text/html> as the content-type.

   use CGI::Response qw(:Simple);
   print &NoCache;   # defaults to text/html

Otherwise, you can specify some other content-type:

   use CGI::Response qw(:Simple);
   print &NoCache('image/gif');

As noted earlier, this function should be called as early as possible
to prevent server errors (see the note on C<$|> above).

=item &NoContent

&NoContent allows a script to accept input without changing the
current page in the user-agent's view.  This may be useful for a
successful form input that requires no response, or for an imagemap
click that does not have a defined link.

A No Content response does not reset form fields after submission.
HTTP/1.1 will include a C<205 Reset Document> status for this purpose,
and a future version of this module will provide a &Reset function to
support this status.

This function sends only one header, C<Status: 204 No Content>, and it
takes no arguments.

   use CGI::Response qw(:Simple);
   print &NoContent;

=back

=head2 Full Interface

The Full Interface is still under development and is not currently
documented.

=head1 DEPENDENCIES

=head1 SEE ALSO

CGI::Base(3pm), CGI::BasePlus(3pm), CGI::Request(3pm), CGI::Lite(3pm),
CGI(3pm), CGI::Form(3pm), LWP(3pm), SelfLoader(3pm)

=head1 NOTES

Please note that future versions are not guaranteed to be
backwards-compatible with this version.  The interface will be frozen
at version 0.1 (first beta release).

=head1 VERSION

  Version:      0.03 (alpha release)
  Release date: 02 December 1995

=head1 AUTHOR

  Marc Hedlund <hedlund@best.com>
  Copyright 1995, All rights reserved

=cut



