1 package Maypole::Model::CDBI::DFV;
6 Maypole::Model::CDBI::DFV - Class::DBI::DFV model for Maypole.
11 use 'Maypole::Application';
13 Foo->config->model("Maypole::Model::CDBI::DFV");
14 Foo->setup([qw/ Foo::SomeTable Foo::Other::Table /]);
16 # Look ma, no untainting
18 sub Foo::SomeTable::SomeAction : Exported {
26 This module allows you to use Maypole with previously set-up
27 L<Class::DBI> classes that use Class::DBI::DFV;
29 Simply call C<setup> with a list reference of the classes you're going to use,
30 and Maypole will work out the tables and set up the inheritance relationships
33 Better still, it will also set use your DFV profile to validate input instead
34 of CGI::Untaint. For teh win!!
40 use Data::FormValidator;
41 use Maypole::Model::CDBI::AsForm;
43 use base qw(Maypole::Model::Base);
45 Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO));
51 This method is inherited from Maypole::Model::Base and calls setup_database,
52 which uses Class::DBI::Loader to create and load Class::DBI classes from
53 the given database schema.
57 This method loads the model classes for the application
62 my ( $self, $config, $namespace, $classes ) = @_;
63 $config->{classes} = $classes;
64 foreach my $class (@$classes) { $namespace->load_model_subclass($class); }
65 $namespace->model_classes_loaded(1);
66 $config->{table_to_class} = { map { $_->table => $_ } @$classes };
67 $config->{tables} = [ keys %{ $config->{table_to_class} } ];
72 returns class for given table
77 my ( $self, $r, $table ) = @_;
78 return $r->config->{table_to_class}->{$table};
83 This class method is passed the name of a model class that represensts a table
84 and allows the master model class to do any set-up required.
89 my ( $self, $child ) = @_;
90 if ( my $col = $child->stringify_column ) {
91 $child->columns( Stringify => $col );
97 Action methods are methods that are accessed through web (or other public) interface.
99 Inherited from L<Maypole::Model::CDBI::Base> except do_edit (below)
103 If there is an object in C<$r-E<gt>objects>, then it should be edited
104 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
105 be created with those parameters, and put back into C<$r-E<gt>objects>.
106 The template should be changed to C<view>, or C<edit> if there were any
107 errors. A hash of errors will be passed to the template.
111 sub do_edit : Exported {
112 my ($class, $r, $obj) = @_;
114 my $config = $r->config;
115 my $table = $r->table;
117 # handle cancel button hit
118 if ( $r->params->{cancel} ) {
119 $r->template("list");
120 $r->objects( [$class->retrieve_all] );
124 my $required_cols = $class->required_columns;
127 ($obj,$errors) = $class->_do_update($r,$obj);
129 ($obj,$errors) = $class->_do_create($r);
132 # handle errors, if none, proceed to view the newly created/updated object
134 # pass errors to template
135 $r->template_args->{errors} = $errors;
136 foreach my $error (keys %$errors) {
137 $r->template_args->{errors}{ucfirst($error)} = $errors->{$error}
140 # Set it up as it was:
141 $r->template_args->{cgi_params} = $r->params;
142 $r->template("edit");
144 $r->template("view");
147 $r->objects( $obj ? [$obj] : []);
151 my ($class,$r,$obj) = @_;
153 my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
156 if ( $dfv_results->has_missing ) { # missing fields
157 foreach my $field ( $dfv_results->missing ) {
158 $errors->{$field} = "$field is required";
161 if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
162 foreach my $field ( $dfv_results->invalid ) {
163 $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
167 my $this_class_params = { map { $_ => $r->{params}{$_} } $class->columns };
169 # update or make other related (must_have, might_have, has_many etc )
171 foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
172 # get related object if it exists
173 my $rel_meta = $class->related_meta('r',$accssr);
175 $class->_croak("No relationship for $accssr in " . ref($class));
178 my $rel_type = $rel_meta->{name};
179 my $fclass = $rel_meta->{foreign_class};
181 $rel_obj = $fclass->retrieve($r->params->{$accssr});
182 # update or create related object
183 ($rel_obj, $errs) = ($rel_obj)
184 ? $fclass->_do_update($r, $rel_obj)
185 : $obj->_create_related($accssr, $r->params);
186 $errors->{$accssr} = $errs if ($errs);
191 $obj->set( %$this_class_params );
195 return ($obj,$errors);
202 my $this_class_params = { map { $_ => $r->{params}{$_} } $class->columns };
203 my $obj = eval { My::DBI->create( $this_class_params ) };
205 my $dfv_results = ($obj) ? undef : $class->dfv_results->msgs ;
208 if ( $dfv_results->has_missing ) { # missing fields
209 foreach my $field ( $dfv_results->missing ) {
210 $errors->{$field} = "$field is required";
213 if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
214 foreach my $field ( $dfv_results->invalid ) {
215 $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
219 # Make other related (must_have, might_have, has_many etc )
221 foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
222 my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
223 $errors->{$accssr} = $errs if ($errs);
226 return ($obj,$errors);
230 sub _create_related {
231 # self is object or class, accssr is accssr to relationship, params are
232 # data for relobject, and created is the array ref to store objs
233 my ( $self, $accssr, $params ) = @_;
234 $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
236 my $rel_meta = $self->related_meta('r',$accssr);
238 $self->_croak("No relationship for $accssr in " . ref($self));
241 my $rel_type = $rel_meta->{name};
242 my $fclass = $rel_meta->{foreign_class};
246 # Set up params for might_have, has_many, etc
247 if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
248 # Foreign Key meta data not very standardized in CDBI
249 my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
250 unless ($fkey) { die " Could not determine foreign key for $fclass"; }
251 my %data = (%$params, $fkey => $self->id);
252 %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
253 ($rel, $errs) = $fclass->_do_create(\%data);
256 ($rel, $errs) = $fclass->_do_create($params);
258 $self->$accssr($rel->id);
262 return ($rel, $errs);
268 Inherited from Maypole::Model::CDBI::Base.
270 This action deletes records
274 Inherited from Maypole::Model::CDBI::Base.
276 This action method searches for database records.
280 Inherited from Maypole::Model::CDBI::Base.
282 The C<list> method fills C<$r-E<gt>objects> with all of the
283 objects in the class. The results are paged using a pager.
290 # get COLUMN INFO from DB
291 $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
293 # update with required columns from DFV Profile
294 my $profile = $class->dfv_profile;
295 $class->required_columns(@{$profile->{required}});
297 return $class->COLUMN_INFO;
304 L<Maypole::Model::Base>
306 L<Maypole::Model::CDBI::Base>
314 You may distribute this code under the same terms as Perl itself.