package ASP4::ModPerl;

use strict;
use warnings 'all';
use APR::Table ();
use APR::Socket ();
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::Connection ();
use Apache2::RequestUtil ();
use ASP4::HTTPContext ();
use CGI( ':cgi' );


#==============================================================================
sub handler : method
{
  my ($class, $r) = @_;
  
  $ENV{DOCUMENT_ROOT}   = $r->document_root;
  $ENV{REMOTE_ADDR}     = $r->connection->get_remote_host();
  $ENV{HTTP_HOST}       = $r->hostname;
  
  my $context = ASP4::HTTPContext->new();
  $r->pool->cleanup_register(sub { $context->DESTROY });
  
  if( ($r->headers_in->{'content-type'}||'') =~ m/multipart\/form\-data/ )
  {
    $context->{r} = $r;
    if( $@ )
    {
      warn $@;
      $r->status( 500 );
      return $r->status;
    }# end if()
    
    my $handler_class = eval {
      $context->config->web->handler_resolver->new()->resolve_request_handler( $r->uri )
    };
    if( $@ )
    {
      warn $@;
      $r->status( 500 );
      return $r->status;
    }# end if()
    
    return 404 unless $handler_class;
    
    eval {
      my $cgi = CGI->new( $r );
      my %args = map { my ($k,$v) = split /\=/, $_; ( $k => $v ) } split /&/, $ENV{QUERY_STRING};
      map { $cgi->param($_ => $args{$_}) } keys %args;
      $context->setup_request( $r, $cgi);
      $context->execute;
    };
    if( $@ )
    {
      if( $@ =~ m/Software\scaused\sconnection\sabort/ )
      {
        return 0;
      }# end if()
      warn $@;
      $r->status( 500 );
    }# end if()
    return $r->status =~ m/^2/ ? 0 : $r->status == 500 ? 0 : $r->status;
  }
  else
  {
    my $cgi = CGI->new( $r );
    eval {
      $context->setup_request( $r, $cgi );
      $context->execute;
    };
    if( $@ =~ m/Software\scaused\sconnection\sabort/ )
    {
      return 0;
    }# end if()
    warn $@ if $@;
    
    
    if( $context->response->Status == 200 )
    {
      $r->status( 200 );
      if( $context->did_end && $context->did_send_headers )
      {
        $r->rflush();
      }# end if()
      return 0;
    }
    else
    {
      $r->status( $context->response->Status );
      if( $context->did_end && $context->did_send_headers )
      {
        $r->rflush();
      }
      else
      {
        # Make sure we send our headers now, since we haven't done so already:
        $context->send_headers();
        $context->did_end(1);
        $r->rflush();
      }# end if()
      return $context->response->Status == 500 ? 0 : $context->response->Status;
    }# end if()
  }# end if()
  
}# end handler()

1;# return true:

=pod

=head1 NAME

ASP4::ModPerl - mod_perl2 PerlResponseHandler for ASP4

=head1 SYNOPSIS

In your httpd.conf

  # Load up some important modules:
  PerlModule DBI
  PerlModule DBD::mysql
  PerlModule ASP4::ModPerl
  
  <VirtualHost *:80>
  
    ServerName    mysite.com
    ServerAlias   www.mysite.com
    DocumentRoot  /usr/local/projects/mysite.com/htdocs
    
    # Set the directory index:
    DirectoryIndex index.asp
    
    # All *.asp files are handled by ASP4::ModPerl
    <Files ~ (\.asp$)>
      SetHandler  perl-script
      PerlResponseHandler ASP4::ModPerl
    </Files>
    
    # !IMPORTANT! Prevent anyone from viewing your GlobalASA.pm
    <Files ~ (\.pm$)>
      Order allow,deny
      Deny from all
    </Files>
    
    # All requests to /handlers/* will be handled by their respective handler:
    <Location /handlers>
      SetHandler  perl-script
      PerlResponseHandler ASP4::ModPerl
    </Location>
    
  </VirtualHost>

=head1 DESCRIPTION

C<ASP4::ModPerl> provides a mod_perl2 PerlResponseHandler interface to
L<ASP4::HTTPContext>.

Under normal circumstances, all you have to do is configure it and forget about it.

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=ASP4> to submit bug reports.

=head1 HOMEPAGE

Please visit the ASP4 homepage at L<http://0x31337.org/code/> to see examples
of ASP4 in action.

=head1 AUTHOR

John Drago L<mailto:jdrago_999@yahoo.com>

=head1 COPYRIGHT AND LICENSE

Copyright 2007 John Drago, All rights reserved.

This software is free software.  It may be used and distributed under the
same terms as Perl itself.

=cut