From: Aaron Trevena Date: Mon, 9 Jan 2006 16:38:16 +0000 (+0000) Subject: fixed bug 16869 - forced inheritance of model X-Git-Tag: 2.11~74 X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=commitdiff_plain;h=41a93152a01bdeab5ada42fd423f985554ade78e fixed bug 16869 - forced inheritance of model git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@444 48953598-375a-da11-a14b-00016c27c3ee --- diff --git a/Changes b/Changes index 8692886..fd9999a 100644 --- a/Changes +++ b/Changes @@ -55,7 +55,7 @@ Bug fixes: Fix to cgi_maypole.t (bug 11346) Fix to TT error reporting (bug 13991) Template xhtml validation (bug 13975) - Apache2 fix in Apache::MVC (bug 13888) + Apache2 fixes in Apache::MVC (bug 13888) Fixed inheritance issues in Mp::Application - Mp::App now manipulates the caller's @ISA directly, and doesn't inject itself into the chain (bugs 12923 & 14120) @@ -66,6 +66,8 @@ Bug fixes: Fixed related_class() method (bug 14566) Added a cgi() attribute in Maypole::CGI Factory templates now less vulnerable to XSS (bug 16659) + Reduced risk of XSS in factory templates (bug 16659) + model search/delete methods in model and subclassing the cdbi mode (bug 16661) Documentation: Fix to documentation for CGI::Maypole (bug 7263) @@ -79,6 +81,8 @@ Documentation: - updated Maypole::Manual::View - updated Maypole::View:TT +Requirements: + HTTP::Body now required 2.10 Tue 19 Jul 2005 diff --git a/MANIFEST b/MANIFEST index be5dea4..a578fbb 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3,6 +3,7 @@ ex/BeerDB.pm ex/beerdb.sql lib/Apache/MVC.pm lib/CGI/Maypole.pm +lib/CGI/Untaint/Maypole.pm lib/Maypole.pm lib/Maypole/Application.pm lib/Maypole/CLI.pm @@ -26,6 +27,7 @@ lib/Maypole/Manual/Plugins.pod lib/Maypole/Model/Base.pm lib/Maypole/Model/CDBI.pm lib/Maypole/Model/CDBI/Plain.pm +lib/Maypole/Model/CDBI/AsForm.pm lib/Maypole/View/Base.pm lib/Maypole/View/TT.pm Makefile.PL diff --git a/Makefile.PL b/Makefile.PL index ec2a92a..e5833cb 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -23,12 +23,11 @@ WriteMakefile( URI::QueryParam => 0, CGI::Simple => 0, HTTP::Headers => 1.59, + HTTP::Body => 0.5, Template => 0, Template::Plugin::Class => 0, Test::MockModule => 0, Digest::MD5 => 0, - HTTP::Server::Simple => 0.02, - HTTP::Server::Simple::Static => 0.01, }, # e.g., Module::Name => 1.1 ( $] >= 5.005 diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 4623b9f..ddd742b 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,6 +1,6 @@ package Apache::MVC; -our $VERSION = '2.10'; +our $VERSION = '2.11'; use strict; use warnings; @@ -11,23 +11,30 @@ use Maypole::Constants; __PACKAGE__->mk_accessors( qw( ar ) ); +our $MODPERL2; +our $modperl_version; + BEGIN { - my $version; - eval 'use mod_perl2; $version = $mod_perl2::VERSION; '; + eval 'use Apache;'; if ($@) { - use mod_perl; - $version = 0; + eval 'use mod_perl2; $modperl_version = $mod_perl2::VERSION; '; + if ($@) { + $modperl_version = $Apache2::RequestRec::VERSION; + } + require Apache2::RequestIO; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require APR::URI; + require HTTP::Body; + $MODPERL2 = 1; + } else { + eval ' use mod_perl; '; require Apache; require Apache::Request; - } else { - require Apache2::RequestIO; - require Apache2::RequestRec; - require Apache2::RequestUtil; - require APR::URI; - require Apache2::Request; + $MODPERL2 = 0; + $modperl_version = 1; } - use constant APACHE2 => $version; } =head1 NAME @@ -82,7 +89,7 @@ functionality. See L for these: sub get_request { my ($self, $r) = @_; - my $ar = (APACHE2) ? Apache2::Request->new($r) : Apache::Request->instance($r); + my $ar = ($MODPERL2) ? $r : Apache::Request->instance($r); $self->ar($ar); } @@ -96,7 +103,7 @@ sub parse_location { # Reconstruct the request headers $self->headers_in(Maypole::Headers->new); my %headers; - if (APACHE2) { %headers = %{$self->ar->headers_in}; + if ($MODPERL2) { %headers = %{$self->ar->headers_in}; } else { %headers = $self->ar->headers_in; } for (keys %headers) { $self->headers_in->set($_, $headers{$_}); @@ -182,7 +189,7 @@ sub send_output { $r->ar->headers_out->set($_ => $r->headers_out->get($_)); } - APACHE2 || $r->ar->send_http_header; + $MODPERL2 || $r->ar->send_http_header; $r->ar->print( $r->output ); } @@ -195,23 +202,56 @@ sub get_template_root { $r->ar->document_root . "/" . $r->ar->location; } +=back + +=cut + +######################################################### +# private / internal methods and subs + + sub _mod_perl_args { my ( $self, $apr ) = @_; my %args; - foreach my $key ( $apr->param ) { + 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}; } return %args; } -1; +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}; +} + -=back =head1 AUTHOR Simon Cozens, C + +=head1 CREDITS + +Aaron Trevena Marcus Ramberg, C Sebastian Riedel, C @@ -220,3 +260,5 @@ Sebastian Riedel, C You may distribute this code under the same terms as Perl itself. =cut + +1; diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 119a85a..c18f695 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -306,15 +306,16 @@ sub setup_model foreach my $subclass ( @{ $config->classes } ) { - no strict 'refs'; - unshift @{ $subclass . "::ISA" }, $config->model; - - # Load custom model code, if it exists - nb this must happen after the - # unshift, to allow code attributes to work, but before adopt(), - # in case adopt() calls overridden methods on $subclass - $class->load_model_subclass($subclass); - - $config->model->adopt($subclass) if $config->model->can("adopt"); + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + unshift @{ $subclass . "::ISA" }, $config->model; + + # Load custom model code, if it exists - nb this must happen after the + # unshift, to allow code attributes to work, but before adopt(), + # in case adopt() calls overridden methods on $subclass + $class->load_model_subclass($subclass); + + $config->model->adopt($subclass) if $config->model->can("adopt"); } } diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index 1442d0e..dd9af06 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -1,18 +1,4 @@ package Maypole::Model::CDBI; -use base qw(Maypole::Model::Base Class::DBI); -use Class::DBI::AsForm; -# use Maypole::Form::CDBI; -use CGI::Untaint; -# use Maypole::Form; - -use Class::DBI::FromCGI; -use Class::DBI::Loader; -use Class::DBI::AbstractSearch; -use Class::DBI::Plugin::RetrieveAll; -use Class::DBI::Pager; - -use Lingua::EN::Inflect::Number qw(to_PL); - use strict; =head1 NAME @@ -27,154 +13,117 @@ model to copy if you're replacing it with other database abstraction modules. It implements a base set of methods required for a Maypole Data Model. -See L for these: - -=over 4 -=item adopt - -=item class_of - -=item do_edit +It inherits accessor and helper methods from L. -=item list +=cut -=item related +use base qw(Maypole::Model::Base Class::DBI); +use Maypole::Model::CDBI::AsForm; +use CGI::Untaint::Maypole; -=item setup_database +use Class::DBI::FromCGI; +use Class::DBI::Loader; +use Class::DBI::AbstractSearch; +use Class::DBI::Plugin::RetrieveAll; +use Class::DBI::Pager; -=item fetch_objects +use Lingua::EN::Inflect::Number qw(to_PL); -=back -=head1 Additional Actions +############################################################################### +# Helper methods -=over +=head1 Action Methods -=item delete +Action methods are methods that are accessed through web (or other public) interface. -Unsuprisingly, this command causes a database record to be forever lost. +=item do_edit -=item search +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. -The search action +=cut -=back +sub do_edit : Exported { + my ($self, $r, $obj) = @_; -=head1 Helper Methods + my $config = $r->config; + my $table = $r->table; -=over + # handle cancel button hits + if ( $r->{params}->{cancel} ) { + $r->template("list"); + $r->objects( [$self->retrieve_all] ); + return; + } -=item order + my $required_cols = $config->{$table}->{required_cols} || []; + my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || []; -=item stringify_column + ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); -=item do_pager + # handle errors, if none, proceed to view the newly created/updated object + my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; -=item related_class + if (%errors) { + # Set it up as it was: + $r->template_args->{cgi_params} = $r->params; + $r->template_args->{errors} = \%errors; -Given an accessor name as a method, this function returns the class this accessor returns. + undef $obj if $creating; + $r->template("edit"); + } else { + $r->template("view"); + } -=back + $r->objects( $obj ? [$obj] : []); +} -=cut +# split out from do_edit to be reported by Mp::P::Trace +sub _do_update_or_create { + my ($self, $r, $obj, $required_cols, $ignored_cols) = @_; + + my $fatal; + my $creating = 0; + my $h = CGI::Untaint::Maypole->new( %{$r->params} ); + + # update or create + if ($obj) { + # We have something to edit + eval { $obj->update_from_cgi( $h => { + required => $required_cols, + ignore => $ignored_cols, + } ) }; + $fatal = $@; + } else { + eval { + $obj = $self->create_from_cgi( $h => { + required => $required_cols, + ignore => $ignored_cols, + } ) + }; + + if ($fatal = $@) { + warn "$fatal" if $r->debug; + } + $creating++; + } -sub related { - my ( $self, $r ) = @_; - return keys %{ $self->meta_info('has_many') || {} }; + return $obj, $fatal, $creating; } -sub related_class { - my ( $self, $r, $accessor ) = @_; - my $meta = $self->meta_info; - my @rels = keys %$meta; - my $related; - foreach (@rels) { - $related = $meta->{$_}{$accessor}; - last if $related; - } - return unless $related; - my $mapping = $related->{args}->{mapping}; - if ( $mapping and @$mapping ) { - return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class}; - } - else { - return $related->{foreign_class}; - } - } +=head2 do_delete +Unsuprisingly, this command causes a database record to be forever lost. -sub do_edit : Exported -{ - my ($self, $r, $obj) = @_; - - my $config = $r->config; - my $table = $r->table; - - my $required_cols = $config->{$table}->{required_cols} || []; - my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols}; - - ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols); - - # handle errors, if none, proceed to view the newly created/updated object - my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors; - - if (%errors) - { - # Set it up as it was: - $r->template_args->{cgi_params} = $r->params; - $r->template_args->{errors} = \%errors; - - undef $obj if $creating; - $r->template("edit"); - } - else - { - $r->template("view"); - } - - $r->objects( $obj ? [$obj] : []); -} +This method replaces the, now deprecated, delete method provided in prior versions -# drb - I've (probably temporarily) split this out from do_edit, so it's -# reported by Mp::P::Trace -sub _do_update_or_create -{ - my ($self, $r, $obj, $required_cols, $ignored_cols) = @_; - - my $fatal; - my $creating = 0; - my $h = CGI::Untaint->new( %{$r->params} ); - - # update or create - if ($obj) - { - # We have something to edit - eval { $obj->update_from_cgi( $h => { - required => $required_cols, - ignore => $ignored_cols, - } ) }; - $fatal = $@; - } - else - { - eval { - $obj = $self->create_from_cgi( $h => { - required => $required_cols, - ignore => $ignored_cols, - } ) - }; - - if ($fatal = $@) - { - warn "$fatal" if $r->debug; - } - $creating++; - } - - return $obj, $fatal, $creating; -} +=cut sub delete : Exported { my $self = shift; @@ -193,23 +142,13 @@ sub do_delete { $self->list($r); } -sub stringify_column { - my $class = shift; - return ( - $class->columns("Stringify"), - ( grep { /^(name|title)$/i } $class->columns ), - ( grep { /(name|title)/i } $class->columns ), - ( grep { !/id$/i } $class->primary_columns ), - )[0]; -} -sub adopt { - my ( $self, $child ) = @_; - $child->autoupdate(1); - if ( my $col = $child->stringify_column ) { - $child->columns( Stringify => $col ); - } -} +=head2 do_search + +This action method searches for database records, it replaces +the, now deprecated, search method previously provided. + +=cut sub search : Exported { my $self = shift; @@ -243,6 +182,292 @@ sub do_search : Exported { $r->{template_args}{search} = 1; } +=head2 list + +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. + +=cut + +sub list : Exported { + my ( $self, $r ) = @_; + my $order = $self->order($r); + $self = $self->do_pager($r); + if ($order) { + $r->objects( [ $self->retrieve_all_sorted_by($order) ] ); + } + else { + $r->objects( [ $self->retrieve_all ] ); + } +} + +####################### +# _process_local_srch # +####################### + +# Makes the local part of the db search query +# Puts search prams local to this table in where array. +# Returns a where array ref and search criteria string. +# This is factored out of do_search so sub classes can override this part +sub _process_local_srch { + my ($self, $hashed) = @_; + my %fields = map { $_ => 1 } $self->columns; + my $moniker = $self->moniker; + my %colnames = $self->column_names; + my $srch_crit = ''; + my ($oper, $wc); + my @where = map { + # prelim + $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'"; + $oper = $self->sql_search_oper($_); + $wc = $oper =~ /LIKE/i ? '%':''; # match any substr + "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause + } + grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} } + keys %$hashed; + + return (\@where, $srch_crit); +} + +######################### +# _process_foreign_srch # +######################### + +# puts foreign search fields into select statement +# changes @where by ref and return sel and srch_criteria string +sub _process_foreign_srch { + my ($self, $hashed, $sel, $where, $srch_crit) = @_; + my %colnames = $self->column_names; + my $moniker = $self->moniker; + my %foreign; + foreach (keys %$hashed) { + $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_}; + } + my %accssr_class = %{$self->accessor_classes}; + while (my ( $accssr, $prms) = each %foreign ) { + my $fclass = $accssr_class{$accssr}; + my %fields = map { $_ => 1 } $fclass->columns; + my %colnames = $fclass->column_names; + my ($oper, $wc); + my @this_where = + # TODO make field name match in all cases in srch crit + map { + # prelim + $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'"; + $oper = $fclass->sql_search_oper($_); + $wc = $oper =~ /LIKE/i ? '%':''; + "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where + } + grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} } + keys %$prms; + + next unless @this_where; + $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from + + # map relationships -- TODO use constraints in has_many and mhaves + # and make general + my $pk = $self->primary_column; + if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) { + unshift @this_where, ("$accssr.owner_id = $moniker.$pk", + "$accssr.owner_table = '" . $self->table ."'"); + } + # for has_own, has_a where foreign id is in self's table + elsif ( my $fk = $self->find_column($fclass->primary_column) ) { + unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name; + } + push @$where, @this_where; + } + return ($sel, $srch_crit); +} + +############################################################################### +# Helper methods + +=head1 Helper Methods + + +=head2 adopt + +This class method is passed the name of a model class that represensts a table +and allows the master model class to do any set-up required. + +=cut + +sub adopt { + my ( $self, $child ) = @_; + $child->autoupdate(1); + if ( my $col = $child->stringify_column ) { + $child->columns( Stringify => $col ); + } +} + +=head2 is_public + +Should return true if a certain action is supported, or false otherwise. +Defaults to checking if the sub has the C<:Exported> attribute. + +=cut + +sub is_public { + my ( $self, $action, $attrs ) = @_; + my $cv = $self->can($action); + warn "is_public failed . action is $action. self is $self" and return 0 unless $cv; + unless ($attrs) { + my @attrs = attributes::get($cv) || (); + $attrs = join " ", @attrs; + } + do { + warn "is_public failed .$action not exported" if Maypole->debug; + return 0; + } unless $attrs =~ /\bExported\b/i; + return 1; +} + + +=head2 is_class + +Tell if action is a class method (See Maypole::Plugin::Menu) + +=cut + +sub is_class { + my ( $self, $method, $attrs ) = @_; + die "Usage: method must be passed as first arg" unless $method; + $attrs = $self->method_attrs($method) unless ($attrs); + return 1 if $attrs =~ /\bClass\b/i; + return 1 if $method =~ /^list$/; # default class actions + return 0; +} + +=head2 is_object + +Tell if action is a object method (See Maypole::Plugin::Menu) + +=cut + +sub is_object { + my ( $self, $method, $attrs ) = @_; + die "Usage: method must be passed as first arg" unless $method; + $attrs = $self->method_attrs($method) unless ($attrs); + return 1 if $attrs =~ /\bObject\b/i; + return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions + return 0; +} + +# Get string of joined attributes for matching +sub method_attrs { + my ($class, $method) = @_; + my $cv = $class->can($method); + return 0 unless $cv; + my @attrs = attributes::get($cv) || (); + return join " ", @attrs; +} + +=head2 related + +This method returns a list of has-many accessors. A brewery has many +beers, so C needs to return C. + +=cut + +sub related { + my ( $self, $r ) = @_; + return keys %{ $self->meta_info('has_many') || {} }; +} + + +=head2 related_class + +Given an accessor name as a method, this function returns the class this accessor returns. + +=cut + +sub related_class { + my ( $self, $r, $accessor ) = @_; + my $meta = $self->meta_info; + my @rels = keys %$meta; + my $related; + foreach (@rels) { + $related = $meta->{$_}{$accessor}; + last if $related; + } + return unless $related; + + my $mapping = $related->{args}->{mapping}; + if ( $mapping and @$mapping ) { + return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class}; + } + else { + return $related->{foreign_class}; + } + } + +=head2 isa_class + +Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels) + +=cut + +sub isa_class { + my ($class, $col) = @_; + $class->_croak( "Need a column for isa_class." ) unless $col; + my $isaclass; + # class col is first found in is returned + my $isa = $class->meta_info("is_a") || {}; + foreach ( keys %$isa ) { + $isaclass = $isa->{$_}->foreign_class; + return $isaclass if ($isaclass->find_column($col)); + } + return 0; # col not in a is_a class +} + +=head2 accessor_classes + +Returns hash ref of classes for accessors. + +This is an attempt at a more efficient method than calling "related_class()" +a bunch of times when you need it for many relations. + +=cut + +sub accessor_classes { + my ($self, $class) = @_; # can pass a class arg to get accssor classes for + $class ||= $self; + my $meta = $class->meta_info; + my %res; + foreach my $rel (keys %$meta) { + my $rel_meta = $meta->{$rel}; + %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} } + keys %$rel_meta ); + } + return \%res; + + # 2 liner to get class of accessor for $name + #my $meta = $class->meta_info; + #my ($isa) = map $_->foreign_class, grep defined, + # map $meta->{$_}->{$name}, keys %$meta; + +} + + +=head2 stringify_column + +=cut + +sub stringify_column { + my $class = shift; + return ( + $class->columns("Stringify"), + ( grep { /^(name|title)$/i } $class->columns ), + ( grep { /(name|title)/i } $class->columns ), + ( grep { !/id$/i } $class->primary_columns ), + )[0]; +} + +=head2 do_pager + +=cut + sub do_pager { my ( $self, $r ) = @_; if ( my $rows = $r->config->rows_per_page ) { @@ -252,6 +477,11 @@ sub do_pager { else { return $self } } + +=head2 order + +=cut + sub order { my ( $self, $r ) = @_; my %ok_columns = map { $_ => 1 } $self->columns; @@ -262,17 +492,9 @@ sub order { return $order; } -sub list : Exported { - my ( $self, $r ) = @_; - my $order = $self->order($r); - $self = $self->do_pager($r); - if ($order) { - $r->objects( [ $self->retrieve_all_sorted_by($order) ] ); - } - else { - $r->objects( [ $self->retrieve_all ] ); - } -} +=head2 setup_database + +=cut sub setup_database { my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_; @@ -313,4 +535,15 @@ sub fetch_objects { return $class->retrieve( $r->{args}->[0] ); } + +############################################################################### +# private / internal functions and classes + +sub _column_info { + my $class = shift; + $class = ref $class || $class; + no strict 'refs'; + return ${$class . '::COLUMN_INFO'}; +} + 1;