package PSP::Driver;

# Copyright (c) 2000, FundsXpress Financial Network, Inc.
# This library is free software released under the GNU Lesser General
# Public License, Version 2.1.  Please read the important licensing and
# disclaimer information included below.

# $Id: Driver.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;

=head1 NAME

 PSP::Driver - executes page methods of a loaded pile

=head1 SYNOPSIS

 # In typical CGI form
 use CGI;
 use PSP::Driver qw(dispatch);
 my $cgi = CGI->new();
 dispatch($cgi);

 # In FastCGI form
 use CGI::Fast;
 while (my $cgi = CGI::Fast->new()) {
   dispatch($cgi);
 }

 # In httpd.conf for mod_perl
 <Location /driver>
   SetHandler "perl-script"
   PerlModule PSP::Driver
   PerlHandler PSP::Driver
 </Location>

=head1 DESCRIPTION

The PSP Driver associates an incoming request to a pile object and a 
particular set of methods of that pile object.  It executes the page
method in an exception friendly environment, and then outputs the page
headers and result to standard output.

If called in a CGI or FastCGI environment, dispatch() is called from the
executable script and is passed a CGI object.  dispatch() in turn calls
dispatch_page(), which is available in a hypothetical environment that
can generate a pile_url or page_url without dispatch().

If called in a mod_perl environment, handler() is called, which creates a
CGI object and passes it to dispatch(), which in turn calls
dispatch_page().

=cut

use Exporter;
use Error qw (:try);
use CGI;
use Data::Dumper;
use PSP::Loader;
use PSP::Log qw(&psp_log_event &psp_warn);
use PSP::Utils qw(&save_or_restore_env);
use PSP::Conf qw($psp_do_auto_die
		 $psp_auto_die_fname
		 $psp_requests_per_process
		 $psp_save_or_restore_env
		 $psp_dump_dir
		 $psp_loader);

BEGIN {
  @PSP::Driver::ISA = qw(Exporter);
  @PSP::Driver::EXPORT_OK = qw(&dispatch &dispatch_page $n_requests);
  $PSP::Driver::EXPORT_TAGS{all} = \@PSP::Driver::EXPORT_OK;
}

# $n_requests is number of requests dispatched by this process.
use vars qw($n_requests);
$n_requests = 0;

=head1 METHODS

=head2 handler

 package
 () handler (Apache::Request $r)

DESCRIPTION:

mod_perl handler.

=cut

sub handler {
  my ($request) = @_;
  my $cgi = CGI->new();
  return dispatch($cgi);
}

=head2 dispatch

 global
 () dispatch (CGI $cgi)

DESCRIPTION:

Analyze the CGI environment, and determine the pile_url and the page_url.
The pile_url is the minimum URL required to get to a particular pile, while
the page_url is the URL relative to the piledriver.  For example, given a
URL like:  http://localhost/piles/this_pile/this/page,

 pile_url = http://localhost/piles/this_pile

  and

 page_url = this_pile/this/page

The pile_url is used to find the initial pile, and the page_url is used to
determine which page from within the pile.

At the bottom of this routine, dispatch() calls dispatch_page() with this
determined information, and returns its return value.

=cut

sub dispatch {
  my ($cgi) = @_;

  # this is useful for debugging from a command-line.
  # this must occur before we change and/or interpret the environment.
  $psp_save_or_restore_env and
    save_or_restore_env($psp_save_or_restore_env);

  # handle redirected call.  (e.g. from FastCGI with Handler.)
  my ($pile_url,$page_url);
  if ($ENV{REDIRECT_URL} and 
      $ENV{REDIRECT_URL} =~ /^(.*?\bpiles)(\/.*[^\/]+(\.pile4?\b)?)(.*)$/) {
    $pile_url = $1.$2;
    $page_url = $2.$4;
  }

  # e.g. when PATH_INFO contains a piles component with /.*\.pile?/
  if (! $page_url) {
    if ($ENV{PATH_INFO} =~ /^(.*?\bpiles)(\/.*[^\/]+(\.pile4?\b)?)(.*)$/) {
      $pile_url = $1.$2;
      $page_url = $2.$4;
    }
  }

  # handle "normal" call.
  # e.g. from /cgi-bin/piledriver, PATH_INFO begins with pile name.
  if (! $page_url) {
    if ($ENV{SCRIPT_NAME} and 
	$ENV{PATH_INFO} =~ /^(\/[^\/]+)\b(.*)$/) {
      $pile_url = $ENV{SCRIPT_NAME}.$1;
      $page_url = $1.$2;
    }
  }

  # what to do here?
  if (! $page_url) {
    $pile_url = $ENV{SCRIPT_NAME};
    $page_url = $ENV{PATH_INFO};
  } else {
    # give $cgi->path_info() a little predictability..
    $ENV{PATH_INFO} = $page_url;
  }

  return dispatch_page($cgi,$pile_url,$page_url);
} #dispatch

