From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

TEEJAY / Maypole-2.10_pre3 / lib / Apache / MVC.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
—
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171

              
package Apache::MVC;
our $VERSION = '2.09';
use strict;
use warnings;
use base 'Maypole';
use mod_perl;
use Maypole::Headers;
use constant APACHE2 => $mod_perl::VERSION >= 1.99;
if (APACHE2) {
    require Apache2;
    require Apache::RequestIO;
    require Apache::RequestRec;
    require Apache::RequestUtil;
    require APR::URI;
}
else { require Apache }
require Apache::Request;
sub get_request {
    my ( $self, $r ) = @_;
    $self->{ar} = Apache::Request->new($r);
}
sub parse_location {
    my $self = shift;
    # Reconstruct the request headers
    $self->headers_in(Maypole::Headers->new);
    my %headers;
    if (APACHE2) { %headers = %{$self->{ar}->headers_in};
    } else { %headers = $self->{ar}->headers_in; }
    for (keys %headers) {
        $self->headers_in->set($_, $headers{$_});
    }
    $self->{path} = $self->{ar}->uri;
    my $loc = $self->{ar}->location;
    no warnings 'uninitialized';
    $self->{path} .= '/' if $self->{path} eq $loc;
    $self->{path} =~ s/^($loc)?\///;
    $self->parse_path;
    $self->parse_args;
}
sub parse_args {
    my $self = shift;
    $self->{params} = { $self->_mod_perl_args( $self->{ar} ) };
    $self->{query}  = { $self->_mod_perl_args( $self->{ar} ) };
}
sub send_output {
    my $r = shift;
    $r->{ar}->content_type(
          $r->{content_type} =~ m/^text/
        ? $r->{content_type} . "; charset=" . $r->{document_encoding}
        : $r->{content_type}
    );
    $r->{ar}->headers_out->set(
        "Content-Length" => do { use bytes; length $r->{output} }
    );
    foreach ($r->headers_out->field_names) {
        next if /^Content-(Type|Length)/;
        $r->{ar}->headers_out->set($_ => $r->headers_out->get($_));
    }
    APACHE2 || $r->{ar}->send_http_header;
    $r->{ar}->print( $r->{output} );
}
sub get_template_root {
    my $r = shift;
    $r->{ar}->document_root . "/" . $r->{ar}->location;
}
sub _mod_perl_args {
    my ( $self, $apr ) = @_;
    my %args;
    foreach my $key ( $apr->param ) {
        my @values = $apr->param($key);
        $args{$key} = @values == 1 ? $values[0] : \@values;
    }
    return %args;
}
1;
=head1 NAME
Apache::MVC - Apache front-end to Maypole
=head1 SYNOPSIS
    package BeerDB;
    use base 'Apache::MVC';
    BeerDB->setup("dbi:mysql:beerdb");
    BeerDB->config->uri_base("http://your.site/");
    BeerDB->config->display_tables([qw[beer brewery pub style]]);
    # Now set up your database:
    # has-a relationships
    # untaint columns
    1;
=head1 DESCRIPTION
A mod_perl platform driver for Maypole. Your application can inherit from
Apache::MVC directly, but it is recommended that you use
L<Maypole::Application>.
=head1 INSTALLATION
Create a driver module like the one above.
Put the following in your Apache config:
    <Location /beer>
        SetHandler perl-script
        PerlHandler BeerDB
    </Location>
Copy the templates found in F<templates/factory> into the
F<beer/factory> directory off the web root. When the designers get
back to you with custom templates, they are to go in
F<beer/custom>. If you need to do override templates on a
database-table-by-table basis, put the new template in
F<beer/I<table>>. 
This will automatically give you C<add>, C<edit>, C<list>, C<view> and
C<delete> commands; for instance, a list of breweries, go to 
    http://your.site/beer/brewery/list
For more information about how the system works and how to extend it,
see L<Maypole>.
=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
=item get_template_root
=item parse_args
=item parse_location
=item send_output
=back
=head1 AUTHOR
Simon Cozens, C<simon@cpan.org>
Marcus Ramberg, C<marcus@thefeed.no>
Screwed up by Sebastian Riedel, C<sri@oook.de>
=head1 LICENSE
You may distribute this code under the same terms as Perl itself.
=cut