X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=b3223c4d7887c0235324e4971e01045cdd658b65;hb=e767951f92d57740dc76425868cce32f6bcf1296;hp=dd9af06c71472df111a129e51bda562173becf65;hpb=41a93152a01bdeab5ada42fd423f985554ade78e;p=maypole.git diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index dd9af06..b3223c4 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -16,29 +16,44 @@ It implements a base set of methods required for a Maypole Data Model. It inherits accessor and helper methods from L. +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. + =cut -use base qw(Maypole::Model::Base Class::DBI); +use base qw(Maypole::Model::CDBI::Base); +use Data::Dumper; +use Class::DBI::Loader; +use attributes (); + use Maypole::Model::CDBI::AsForm; +use Maypole::Model::CDBI::FromCGI; use CGI::Untaint::Maypole; -use Class::DBI::FromCGI; -use Class::DBI::Loader; -use Class::DBI::AbstractSearch; -use Class::DBI::Plugin::RetrieveAll; -use Class::DBI::Pager; +=head2 Untainter -use Lingua::EN::Inflect::Number qw(to_PL); +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 +=cut -############################################################################### -# Helper methods +sub Untainter { 'CGI::Untaint::Maypole' }; + +=head2 add_model_superclass + +Adds model as superclass to model classes (if necessary) + +Inherited from Maypole::Model::CDBI::Base =head1 Action Methods Action methods are methods that are accessed through web (or other public) interface. -=item do_edit +Inherited from L + +=head2 do_edit 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 @@ -46,454 +61,48 @@ 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. -=cut - -sub do_edit : Exported { - my ($self, $r, $obj) = @_; - - my $config = $r->config; - my $table = $r->table; - - # handle cancel button hits - if ( $r->{params}->{cancel} ) { - $r->template("list"); - $r->objects( [$self->retrieve_all] ); - return; - } - - 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] : []); -} - -# 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++; - } - - return $obj, $fatal, $creating; -} - - =head2 do_delete -Unsuprisingly, this command causes a database record to be forever lost. - -This method replaces the, now deprecated, delete method provided in prior versions - -=cut - -sub delete : Exported { - 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); -} +Inherited from Maypole::Model::CDBI::Base. +This action deletes records =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; - 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(@_); -} +Inherited from Maypole::Model::CDBI::Base. -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 { defined $params{$_} && length ($params{$_}) && $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; -} +This action method searches for database records. =head2 list +Inherited from Maypole::Model::CDBI::Base. + 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 setup -=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. + 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. =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 +=head2 setup_database -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}; - } +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, + ... } -=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 ) { - return $r->{template_args}{pager} = - $self->pager( $rows, $r->query->{page} ); - } - else { return $self } -} - - -=head2 order - -=cut - -sub order { - my ( $self, $r ) = @_; - my %ok_columns = map { $_ => 1 } $self->columns; - 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; -} - -=head2 setup_database - =cut sub setup_database { @@ -515,35 +124,44 @@ sub setup_database { ); $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); # 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] ); -} +=head1 SEE ALSO -############################################################################### -# private / internal functions and classes +L, L. -sub _column_info { - my $class = shift; - $class = ref $class || $class; - no strict 'refs'; - return ${$class . '::COLUMN_INFO'}; -} +=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;