X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FApache%2FMVC.pm;h=c9d6a32c762e4c11dc19babf369df6904061a2dd;hb=fdef988c4b6e0c95310edfed99bcb1bb959a6da4;hp=c9db3ae415008cf9dcf1613abdf95d90fe766515;hpb=ce6a4c9c85fd9ea388abc677089564bc46e687be;p=maypole.git diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index c9db3ae..c9d6a32 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,195 +1,181 @@ 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.10'; + use strict; use warnings; -our $VERSION = "0.1"; -__PACKAGE__->mk_classdata($_) for qw( _config init_done view_object ); -__PACKAGE__->mk_accessors ( qw( config ar params 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, @_) }; - } -} - -# This is really dirty. -sub config { - my $self = shift; - if (ref $self) { return $self->_config_accessor(@_) } - return $self->_config(@_); -} -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 base 'Maypole'; +use Maypole::Headers; + +__PACKAGE__->mk_accessors( qw( ar ) ); + +BEGIN { + my $version; + eval 'use mod_perl2; $version = $mod_perl2::VERSION; '; + if ($@) { + warn "no mod_perl 2.x using mod_perl 1.x\n"; + 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; } -} - -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); -} + use constant APACHE2 => $version; -sub class_of { - my ($self, $table) = @_; - return $self->config->{loader}->_table2class($table); -} - -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(); - - warn "Parsed location\n"; - $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 { - warn "Plain template $r->{path}"; - # Otherwise, it's just a plain template. - delete $r->{model_class}; - $r->{path} =~ s{/}{}; # De-absolutify - $r->template($r->{path}); - warn $r->template; - } - return $r->view_object->process($r); } sub get_request { - my $self = shift; - require Apache; require Apache::Request; - $self->{ar} = Apache::Request->new(Apache->request); + my ( $self, $r ) = @_; + $self->{ar} = (APACHE2) ? Apache2::Request->new($r) : 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; - $self->{path} =~ s/^$loc//; # I shouldn't need to do this? - warn "Path is $self->{path}"; - 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 }; + no warnings 'uninitialized'; + $self->{path} .= '/' if $self->{path} eq $loc; + $self->{path} =~ s/^($loc)?\///; + $self->parse_path; + $self->parse_args; } -sub is_applicable { +sub parse_args { 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(); + $self->{params} = { $self->_mod_perl_args( $self->{ar} ) }; + $self->{query} = { $self->_mod_perl_args( $self->{ar} ) }; } -sub call_authenticate { - my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); - return $self->authenticate(); +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 additional_data {} +sub get_template_root { + my $r = shift; + $r->{ar}->document_root . "/" . $r->{ar}->location; +} -sub authenticate { return OK } +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 - Web front end to a data source +Apache::MVC - Apache front-end to Maypole =head1 SYNOPSIS 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]]; + 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; -=haed1 DESCRIPTION - -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 MyCorp::ProductDatabase; - use base 'Apache::MVC'; - __PACKAGE__->set_database("dbi:mysql:products"); +=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 above. + +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 do 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, 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 it's +functionality. See L 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 +Marcus Ramberg, C +Screwed up by Sebastian Riedel, C + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. +=cut