X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=cc78879df3a2ac73316381147882fc458d0de11b;hb=dcc33148f1b562834e16f658e34270f3f581833c;hp=031d9851e797e72497c0ec8681914dcd06766925;hpb=9b8f3c269605db27908000957b20cc3a336f9148;p=maypole.git diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index 031d985..cc78879 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -1,14 +1,4 @@ package Maypole::Model::CDBI; -use base qw(Maypole::Model::Base Class::DBI); -use Class::DBI::AsForm; -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 CGI::Untaint; use strict; =head1 NAME @@ -17,193 +7,104 @@ 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. It implements a base set of methods required for a Maypole Data Model. -See L for these: - -=over 4 -=item adopt +It inherits accessor and helper methods from L. -=item class_of +When specified as the application model, it will use Class::DBI::Loader +to generate the model classes from the provided database. If you do not +wish to use this functionality, use L which +will instead use Class::DBI classes provided. -=item do_edit +=cut -=item list +use base qw(Maypole::Model::CDBI::Base); +use Class::C3; +use Data::Dumper; +use Class::DBI::Loader; +use attributes (); -=item related +use Maypole::Model::CDBI::AsForm; +use Maypole::Model::CDBI::FromCGI; +use CGI::Untaint::Maypole; -=item setup_database +=head2 Untainter -=back +Set the class you use to untaint and validate form data +Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint -=head1 Additional Commands +=cut -=over +sub Untainter { 'CGI::Untaint::Maypole' }; -=item delete +=head2 add_model_superclass -Surprisingly, this command causes a database record to be forever lost. +Adds model as superclass to model classes (if necessary) -=item search +Inherited from Maypole::Model::CDBI::Base -The search action +=head1 Action Methods -=back +Action methods are methods that are accessed through web (or other public) interface. -=head1 Helper Methods +Inherited from L -=over +=head2 do_edit -=item order +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. -=item stringify_column +=head2 do_delete -=item do_pager +Inherited from Maypole::Model::CDBI::Base. -=item related_class +This action deletes records -Given an accessor name as a method, this function returns the class this accessor returns. +=head2 do_search -=back +Inherited from Maypole::Model::CDBI::Base. -=cut +This action method searches for database records. -sub related { - my ( $self, $r ) = @_; - return keys %{ $self->meta_info('has_many') || {} }; -} +=head2 list -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}; - } - else { - return $related->{foreign_class}; - } -} +Inherited from Maypole::Model::CDBI::Base. -sub do_edit : Exported { - my ( $self, $r ) = @_; - my $h = CGI::Untaint->new( %{ $r->{params} } ); - my $creating = 0; - my ($obj) = @{ $r->objects || [] }; - if ($obj) { - - # We have something to edit - $obj->update_from_cgi( $h => - { required => $r->{config}{ $r->{table} }{required_cols} || [], } - ); - } - else { - $obj = - $self->create_from_cgi( $h => - { required => $r->{config}{ $r->{table} }{required_cols} || [], } - ); - $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] ); -} +The C method fills C<$r-Eobjects> with all of the +objects in the class. The results are paged using a pager. -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); -} +=head1 Helper Methods -sub stringify_column { - my $class = shift; - return ( - $class->columns("Stringify"), - ( grep { /(name|title)/i } $class->columns ), - ( grep { !/id$/i } $class->primary_columns ), - )[0]; -} +=head2 setup -sub adopt { - my ( $self, $child ) = @_; - $child->autoupdate(1); - if ( my $col = $child->stringify_column ) { - $child->columns( Stringify => $col ); - } -} + This method is inherited from Maypole::Model::Base and calls setup_database, + which uses Class::DBI::Loader to create and load Class::DBI classes from + the given database schema. -sub search : Exported { - return shift->SUPER::search(@_) if caller ne "Maypole::Model::Base"; - - # A real CDBI search. - 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; - - $r->template("list"); - if ( !%values ) { return $self->list($r) } - my $order = $self->order($r); - $self = $self->do_pager($r); - $r->objects( - [ - $self->search_where( - \%values, ( $order ? { order_by => $order } : () ) - ) - ] - ); - $r->{template_args}{search} = 1; -} +=cut -sub do_pager { - my ( $self, $r ) = @_; - if ( my $rows = $r->config->rows_per_page ) { - return $r->{template_args}{pager} = - $self->pager( $rows, $r->query->{page} ); - } - else { return $self } -} +=head2 setup_database -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; -} +The $opts argument is a hashref of options. The "options" key is a hashref of +Database connection options . Other keys may be various Loader arguments or +flags. It has this form: + { + # DB connection options + options { AutoCommit => 1 , ... }, + # Loader args + relationships => 1, + ... + } -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 ] ); - } -} +=cut sub setup_database { my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_; @@ -219,18 +120,49 @@ sub setup_database { dsn => $dsn, user => $u, password => $p, - options => $opts, + %$opts, ) ); $config->{classes} = [ $config->{loader}->classes ]; $config->{tables} = [ $config->{loader}->tables ]; - warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } ) + + my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} }; + warn( 'Loaded tables to classes: ' . join ', ', @table_class ) if $namespace->debug; } +=head2 class_of + + returns class for given table + +=cut + sub class_of { my ( $self, $r, $table ) = @_; - return $r->config->loader->_table2class($table); + return $r->config->loader->_table2class($table); # why not find_class ? } + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Maypole is currently maintained by Aaron Trevena. + +=head1 AUTHOR EMERITUS + +Simon Cozens, C + +Simon Flack maintained Maypole from 2.05 to 2.09 + +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + 1;