lib/CGI/Maypole.pm

   1 package CGI::Maypole;
   2 use base 'Maypole';
   3
   4 use strict;
   5 use warnings;
   6 use CGI::Simple;
   7 use Maypole::Headers;
   8
   9 our $VERSION = '2.09';
  10
  11 sub run {
  12     my $self = shift;
  13     return $self->handler();
  14 }
  15
  16 sub get_request {
  17     shift->{cgi} = CGI::Simple->new();
  18 }
  19
  20
  21 sub parse_location {
  22     my $self = shift;
  23     my $cgi = $self->{cgi};
  24
  25     # Reconstruct the request headers (as far as this is possible)
  26     $self->headers_in(Maypole::Headers->new);
  27     for my $http_header ($cgi->http) {
  28         (my $field_name = $http_header) =~ s/^HTTPS?_//;
  29         $self->headers_in->set($field_name => $cgi->http($http_header));
  30     }
  31
  32     $self->{path} = $cgi->url( -absolute => 1, -path_info => 1 );
  33     my $loc = $cgi->url( -absolute => 1 );
  34     no warnings 'uninitialized';
  35     $self->{path} .= '/' if $self->{path} eq $loc;
  36     $self->{path} =~ s/^($loc)?\///;
  37     $self->parse_path;
  38     $self->parse_args;
  39 }
  40
  41 sub parse_args {
  42     my $self = shift;
  43     my (%vars) = $self->{cgi}->Vars;
  44     while ( my ( $key, $value ) = each %vars ) {
  45         my @values = split "\0", $value;
  46         $vars{$key} = @values <= 1 ? $values[0] : \@values;
  47     }
  48     $self->{params} = {%vars};
  49     $self->{query}  = {%vars};
  50 }
  51
  52 sub send_output {
  53     my $r = shift;
  54
  55     # Collect HTTP headers
  56     my %headers = (
  57         -type            => $r->{content_type},
  58         -charset         => $r->{document_encoding},
  59         -content_length  => do { use bytes; length $r->{output} },
  60     );
  61     foreach ($r->headers_out->field_names) {
  62         next if /^Content-(Type|Length)/;
  63         $headers{"-$_"} = $r->headers_out->get($_);
  64     }
  65
  66     print $r->{cgi}->header(%headers), $r->{output};
  67 }
  68
  69 sub get_template_root {
  70     my $r = shift;
  71     $r->{cgi}->document_root . "/" . $r->{cgi}->url( -relative => 1 );
  72 }
  73
  74 1;
  75
  76 =head1 NAME
  77
  78 CGI::Maypole - CGI-based front-end to Maypole
  79
  80 =head1 SYNOPSIS
  81
  82      package BeerDB;
  83      use base 'CGI::Maypole';
  84      BeerDB->setup("dbi:mysql:beerdb");
  85      BeerDB->config->uri_base("http://your.site/cgi-bin/beer.cgi/");
  86      BeerDB->config->display_tables([qw[beer brewery pub style]]);
  87      BeerDB->config->template_root("/var/www/beerdb/");
  88      # Now set up your database:
  89      # has-a relationships
  90      # untaint columns
  91
  92      1;
  93
  94      ## example beer.cgi:
  95
  96      #!/usr/bin/perl -w
  97      use strict;
  98      use BeerDB;
  99      BeerDB->run();
 100
 101 Now to access the beer database, type this URL into your browser:
 102 http://your.site/cgi-bin/beer.cgi/frontpage
 103
 104 =head1 DESCRIPTION
 105
 106 This is a CGI platform driver for Maypole. Your application can inherit from
 107 CGI::Maypole directly, but it is recommended that you use
 108 L<Maypole::Application>.
 109
 110
 111 =head1 METHODS
 112
 113 =over
 114
 115 =item run
 116
 117 Call this from your CGI script to start the Maypole application.
 118
 119 =back
 120
 121 =head1 Implementation
 122
 123 This class overrides a set of methods in the base Maypole class to provide it's
 124 functionality. See L<Maypole> for these:
 125
 126 =over
 127
 128 =item get_request
 129
 130 =item get_template_root
 131
 132 =item parse_args
 133
 134 =item parse_location
 135
 136 =item send_output
 137
 138 =back
 139
 140 =head1 AUTHORS
 141
 142 Dave Ranney C<dave@sialia.com>
 143
 144 Simon Cozens C<simon@cpan.org>
 145
 146 =cut