X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=b3223c4d7887c0235324e4971e01045cdd658b65;hb=e767951f92d57740dc76425868cce32f6bcf1296;hp=8de426a7ff409e610b94afaea9b978da39e3a678;hpb=0acf11b08135636930349a74d3cdf8b01c849496;p=maypole.git

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index 8de426a..b3223c4 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,209 +13,97 @@ 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<Maypole::Model::Base> for these:
-
-=over 4
 
-=item adopt
+It inherits accessor and helper methods from L<Maypole::Model::Base>.
 
-=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<Maypole::Model::CDBI::Plain> which
+will instead use Class::DBI classes provided.
 
-=item do_edit
+=cut
 
-=item list
+use base qw(Maypole::Model::CDBI::Base);
+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
 
-=item fetch_objects
+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
 
-=back 
+=cut
 
-=head1 Additional Actions
+sub Untainter { 'CGI::Untaint::Maypole' };
 
-=over 
+=head2 add_model_superclass
 
-=item delete
+Adds model as superclass to model classes (if necessary)
 
-Unsuprisingly, this command causes a database record to be forever lost.
+Inherited from Maypole::Model::CDBI::Base
 
-=item search
+=head1 Action Methods
 
-The search action 
+Action methods are methods that are accessed through web (or other public) interface.
 
-=back
+Inherited from L<Maypole::Model::CDBI::Base>
 
-=head1 Helper Methods
+=head2 do_edit
 
-=over 
+If there is an object in C<$r-E<gt>objects>, then it should be edited
+with the parameters in C<$r-E<gt>params>; otherwise, a new object should
+be created with those parameters, and put back into C<$r-E<gt>objects>.
+The template should be changed to C<view>, or C<edit> if there were any
+errors. A hash of errors will be passed to the template.
 
-=item order
+=head2 do_delete
 
-=item stringify_column
+Inherited from Maypole::Model::CDBI::Base.
 
-=item do_pager
+This action deletes records
 
-=item related_class
+=head2 do_search
 
-Given an accessor name as a method, this function returns the class this accessor returns.
+Inherited from Maypole::Model::CDBI::Base.
 
-=back
+This action method searches for database records.
 
-=cut
+=head2 list
 
-sub related {
-    my ( $self, $r ) = @_;
-    return keys %{ $self->meta_info('has_many') || {} };
-}
+Inherited from Maypole::Model::CDBI::Base.
 
-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 C<list> method fills C<$r-E<gt>objects> with all of the
+objects in the class. The results are paged using a pager.
 
+=head1 Helper Methods
 
-sub do_edit : Exported {
-    my ( $self, $r ) = @_;
-    my $h        = CGI::Untaint->new( %{ $r->{params} } );
-    my $creating = 0;
-    my ($obj) = @{ $r->objects || [] };
-    my $fatal;
-    if ($obj) {
-        # We have something to edit
-        eval {
-            $obj->update_from_cgi( $h =>
-                { required => $r->{config}{ $r->{table} }{required_cols} || [], }
-            );
-        };
-        $fatal = $@;
-    }
-    else {
-        eval {
-            $obj =
-                $self->create_from_cgi( $h =>
-                    { required => $r->{config}{ $r->{table} }{required_cols} || [], }
-            );
-        };
-        if ($fatal = $@) {
-            warn "$fatal" if $r->debug;
-        }
-        $creating++;
-    }
-    if ( my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_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] : []);
-}
-
-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);
-}
-
-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 setup
 
-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 { 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 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 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 }
-}
+=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
+
+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 ) = @_;
@@ -250,24 +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);
+    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
+
+L<Maypole>, L<Maypole::Model::CDBI::Base>.
+
+=head1 AUTHOR
+
+Maypole is currently maintained by Aaron Trevena.
+
+=head1 AUTHOR EMERITUS
+
+Simon Cozens, C<simon#cpan.org>
+
+Simon Flack maintained Maypole from 2.05 to 2.09
+
+Sebastian Riedel, C<sri#oook.de> 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;