From: Aaron Trevena Date: Tue, 7 Feb 2006 21:02:57 +0000 (+0000) Subject: pjsz and AJT Maypole/Model updates and fixes X-Git-Tag: 2.11~62 X-Git-Url: https://git.decadent.org.uk/gitweb/?a=commitdiff_plain;h=688f03716c8809f3e5cd1a2bf95276b3c45747cf;p=maypole.git pjsz and AJT Maypole/Model updates and fixes git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@456 48953598-375a-da11-a14b-00016c27c3ee --- diff --git a/lib/Maypole.pm b/lib/Maypole.pm index fe2d29a..5db199b 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -307,35 +307,32 @@ don't need to load them in the driver. =cut -sub setup_model -{ - my $class = shift; - - $class = ref $class if ref $class; - - my $config = $class->config; - - $config->model || $config->model('Maypole::Model::CDBI'); - - $config->model->require or die sprintf - "Couldn't load the model class %s: %s", $config->model, $@; - - # among other things, this populates $config->classes - $config->model->setup_database($config, $class, @_); - - foreach my $subclass ( @{ $config->classes } ) - { - next if $subclass->isa("Maypole::Model::Base"); - no strict 'refs'; - unshift @{ $subclass . "::ISA" }, $config->model; - - # Load custom model code, if it exists - nb this must happen after the - # unshift, to allow code attributes to work, but before adopt(), - # in case adopt() calls overridden methods on $subclass - $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); - - $config->model->adopt($subclass) if $config->model->can("adopt"); - } +sub setup_model { + my $class = shift; + $class = ref $class if ref $class; + my $config = $class->config; + $config->model || $config->model('Maypole::Model::CDBI'); + $config->model->require or die sprintf + "Couldn't load the model class %s: %s", $config->model, $@; + + # among other things, this populates $config->classes + $config->model->setup_database($config, $class, @_); + + foreach my $subclass ( @{ $config->classes } ) { + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + unshift @{ $subclass . "::ISA" }, $config->model; + + } + + # Load custom model code, if it exists - nb this must happen after the + # unshift, to allow code attributes to work, but before adopt(), + # in case adopt() calls overridden methods on $subclass + foreach my $subclass ( @{ $config->classes } ) { + $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); + $config->model->adopt($subclass) if $config->model->can("adopt"); + } + } =item load_model_subclass($subclass) @@ -344,32 +341,32 @@ This method is called from C. It attempts to load the C<$subclass> package, if one exists. So if you make a customized C package, you don't need to explicitly load it. -If, perhaps during development, you don't want to load up custom classes, you +If automatic loading causes problems, Override load_model_subclass in your driver. + +sub load_model_subclass {}; + +Or perhaps during development, if you don't want to load up custom classes, you can override this method and load them manually. =cut -sub load_model_subclass -{ - my ($class, $subclass) = @_; - - my $config = $class->config; - - # Load any external files for the model base class or subclasses - # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from - # Maypole::Plugin::Loader and Class::DBI. - if ( $subclass->require ) - { - warn "Loaded external module for '$subclass'\n" if $class->debug > 1; - } - else - { - (my $filename = $subclass) =~ s!::!/!g; - die "Loading '$subclass' failed: $@\n" - unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; - warn "No external module for '$subclass'" - if $class->debug > 1; - } +sub load_model_subclass { + my ($class, $subclass) = @_; + + my $config = $class->config; + + # Load any external files for the model base class or subclasses + # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from + # Maypole::Plugin::Loader and Class::DBI. + if ( $subclass->require ) { + warn "Loaded external module for '$subclass'\n" if $class->debug > 1; + } else { + (my $filename = $subclass) =~ s!::!/!g; + die "Loading '$subclass' failed: $@\n" + unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; + warn "No external module for '$subclass'" + if $class->debug > 1; + } } =item init @@ -526,7 +523,7 @@ sub handler_guts $self->__load_request_model; - my $applicable = $self->is_model_applicable; + my $applicable = $self->is_model_applicable == OK; $self->__setup_plain_template unless $applicable; @@ -730,6 +727,10 @@ from a Maypole:Constant to a true/false value. Returns a Maypole::Constant to indicate whether the request is valid. +=cut + +sub is_applicable { return shift->is_model_applicable(@_); } + =item is_model_applicable Returns true or false to indicate whether the request is valid. @@ -740,17 +741,8 @@ C<< $r->action >>. =cut -sub is_model_applicable -{ +sub is_model_applicable { my ($self) = @_; - - # cater for applications that are using obsolete version - if ($self->can('is_applicable')) - { - warn "DEPRECATION WARNING: rewrite is_applicable to the interface ". - "of Maypole::is_model_applicable\n"; - return $self->is_applicable == OK; - } # Establish which tables should be processed by the model my $config = $self->config; @@ -779,17 +771,17 @@ sub is_model_applicable . join( ",", keys %$ok_tables ) if $self->debug and not $ok_tables->{$table}; - return 0; + return DECLINED; } # Is the action public? my $action = $self->action; - return 1 if $self->model_class->is_public($action); + return OK if $self->model_class->is_public($action); warn "The action '$action' is not applicable to the table '$table'" if $self->debug; - return 0; + return DECLINED; } =item get_session diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index 32f36b9..2c79804 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -572,6 +572,12 @@ sub setup_database { 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 ? diff --git a/lib/Maypole/Model/CDBI/Plain.pm b/lib/Maypole/Model/CDBI/Plain.pm index 7a36f68..fd34a75 100644 --- a/lib/Maypole/Model/CDBI/Plain.pm +++ b/lib/Maypole/Model/CDBI/Plain.pm @@ -36,15 +36,10 @@ tables and set up the inheritance relationships as normal. This method loads the model classes for the application -=head1 SEE ALSO - -L - -L - =cut + sub setup_database { my ( $self, $config, $namespace, $classes ) = @_; $config->{classes} = $classes; @@ -54,11 +49,39 @@ sub setup_database { $config->{tables} = [ keys %{ $config->{table_to_class} } ]; } +=head2 class_of + + returns class for given table + +=cut + sub class_of { my ( $self, $r, $table ) = @_; return $r->config->{table_to_class}->{$table}; } +=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. + +=cut + +sub adopt { + my ( $self, $child ) = @_; + if ( my $col = $child->stringify_column ) { + $child->columns( Stringify => $col ); + } +} + +=head1 SEE ALSO + +L + +L + +=cut + 1;