X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=blobdiff_plain;f=lib%2FApache%2FMVC.pm;h=3ea2d28479dc28d49430c893ba6b7fc18765b3ae;hp=960888f2835c2bdc3a80655bde3af87027ed32b1;hb=373c588aa7b5a4f0d99a5940fade8a767c6d9426;hpb=5bf6ba7247ade1abba2f2756e7f8ae0286ed9678 diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 960888f..3ea2d28 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,265 +1,344 @@ package Apache::MVC; -use base qw(Class::Accessor Class::Data::Inheritable); -use attributes (); -use Class::DBI::Loader; -use UNIVERSAL::require; -use Apache::Constants ":common"; + +our $VERSION = '2.121'; + use strict; use warnings; -our $VERSION = "0.2"; -__PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); -__PACKAGE__->mk_accessors ( qw( ar params query objects model_class -args action template )); -__PACKAGE__->config({}); -__PACKAGE__->init_done(0); - - -sub import { - my $real = shift; - if ($real ne "Apache::MVC") { - no strict 'refs'; - *{$real."::handler"} = sub { Apache::MVC::handler($real, @_) }; - } -} -sub set_database { - my ($calling_class, $dsn) = @_; - $calling_class = ref $calling_class if ref $calling_class; - my $config = $calling_class->config; - $config->{model} ||= "Apache::MVC::Model::CDBI"; - $config->{model}->require; - $config->{dsn} = $dsn; - $config->{loader} = Class::DBI::Loader->new( - namespace => $calling_class, - dsn => $dsn - ); - $config->{classes} = [ $config->{loader}->classes ]; - for my $subclass (@{$config->{classes}}) { - no strict 'refs'; - unshift @{$subclass."::ISA"}, $config->{model}; - $config->{model}->adopt($subclass) - if $config->{model}->can("adopt"); +use URI; +use URI::QueryParam; + +use base 'Maypole'; +use Maypole::Headers; +use Maypole::Constants; + +__PACKAGE__->mk_accessors( qw( ar ) ); + +our $MODPERL2; +our $modperl_version; + +BEGIN { + $MODPERL2 = ( exists $ENV{MOD_PERL_API_VERSION} and + $ENV{MOD_PERL_API_VERSION} >= 2 ); + if ($MODPERL2) { + eval 'use mod_perl2; $modperl_version = $mod_perl2::VERSION;'; + if ($@) { + $modperl_version = $Apache2::RequestRec::VERSION; + } + require Apache2::RequestIO; + require Apache2::RequestRec; + require Apache2::RequestUtil; + eval 'use Apache2::Const -compile => qw/REDIRECT/;'; # -compile 4 no import + require APR::URI; + require HTTP::Body; + } else { + eval ' use mod_perl; '; + require Apache; + require Apache::Request; + eval 'use Apache::Constants -compile => qw/REDIRECT/;'; + $modperl_version = 1; } + } -sub init { - my $class = shift; - my $config = $class->config; - $config->{view} ||= "Apache::MVC::View::TT"; - $config->{view}->require; - $config->{display_tables} ||= [ $class->config->{loader}->tables ]; - $class->view_object($class->config->{view}->new); - $class->init_done(1); +=head1 NAME -} +Apache::MVC - Apache front-end to Maypole -sub class_of { - my ($self, $table) = @_; - return $self->config->{loader}->_table2class($table); -} +=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 -sub handler { - # See Apache::MVC::Workflow before trying to understand this. - my $class = shift; - $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; - if ($status == OK) { - $status = $r->call_authenticate; - return $status unless $status == OK; - $r->additional_data(); - - $r->model_class->process($r); - } else { - # Otherwise, it's just a plain template. - delete $r->{model_class}; - $r->{path} =~ s{/}{}; # De-absolutify - $r->template($r->{path}); +=item get_request + +=cut + +sub get_request { + my ($self, $r) = @_; + my $request_options = $self->config->request_options || {}; + my $ar; + if ($MODPERL2) { + $ar = eval {require Apache2::Request} ? Apache2::Request->new($r,%{$request_options}) : $r; + } else { + if (keys %$request_options) { + $ar = Apache::Request->new($r,%{$request_options}); + } else { + $ar = Apache::Request->instance($r); + } } - return $r->view_object->process($r); + $self->ar($ar); } -sub get_request { - my $self = shift; - require Apache; require Apache::Request; - $self->{ar} = Apache::Request->new(Apache->request); +=item warn + +=cut + +sub warn { + my ($self,@args) = @_; + my ($package, $line) = (caller)[0,2]; + my $ar = $self->parent ? $self->parent->{ar} : $self->{ar}; + if ( $args[0] and ref $self ) { + $ar->warn("[$package line $line] ", @args) ; + } else { + print "warn called by ", caller, " with ", @_, "\n"; + } + return; } + +=item parse_location + +=cut + sub parse_location { my $self = shift; - $self->{path} = $self->{ar}->uri; - my $loc = $self->{ar}->location; - $self->{path} =~ s/^$loc//; # I shouldn't need to do this? - $self->{path} ||= "frontpage"; - my @pi = split /\//, $self->{path}; - shift @pi while @pi and !$pi[0]; - $self->{table} = shift @pi; - $self->{action} = shift @pi; - $self->{args} = \@pi; - - $self->{params} = { $self->{ar}->content }; - $self->{query} = { $self->{ar}->args }; -} -sub is_applicable { - my $self = shift; - my $config = $self->config; - $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}}; - warn "We don't have that table ($self->{table})" - unless $config->{ok_tables}{$self->{table}}; - return DECLINED() unless exists $config->{ok_tables}{$self->{table}}; - - # Does the action method exist? - my $cv = $self->model_class->can($self->{action}); - warn "We don't have that action ($self->{action})" unless $cv; - return DECLINED() unless $cv; - - # Is it exported? - $self->{method_attribs} = join " ", attributes::get($cv); - do { warn "$self->{action} not exported"; - return DECLINED() - } unless $self->{method_attribs} =~ /\bExported\b/i; - return OK(); + # Reconstruct the request headers + $self->headers_in(Maypole::Headers->new); + + my %headers; + if ($MODPERL2) { %headers = %{$self->ar->headers_in}; + } else { %headers = $self->ar->headers_in; } + for (keys %headers) { + $self->headers_in->set($_, $headers{$_}); + } + + $self->preprocess_location(); + + my $path = $self->ar->uri; + my $base = URI->new($self->config->uri_base); + my $loc = $base->path; + + { + no warnings 'uninitialized'; + $path .= '/' if $path eq $loc; + if ($loc =~ /\/$/) { + $path =~ s/^($loc)?//; + } else { + $path =~ s/^($loc)?\///; + } + } + + $self->path($path); + $self->parse_path; + $self->parse_args; } -sub call_authenticate { +=item parse_args + +=cut + +sub parse_args { my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); - return $self->authenticate(); + $self->params( { $self->_mod_perl_args( $self->ar ) } ); + $self->query( $self->params ); } -sub additional_data {} +=item redirect_request -sub authenticate { return OK } +Sets output headers to redirect based on the arguments provided -1; +Accepts either a single argument of the full url to redirect to, or a hash of +named parameters : -=head1 NAME +$r->redirect_request('http://www.example.com/path'); -Apache::MVC - Web front end to a data source +or -=head1 SYNOPSIS +$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..'); - package BeerDB; - use base 'Apache::MVC'; - sub handler { Apache::MVC::handler("BeerDB", @_) } - BeerDB->set_database("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 +The named parameters are protocol, domain, path, status and url - 1; +Only 1 named parameter is required but other than url, they can be combined as +required and current values (from the request) will be used in place of any +missing arguments. The url argument must be a full url including protocol and +can only be combined with status. -=head1 DESCRIPTION +=cut + +sub redirect_request { + my $r = shift; + my $redirect_url = $_[0]; + my $status = $MODPERL2 ? eval 'Apache2::Const::REDIRECT;' : + eval 'Apache::Constants::REDIRECT;'; # why have to eval this? + 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; -A large number of web programming tasks follow the same sort of pattern: -we have some data in a datasource, typically a relational database. We -have a bunch of templates provided by web designers. We have a number of -things we want to be able to do with the database - create, add, edit, -delete records, view records, run searches, and so on. We have a web -server which provides input from the user about what to do. Something in -the middle takes the input, grabs the relevant rows from the database, -performs the action, constructs a page, and spits it out. - -This module aims to be the most generic and extensible "something in the -middle". - -An example would help explain this best. You need to add a product -catalogue to a company's web site. Users need to list the products in -various categories, view a page on each product with its photo and -pricing information and so on, and there needs to be a back-end where -sales staff can add new lines, change prices, and delete out of date -records. So, you set up the database, provide some default templates -for the designers to customize, and then write an Apache handler like -this: - - package ProductDatabase; - use base 'Apache::MVC'; - __PACKAGE__->set_database("dbi:mysql:products"); - BeerDB->config->{uri_base} = "http://your.site/catalogue/"; - ProductDatabase::Product->has_a("category" => ProductDatabase::Category); - # ... - - sub authenticate { - my ($self, $request) = @_; - return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com"; - return OK if $request->{action} =~ /^(view|list)$/; - return DECLINED; + $redirect_url = URI->new; + $redirect_url->scheme($protocol); + $redirect_url->host($host); + $redirect_url->path($path); } - 1; + $status = $args{status} if ($args{status}); + } -You then put the following in your Apache config: + $r->ar->status($status); + $r->ar->headers_out->set('Location' => $redirect_url); + return OK; +} - - SetHandler perl-script - PerlHandler ProductDatabase - -And 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 do override templates on a -database-table-by-table basis, put the new template in -F>. +=item get_protocol -This will automatically give you C, C, C, C and -C commands; for instance, a product list, go to +=cut - http://your.site/catalogue/product/list +sub get_protocol { + my $self = shift; + my $protocol = ( $self->ar->protocol =~ m/https/i ) ? 'https' : 'http' ; + return $protocol; +} -For a full example, see the included "beer database" application. +=item send_output -=head1 HOW IT WORKS +=cut -There's some documentation for the workflow in L, -but the basic idea is that a URL part like C gets -translated into a call to Clist>. This -propagates the request with a set of objects from the database, and then -calls the C template; first, a C template if it -exists, then the C and finally C. +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 } + ); -If there's another action you want the system to do, you need to either -subclass the model class, and configure your class slightly differently: + foreach ($r->headers_out->field_names) { + next if /^Content-(Type|Length)/; + $r->ar->headers_out->set($_ => $r->headers_out->get($_)); + } - package ProductDatabase::Model; - use base 'Apache::MVC::Model::CDBI'; + $MODPERL2 || $r->ar->send_http_header; + $r->ar->print( $r->output ); +} - sub supersearch :Exported { - my ($self, $request) = @_; - # Do stuff, get a bunch of objects back - $r->objects(\@objects); - $r->template("template_name"); - } +=item get_template_root - ProductDatabase->config->{model_class} = "ProductDatabase::Model"; +=cut + +sub get_template_root { + my $r = shift; + $r->ar->document_root . "/" . $r->ar->location; +} -(The C<:Exported> attribute means that the method can be called via the -URL C/supersearch/...>.) +=back + +=cut + +######################################################### +# private / internal methods and subs + + +sub _mod_perl_args { + my ( $self, $apr ) = @_; + my %args; + if ($apr->isa('Apache::Request')) { + foreach my $key ( $apr->param ) { + my @values = $apr->param($key); + $args{$key} = @values == 1 ? $values[0] : \@values; + } + } else { + my $body = $self->_prepare_body($apr); + %args = %{$body->param}; + my $uri = URI->new($self->ar->unparsed_uri); + foreach my $key ($uri->query_param) { + if (ref $args{$key}) { + push (@{$args{$key}}, $uri->query_param($key)); + } else { + if ($args{$key}) { + $args{$key} = [ $args{$key}, $uri->query_param($key) ]; + } else { + my @args = $uri->query_param($key); + if (scalar @args > 1) { + $args{$key} = [ $uri->query_param($key) ]; + } else { + $args{$key} = $uri->query_param($key); + } + } + } + } + } + return %args; +} -Alternatively, you can put the method directly into the specific model -class for the table: +sub _prepare_body { + my ( $self, $r ) = @_; + + unless ($self->{__http_body}) { + my $content_type = $r->headers_in->get('Content-Type'); + my $content_length = $r->headers_in->get('Content-Length'); + my $body = HTTP::Body->new( $content_type, $content_length ); + my $length = $content_length; + while ( $length ) { + $r->read( my $buffer, ( $length < 8192 ) ? $length : 8192 ); + $length -= length($buffer); + $body->add($buffer); + } + $self->{__http_body} = $body; + } + return $self->{__http_body}; +} - sub ProductDatabase::Product::supersearch :Exported { ... } -By default, the view class uses Template Toolkit as the template -processor, and the model class uses C; it may help you to be -familiar with these modules before going much further with this, -although I expect there to be other subclasses for other templating -systems and database abstraction layers as time goes on. The article at -C is a great -introduction to the process we're trying to automate. =head1 AUTHOR Simon Cozens, C +=head1 CREDITS + +Aaron Trevena +Marcus Ramberg, C +Sebastian Riedel, C + =head1 LICENSE You may distribute this code under the same terms as Perl itself. + +=cut + +1;