=head2 dispatch_page

 global
 () dispatch_page (CGI $cgi, string $pile_url, string $page_url)

DESCRIPTION:

This function determines the subroutine that the input page is mapped to,
calls it, and prints the output result to STDOUT.

The global loader object recursively iterates upon the input page_url, and 
returns a pile object, and a page method.

Then, if a form id is present in the input parameters, the associated
submit_handler method is called and passed the above page method, and is
expected to return a possibly new page method.

The page method is called and is expected to return the output content.

An exception may be raise by any of the steps of this procedure, and will
be caught by the ajoining catch block.  The catch block passes the caught
Error object to the handle_exception() method, which is expected to return
the error message to be displayed to the user.  If it fails to, the catch
block will generate the message.

Both the page method and the exception handler may change the response
CGI headers via the header() and headers() methods off of the Pile 
interface.

After the page is executed and/or a thrown exception is handled, 
the headers and then the content is written to STDOUT.

=cut

sub dispatch_page {
  my ($cgi, $pile_url, $page_url) = @_;

  # count the number of requests.
  $n_requests++;

  # log the beginning and end of each page dispatched.
  my $start_time = psp_log_event("$page_url","Request has started.");

  my ($pile,$page_name,%headers);
  my $content = "";

  # Begin exeception handling here.
  try {

    # Map the input url to a pile and a page name.
    # Complain if we don't get a pile out of this.
    ($pile,$page_name) = $psp_loader->map_page($cgi,$page_url);
    $pile or throw
      Error::Simple("'$page_url' does not map to a pile.\n");

    # have the pile's headers methods refer to our current lexical %headers.
    %headers = $pile->headers();
    $pile->headers(\%headers);
    # inform the pile of the input base pile_url.
    $pile->url($pile_url);

    # if there is a form_id, call the submit_handler.
    if (my $form_id = $cgi->param('_form_id')) {
      my $submit_name = $pile->submit_page($form_id) or throw
	Error::Simple(ref($pile)." submit handler not found.\n".
		      "(form ID = $form_id)\n");
      ($page_name) = $pile->$submit_name($page_name);
    }

    # if this method is not available, return page_not_found page.
    if (! $pile->can($page_name)) {
      $content .= $pile->page_not_found($page_name);
      return; # (return out of try block.)
    }

    # call the pile method.
    $content .= $pile->$page_name();

    # warn if the page is empty.
    $content eq "" and psp_warn("Empty page generated.");

  } catch Error with {
    my $error = shift;

    # Determine the return status. (stupid MSIE doesn't do 404 right)
    my $status = $headers{status} || "200 Internal Server Error";

    # Clear all headers; reassign status to the above.  clear content.
    %headers = (status => $status);
    $content = "";

    # if there is a defined handle_exception(), call it with this error.
    if ($pile and $pile->can("handle_exception")) {
      $content .= eval { $pile->handle_exception($error) };
    }

    $content ne "" and return; # (we have content. return from catch block.)

    # otherwise, or styling mechanisms failed, and the error slipped through.

    # populate content with text, file, and line from Error.
    (my $text = $error->text()) =~ s/\n/<br>\n/g;
    $content .= "<b><font size=\"+1\">$text</font></b><hr>\n";
    $content .= "<font size=\"+1\">thrown at <b>".$error->file()."</b>\n";
    $content .= "&nbsp; (line <b>".$error->line()."</b>)</font>\n";

    # note any error in the exception handler.
    ($@ ne "") and
      $content .= "<hr>Error in handle_exception(): $@<br>\n";

    # bring it all together into a table format.
    $content = ('<table border="1" cellpadding="10">'.
		'<tr><td colspan="2"><b><font size="+2">'.
		"Unhandled &nbsp; ".ref($error)." &nbsp; ".
		"Exception</font></td></tr>\n".
		'<tr><td colspan="2">'.$content."</td></tr></table>\n");

  };#catch

  # Get rid of some extraneous whitespace.  collapse multiple blank lines.
  $content =~ s/\s*\n\s*\n+/\n\n/sg;
  $content =~ s/\s*$/\n/sg;

  # Call post-dispatch method if present.
  if ($pile and $pile->can("post_dispatch")) {
    $content = $pile->post_dispatch($content);
  }

  #######################################################################
  ### We now have a $content we want to print, and %headers is populated.

  # CGI.pm wants all headers to begin with "-"
  my ($val, %cgi_headers);
  for my $key (sort keys %headers) {
    $val = $headers{$key};
    $key =~ s/^([^-])/-$1/; 
    $cgi_headers{$key} = $val;
  }

  my $extra = "";
  if ($pile and (!$cgi_headers{'-Content-Type'} or
		 $cgi_headers{'-Content-Type'} eq 'text/html')) {
    (my $tmp = $pile->page_name()) =~ s/^page__//;
    $extra .= "<!-- pile:".$pile->name()." page:".$pile->page_name()." -->\n";
  }

  # assign the content-length.
  $cgi_headers{'-Content_length'} = length($content) + length($extra);

  my $header = $cgi->header(%cgi_headers);

  # print the header and content.
  print $header;
  print $extra if length($extra);
  print $content;

  # Do some debugging dumps;
  if ($psp_dump_dir) {
    mkdir $psp_dump_dir, 0755;
    if (open OUT, ">$psp_dump_dir/rqst-$$-$n_requests") {
      print OUT Dumper($cgi);
      close OUT;
    }
    if (open OUT, ">$psp_dump_dir/head-$$-$n_requests") {
      print OUT $header;
      close OUT;
    }
    if (open OUT, ">$psp_dump_dir/body-$$-$n_requests") {
      print OUT $extra if length($extra);
      print OUT $content;
      close OUT;
    }
  }


  # cleanup
  if ($pile) {
    $pile and eval { $pile->cleanup() };
    $psp_loader->unshare();
    $pile->free_internals();
    undef $pile;
  }

  # log the end of dispatch.
  psp_log_event("$page_url","Request has stopped.",
		$start_time,$pile||$cgi);

  # detect and react to conditions to die:
  # die if we have reached our maximum number of requests.
  if ($psp_requests_per_process) {
    if ($n_requests >= $psp_requests_per_process) {
      die "Dying after executing $psp_requests_per_process requests.\n";
    }
  }

  # die if the loader detected that the pile file changed.
  if ($psp_auto_die_fname) {
    die "Detected change in pile, $psp_auto_die_fname\n";
  }

} #dispatch_page

