package CGI::Maypole;
use base 'Maypole';

use strict;
use warnings;
use CGI::Simple;
use Maypole::Headers;
use Maypole::Constants;

our $VERSION = '2.13';

__PACKAGE__->mk_accessors( qw/cgi/ );

=head1 NAME

CGI::Maypole - CGI-based front-end to Maypole

=head1 SYNOPSIS

     package BeerDB;
     use Maypole::Application;

     ## example beer.cgi:

     #!/usr/bin/perl -w
     use strict;
     use BeerDB;
     BeerDB->run();

Now to access the beer database, type this URL into your browser:
http://your.site/cgi-bin/beer.cgi/frontpage

NOTE: this Maypole frontend requires additional modules that won't be installed
or included with Maypole. Please see below.

=head1 DESCRIPTION

This is a CGI platform driver for Maypole. Your application can inherit from
CGI::Maypole directly, but it is recommended that you use
L<Maypole::Application>.

This module requires CGI::Simple which you will have to install yourself via
CPAN or manually.

=head1 METHODS

=over

=item run

Call this from your CGI script to start the Maypole application.

=back

=cut

sub run  {
  my $self = shift;
  my $status = $self->handler;
  if ($status != OK) {
    print <<EOT;
Status: 500 Maypole application error
Content-Type: text/html

<title>Maypole application error</h1>
<h1>Maypole application error</h1>
EOT
  }
  return $status;
}

=head1 Implementation

This class overrides a set of methods in the base Maypole class to provide it's
functionality. See L<Maypole> for these:

=over

=item get_request

=cut

sub get_request {
  my $self = shift;
  my $request_options = $self->config->request_options || {};
  $CGI::Simple::POST_MAX = $request_options->{POST_MAX} if ($request_options->{POST_MAX});
  $self->cgi( CGI::Simple->new );
}

=item parse_location

=cut

sub parse_location 
{
    my $r = shift;
    my $cgi = $r->cgi;

    # Reconstruct the request headers (as far as this is possible)
    $r->headers_in(Maypole::Headers->new);
    for my $http_header ($cgi->http) {
        (my $field_name = $http_header) =~ s/^HTTPS?_//;
        $r->headers_in->set($field_name => $cgi->http($http_header));
    }

    $r->preprocess_location();

    my $path = $cgi->url( -absolute => 1, -path_info => 1 );
    my $loc = $cgi->url( -absolute => 1 );
    {
        no warnings 'uninitialized';
        $path .= '/' if $path eq $loc;
	if ($loc =~ /\/$/) {
	  $path =~ s/^($loc)?//;
	} else {
	  $path =~ s/^($loc)?\///;
	}
    }
    $r->path($path);
    
    $r->parse_path;
    $r->parse_args;
}

=item warn

=cut

sub warn {
    my ($self,@args) = @_;
    my ($package, $line) = (caller)[0,2];
    warn "[$package line $line] ", @args ;
    return;
}

=item parse_args

=cut

sub parse_args 
{
    my $r = shift;
    my (%vars) = $r->cgi->Vars;
    while ( my ( $key, $value ) = each %vars ) {
        my @values = split "\0", $value;
        $vars{$key} = @values <= 1 ? $values[0] : \@values;
    }
    $r->params( {%vars} );
    $r->query( $r->params );
}

=item redirect_request

=cut

# FIXME: use headers_in to gather host and other information?
sub redirect_request 
{
  my $r = shift;
  my $redirect_url = $_[0];
  my $status = "302";
  if ($_[1]) {
    my %args = @_;
    if ($args{url}) {
      $redirect_url = $args{url};
    } else {
      my $path = $args{path} || $r->cgi->url(-absolute => 1, -query=>1);
      my $host = $args{domain};
      ($host = $r->cgi->url(-base => 1)) =~ s/^https?:\/\///i unless ($host);
      my $protocol = $args{protocol} || $r->get_protocol;
      $redirect_url = "${protocol}://${host}/${path}";
    }
    $status = $args{status} if ($args{status});
  }

  $r->headers_out->set('Status' => $status);
  $r->headers_out->set('Location' => $redirect_url);

  return;
}

=item get_protocol

=cut

sub get_protocol 
{
  my $self = shift;
  my $protocol = ($self->cgi->https) ? 'https' : 'http';
  return $protocol;
}

=item send_output

Generates output (using C<collect_output>) and prints it. 

=cut

sub send_output 
{
    my $r = shift;
    print $r->collect_output;
}

=item collect_output

Gathers headers and output together into a string and returns it.

Splitting this code out of C<send_output> supports L<Maypole::HTTPD::Frontend>.

=cut

sub collect_output
{
    my $r = shift;
    
    # Collect HTTP headers
    my %headers = (
        -type            => $r->content_type,
        -charset         => $r->document_encoding,
        -content_length  => do { use bytes; length $r->output },
    );
    foreach ($r->headers_out->field_names) {
        next if /^Content-(Type|Length)/;
        $headers{"-$_"} = $r->headers_out->get($_);
    }

    return $r->cgi->header(%headers) . $r->output;
}

=item get_template_root

=cut

sub get_template_root {
    my $r = shift;
    $r->cgi->document_root . "/" . $r->cgi->url( -relative => 1 );
}

1;


=back

=head1 DEPENDANCIES

CGI::Simple

=head1 AUTHORS

Dave Ranney C<dave@sialia.com>

Simon Cozens C<simon@cpan.org>

=cut