X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=1442d0eccfa7a216d6e213c560ae1a8f2eec36c1;hb=a02686080acb66fce170e9657e110761b09e62a2;hp=031d9851e797e72497c0ec8681914dcd06766925;hpb=9b8f3c269605db27908000957b20cc3a336f9148;p=maypole.git diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index 031d985..1442d0e 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -1,6 +1,10 @@ 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; @@ -8,7 +12,7 @@ use Class::DBI::Plugin::RetrieveAll; use Class::DBI::Pager; use Lingua::EN::Inflect::Number qw(to_PL); -use CGI::Untaint; + use strict; =head1 NAME @@ -17,7 +21,7 @@ Maypole::Model::CDBI - Model class based on Class::DBI =head1 DESCRIPTION -This is a master model class which uses C to do all the hard +This is a master model class which uses L to do all the hard work of fetching rows and representing them as objects. It is a good model to copy if you're replacing it with other database abstraction modules. @@ -39,15 +43,17 @@ See L for these: =item setup_database +=item fetch_objects + =back -=head1 Additional Commands +=head1 Additional Actions =over =item delete -Surprisingly, this command causes a database record to be forever lost. +Unsuprisingly, this command causes a database record to be forever lost. =item search @@ -79,63 +85,119 @@ sub related { } sub related_class { - my ( $self, $r, $accessor ) = @_; - my $related = $self->related->{$accessor}; - if ( my $mapping = $related->{args}->{mapping} ) { - return $related->{foreign_class}->meta_info('has_a')->{ $$mapping[0] } - ->{foreign_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}; + } + } + + +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 { - return $related->{foreign_class}; + else + { + $r->template("view"); } + + $r->objects( $obj ? [$obj] : []); } -sub do_edit : Exported { - my ( $self, $r ) = @_; - my $h = CGI::Untaint->new( %{ $r->{params} } ); +# 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 ($obj) = @{ $r->objects || [] }; - if ($obj) { - + my $h = CGI::Untaint->new( %{$r->params} ); + + # update or create + if ($obj) + { # We have something to edit - $obj->update_from_cgi( $h => - { required => $r->{config}{ $r->{table} }{required_cols} || [], } - ); + eval { $obj->update_from_cgi( $h => { + required => $required_cols, + ignore => $ignored_cols, + } ) }; + $fatal = $@; } - else { - $obj = - $self->create_from_cgi( $h => - { required => $r->{config}{ $r->{table} }{required_cols} || [], } - ); + else + { + eval { + $obj = $self->create_from_cgi( $h => { + required => $required_cols, + ignore => $ignored_cols, + } ) + }; + + if ($fatal = $@) + { + warn "$fatal" if $r->debug; + } $creating++; } - if ( my %errors = $obj->cgi_update_errors ) { - - # Set it up as it was: - $r->{template_args}{cgi_params} = $r->{params}; - $r->{template_args}{errors} = \%errors; - $r->{template} = "edit"; - undef $obj if $creating; # Couldn't create - } - else { - $r->{template} = "view"; - } - $r->objects( [$obj] ); + + return $obj, $fatal, $creating; } sub delete : Exported { - return shift->SUPER::delete(@_) if caller ne "Maypole::Model::Base"; - my ( $self, $r ) = @_; - $_->SUPER::delete for @{ $r->objects || [] }; - $r->objects( [ $self->retrieve_all ] ); - $r->{template} = "list"; - $self->list($r); + my $self = shift; + my ($sub) = (caller(1))[3]; + $sub =~ /^(.+)::([^:]+)$/; + # So subclasses can still send search down ... + return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ? + $self->SUPER::search(@_) : $self->do_delete(@_); +} + +sub do_delete { + my ( $self, $r ) = @_; + $_->SUPER::delete for @{ $r->objects || [] }; + $r->objects( [ $self->retrieve_all ] ); + $r->{template} = "list"; + $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]; @@ -150,15 +212,22 @@ sub adopt { } sub search : Exported { - return shift->SUPER::search(@_) if caller ne "Maypole::Model::Base"; + my $self = shift; + my ($sub) = (caller(1))[3]; + $sub =~ /^(.+)::([^:]+)$/; + # So subclasses can still send search down ... + return ($1 ne "Maypole::Model::Base" && $2 ne "search") ? + $self->SUPER::search(@_) : $self->do_search(@_); +} - # A real CDBI search. +sub do_search : Exported { my ( $self, $r ) = @_; my %fields = map { $_ => 1 } $self->columns; my $oper = "like"; # For now my %params = %{ $r->{params} }; my %values = map { $_ => { $oper, $params{$_} } } - grep { length ($params{$_}) and $fields{$_} } keys %params; + grep { defined $params{$_} && length ($params{$_}) && $fields{$_} } + keys %params; $r->template("list"); if ( !%values ) { return $self->list($r) } @@ -185,12 +254,12 @@ sub do_pager { sub order { my ( $self, $r ) = @_; - my $order; my %ok_columns = map { $_ => 1 } $self->columns; - if ( $order = $r->query->{order} and $ok_columns{$order} ) { - $order .= ( $r->query->{o2} eq "desc" && " DESC" ); - } - $order; + my $q = $r->query; + my $order = $q->{order}; + return unless $order and $ok_columns{$order}; + $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc'; + return $order; } sub list : Exported { @@ -219,7 +288,7 @@ sub setup_database { dsn => $dsn, user => $u, password => $p, - options => $opts, + %$opts, ) ); $config->{classes} = [ $config->{loader}->classes ]; @@ -230,7 +299,18 @@ sub setup_database { sub class_of { my ( $self, $r, $table ) = @_; - return $r->config->loader->_table2class($table); + return $r->config->loader->_table2class($table); # why not find_class ? +} + +sub fetch_objects { + my ($class, $r)=@_; + my @pcs = $class->primary_columns; + if ( $#pcs ) { + my %pks; + @pks{@pcs}=(@{$r->{args}}); + return $class->retrieve( %pks ); + } + return $class->retrieve( $r->{args}->[0] ); } 1;