=head2

 global
 () fix_apache_buffer_problem (CGI $cgi, 
			       string ref $content, string ref $header)

DESCRIPTION:

There is a buffer boundary bug in the Apache server which results in
"Document contains no data" error at the browser. Error only shows up when
we return to Apache a page of length "near" 8192.  This patch checks the
size of all pages being returned; if their length +/- 100 bytes of the
8192 boundary, we will pad the page with 200 blanks. We can remove this
patch whenever the bug is fixed in Apache.

This problem probably does not exist anymore.

=cut

sub fix_apache_buffer_problem {
  my ($cgi,$content,$header) = @_;

  # do the Apache buffer hack against the headers + content.
  my ($len, $modlen);
  $len    = length( $$content . $$header );
  $modlen = $len % 8192;
  if ( ($modlen > 8092) or ($modlen < 100   and $len >= 8192) ) {
    $$content = $$content.(' 'x200);
    my $content_len = length( $$content );
    $$header =~ s/^content-length: \d+\b/Content-Length: $content_len/;
  }
}

1;
__END__

=head1 BUGS

No known bugs, but this does not mean no bugs exist.

=head1 SEE ALSO

L<CGI>, L<PSP::Loader>, L<PSP::Log>, L<PSP::Conf>

=head1 COPYRIGHT

 PSP - Perl Server Pages
 Copyright (c) 2000, FundsXpress Financial Network, Inc.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2 of the License, or (at your option) any later version.

 BECAUSE THIS LIBRARY IS LICENSED FREE OF CHARGE, THIS LIBRARY IS
 BEING PROVIDED "AS IS WITH ALL FAULTS," WITHOUT ANY WARRANTIES
 OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, WITHOUT
 LIMITATION, ANY IMPLIED WARRANTIES OF TITLE, NONINFRINGEMENT,
 MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, AND THE
 ENTIRE RISK AS TO SATISFACTORY QUALITY, PERFORMANCE, ACCURACY,
 AND EFFORT IS WITH THE YOU.  See the GNU Lesser General Public
 License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

=cut