X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FApache%2FMVC.pm;h=3bb33e629a549a68644819ad526f47965b367e3c;hb=4a8ca505c7550ed92d136b71824e29cd8a13ce44;hp=a68f0ac29bc727a51428d296cfebfb0bafcaae0d;hpb=1b3ec28e5f2b7f6f5f4c8140a98e114912271a53;p=maypole.git diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index a68f0ac..3bb33e6 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,103 +1,222 @@ package Apache::MVC; -use base qw(Class::Accessor Class::Data::Inheritable); -use attributes (); -use Class::DBI::Loader; + +our $VERSION = '2.10'; + use strict; use warnings; -__PACKAGE__->mk_classdata(qw( _config init_done view_object )); -__PACKAGE__->mk_accessors ( qw( config ar params objects model_class args )); -__PACKAGE__->config({}); -__PACKAGE__->init_done(0); - -# This is really dirty. -sub config { - my $self = shift; - if (ref $self) { return $self->_config_accessor(@_) } - return $self->_config(@_); -} +use base 'Maypole'; +use Maypole::Headers; +use Maypole::Constants; -sub set_database { - my ($calling_class, $dsn) = @_; - $calling_class = ref $calling_class if ref $calling_class; - $calling_class->config->{dsn} = $dsn; - $calling_class->config->{loader} = Class::DBI::Loader->new( - namespace => $calling_class, - dsn => $dsn - ); -} +__PACKAGE__->mk_accessors( qw( ar ) ); -sub init { - my $class = shift; - my $config = $class->config; - $config->{model} ||= "Apache::MVC::Model::CDBI"; - $config->{view} ||= "Apache::MVC::View::TT"; - $config->{classes} = [ $class->config->{loader}->classes ]; - $config->{display_tables} ||= [ $class->config->{loader}->tables ]; - for my $class (@{$config->{classes}}) { - no strict 'refs'; - push @{$class."::ISA"}, $class->config->{model}; +BEGIN { + my $version; + eval 'use mod_perl2; $version = $mod_perl2::VERSION; '; + if ($@) { + use mod_perl; + $version = 0; + require Apache; + require Apache::Request; + } else { + require Apache2::RequestIO; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require APR::URI; + require Apache2::Request; } - $class->view_object($class->config->{view}->new); + use constant APACHE2 => $version; } -sub class_of { - my ($self, $table) = @_; - return $self->config->{loader}->_table2class($table); -} +=head1 NAME -sub handler { - # See Apache::MVC::Workflow before trying to understand this. - my $class = (caller(0))[0]; - $class->init unless $class->init_done; - my $r = bless { config => $class->config }, $class; - $r->get_request(); - $r->parse_location(); - $r->model_class($r->class_of($r->{table})); - my $status = $r->is_applicable; - return $status unless $status == 200; - $status = $r->call_authenticate; - return $status unless $status == 200; - $r->find_objects(); - $r->additional_data(); - $r->class->process($r); -} +Apache::MVC - Apache front-end to Maypole + +=head1 SYNOPSIS + + package BeerDB; + use Maypole::Application; + +=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. + +=head1 INSTALLATION + +Create a driver module like the one illustrated in L. + +Put the following in your Apache config: + + + SetHandler perl-script + PerlHandler BeerDB + + +Copy the templates found in F into the F +directory off the web root. When the designers get back to you with custom +templates, they are to go in F. If you need to override templates +on a database-table-by-table basis, put the new template in F>. + +This will automatically give you C, C, C, C and C +commands; for instance, to see 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. + +=head1 Implementation + +This class overrides a set of methods in the base Maypole class to provide its +functionality. See L for these: + +=over + +=item get_request + +=cut sub get_request { - my $self = shift; - require Apache; require Apache::Request; - $self->{ar} = Apache::Request->new(Apache->request); + my ($self, $r) = @_; + my $ar = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->new($r); + $self->ar($ar); } +=item parse_location + +=cut + sub parse_location { my $self = shift; - my @pi = split /\//, $self->{ar}->uri(); - shift @pi while @pi and !$pi[0]; - $self->{table} = shift @pi; - $self->{action} = shift @pi; - $self->{args} = \@pi; + + # 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{$_}); + } + my $path = $self->ar->uri; + my $loc = $self->ar->location; + { + no warnings 'uninitialized'; + $path .= '/' if $path eq $loc; + $path =~ s/^($loc)?\///; + } + $self->path($path); + + $self->parse_path; + $self->parse_args; } -sub is_applicable { +=item parse_args + +=cut + +sub parse_args { my $self = shift; - require Apache::Constants; - Apache::Constants->import(":common"); - my $config = $self->config; - my %ok = map {$_ => 1} @{$config->{displaying_tables}}; - return DECLINED() unless exists $ok{$self->{table}}; - - # Does the action method exist? - my $cv = $self->model_class->can($self->{action}); - return DECLINED() unless $cv; - - # Is it exported? - my $attribs = join " ", attributes::get($cv); - return DECLINED() unless $attribs =~ /\b(Exported|Class|Single|Multiple)\b/i; - return OK(); + $self->params( { $self->_mod_perl_args( $self->ar ) } ); + $self->query( $self->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->path; + my $host = $args{domain} || $r->ar->hostname; + 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 OK; +} + +=item get_protocol + +=cut + +sub get_protocol { + my $self = shift; + my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ; + return $protocol; +} + +=item send_output + +=cut + +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 ); } +=item get_template_root -sub authenticate { return 200 } +=cut + +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; + +=back + +=head1 AUTHOR + +Simon Cozens, C +Marcus Ramberg, C +Sebastian Riedel, C + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut