#!/usr/local/bin/perl # CGI::Response # Marc Hedlund # 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"; This Resource Has Moved

This Resource Has Moved

This resource has moved to \<URL:$_[0]\>.

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', '; 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 = ; # close(FILE); # # $contents = join('', @contents); # $contents =~ /([^<]*)<\/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