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 };
210 if ($class->isa('Class::DBI::DFV')) {
211 $obj = eval { My::DBI->create( $this_class_params ) };
212 $dfv_results = ($obj) ? undef : $class->dfv_results ;
214 $dfv_results = Data::FormValidator->check($r->{params}, $class->dfv_profile);
215 if ($dfv_results->success) {
216 $obj = $class->create($this_class_params);
221 if ( $dfv_results->has_missing ) { # missing fields
222 foreach my $field ( $dfv_results->missing ) {
223 $errors->{$field} = "$field is required";
226 if ( $dfv_results->has_invalid ) { # Print the name of invalid fields
227 foreach my $field ( $dfv_results->invalid ) {
228 $errors->{$field} = "$field is invalid: " . $dfv_results->invalid( $field );
232 # Make other related (must_have, might_have, has_many etc )
234 foreach my $accssr ( grep ( !(exists $this_class_params->{$_}) , keys %{$r->{params}} ) ) {
235 my ($rel_obj, $errs) = $obj->_create_related($accssr, $r->{params}{$accssr});
236 $errors->{$accssr} = $errs if ($errs);
239 return ($obj,$errors);
243 sub _create_related {
244 # self is object or class, accssr is accssr to relationship, params are
245 # data for relobject, and created is the array ref to store objs
246 my ( $self, $accssr, $params ) = @_;
247 $self->_croak ("Can't make related object without a parent $self object") unless (ref $self);
249 my $rel_meta = $self->related_meta('r',$accssr);
251 $self->_croak("No relationship for $accssr in " . ref($self));
254 my $rel_type = $rel_meta->{name};
255 my $fclass = $rel_meta->{foreign_class};
259 # Set up params for might_have, has_many, etc
260 if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {
261 # Foreign Key meta data not very standardized in CDBI
262 my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
263 unless ($fkey) { die " Could not determine foreign key for $fclass"; }
264 my %data = (%$params, $fkey => $self->id);
265 %data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
266 ($rel, $errs) = $fclass->_do_create(\%data);
269 ($rel, $errs) = $fclass->_do_create($params);
271 $self->$accssr($rel->id);
275 return ($rel, $errs);
281 Inherited from Maypole::Model::CDBI::Base.
283 This action deletes records
287 Inherited from Maypole::Model::CDBI::Base.
289 This action method searches for database records.
293 Inherited from Maypole::Model::CDBI::Base.
295 The C<list> method fills C<$r-E<gt>objects> with all of the
296 objects in the class. The results are paged using a pager.
303 # get COLUMN INFO from DB
304 $class->SUPER::_column_info() unless (ref $class->COLUMN_INFO);
306 # update with required columns from DFV Profile
307 my $profile = $class->dfv_profile;
308 $class->required_columns($profile->{required});
310 return $class->COLUMN_INFO;
317 L<Maypole::Model::Base>
319 L<Maypole::Model::CDBI::Base>
327 You may distribute this code under the same terms as Perl itself.