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!!
39 use Data::FormValidator;
43 use Maypole::Model::CDBI::AsForm;
45 use base qw(Maypole::Model::CDBI::Base);
47 Maypole::Config->mk_accessors(qw(table_to_class _COLUMN_INFO));
53 This method is inherited from Maypole::Model::Base and calls setup_database,
54 which uses Class::DBI::Loader to create and load Class::DBI classes from
55 the given database schema.
59 This method loads the model classes for the application
64 my ( $self, $config, $namespace, $classes ) = @_;
65 $config->{classes} = $classes;
66 foreach my $class (@$classes) {
67 $namespace->load_model_subclass($class);
69 $namespace->model_classes_loaded(1);
70 $config->{table_to_class} = { map { $_->table => $_ } @$classes };
71 $config->{tables} = [ keys %{ $config->{table_to_class} } ];
76 returns class for given table
81 my ( $self, $r, $table ) = @_;
82 return $r->config->{table_to_class}->{$table};
87 This class method is passed the name of a model class that represensts a table
88 and allows the master model class to do any set-up required.
93 my ( $self, $child ) = @_;
94 if ( my $col = $child->stringify_column ) {
95 $child->columns( Stringify => $col );
101 Action methods are methods that are accessed through web (or other public) interface.
103 Inherited from L<Maypole::Model::CDBI::Base> except do_edit (below)
107 If there is an object in C<$r-E<gt>objects>, then it should be edited
108 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
109 be created with those parameters, and put back into C<$r-E<gt>objects>.
110 The template should be changed to C<view>, or C<edit> if there were any
111 errors. A hash of errors will be passed to the template.
115 sub do_edit : Exported {
116 my ($class, $r, $obj) = @_;
118 my $config = $r->config;
119 my $table = $r->table;
121 # handle cancel button hit
122 if ( $r->params->{cancel} ) {
123 $r->template("list");
124 $r->objects( [$class->retrieve_all] );
128 my $required_cols = $class->required_columns;
131 ($obj,$errors) = $class->_do_update($r,$obj);
133 ($obj,$errors) = $class->_do_create($r);
136 # handle errors, if none, proceed to view the newly created/updated object
138 # pass errors to template
139 $r->template_args->{errors} = $errors;
140 foreach my $error (keys %$errors) {
141 $r->template_args->{errors}{ucfirst($error)} = $errors->{$error}
144 # Set it up as it was:
145 $r->template_args->{cgi_params} = $r->params;
146 $r->template("edit");
148 $r->template("view");
151 $r->objects( $obj ? [$obj] : []);
155 my ($class,$r,$obj) = @_;
157 my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
160 if ( $dfv_results->has_missing ) { # missing fields
161 foreach my $field ( $dfv_results->missing ) {
162 $errors->{$field} = "$field is required";
165 if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
166 foreach my $field ( $dfv_results->invalid ) {
167 $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
171 my $this_class_params = { map { $_ => $r->{params}{$_} } $class->columns };
173 # update or make other related (must_have, might_have, has_many etc )
175 foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
176 # get related object if it exists
177 my $rel_meta = $class->related_meta('r',$accssr);
179 $class->_croak("No relationship for $accssr in " . ref($class));
182 my $rel_type = $rel_meta->{name};
183 my $fclass = $rel_meta->{foreign_class};
185 $rel_obj = $fclass->retrieve($r->params->{$accssr});
186 # update or create related object
187 ($rel_obj, $errs) = ($rel_obj)
188 ? $fclass->_do_update($r, $rel_obj)
189 : $obj->_create_related($accssr, $r->params);
190 $errors->{$accssr} = $errs if ($errs);
195 $obj->set( %$this_class_params );
199 return ($obj,$errors);
206 my $this_class_params = { map { $_ => $r->{params}{$_} } $class->columns };
209 my $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
210 if ($dfv_results->success) {
211 $obj = $class->create($this_class_params);
214 if ( $dfv_results->has_missing ) { # missing fields
215 foreach my $field ( $dfv_results->missing ) {
216 $errors->{$field} = "$field is required";
219 if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
220 foreach my $field ( $dfv_results->invalid ) {
221 $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
226 # Make other related (must_have, might_have, has_many etc )
228 foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
229 my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
230 $errors->{$accssr} = $errs if ($errs);
233 return ($obj,$errors);
237 sub _create_related {
238 # self is object or class, accssr is accssr to relationship, params are
239 # data for relobject, and created is the array ref to store objs
240 my ( $self, $accssr, $params ) = @_;
241 $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
243 my $rel_meta = $self->related_meta('r',$accssr);
245 $self->_croak("No relationship for $accssr in " . ref($self));
248 my $rel_type = $rel_meta->{name};
249 my $fclass = $rel_meta->{foreign_class};
253 # Set up params for might_have, has_many, etc
254 if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
255 # Foreign Key meta data not very standardized in CDBI
256 my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
257 unless ($fkey) { die " Could not determine foreign key for $fclass"; }
258 my %data = (%$params, $fkey => $self->id);
259 %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
260 ($rel, $errs) = $fclass->_do_create(\%data);
263 ($rel, $errs) = $fclass->_do_create($params);
265 $self->$accssr($rel->id);
269 return ($rel, $errs);
275 Inherited from Maypole::Model::CDBI::Base.
277 This action deletes records
281 Inherited from Maypole::Model::CDBI::Base.
283 This action method searches for database records.
287 Inherited from Maypole::Model::CDBI::Base.
289 The C<list> method fills C<$r-E<gt>objects> with all of the
290 objects in the class. The results are paged using a pager.
297 # get COLUMN INFO from DB
298 $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
300 # update with required columns from DFV Profile
301 my $profile = $class->dfv_profile;
302 $class->required_columns($profile->{required});
304 return $class->COLUMN_INFO;
311 L<Maypole::Model::Base>
313 L<Maypole::Model::CDBI::Base>
321 You may distribute this code under the same terms as Perl itself.