# @(#)$Id: Model.pm 1139 2012-03-28 23:49:18Z pjf $ package CatalystX::Usul::Model; use strict; use warnings; use version; our $VERSION = qv( sprintf '0.5.%d', q$Rev: 1139 $ =~ /\d+/gmx ); use parent qw(Catalyst::Model CatalystX::Usul CatalystX::Usul::Encoding); use CatalystX::Usul::Constants; use CatalystX::Usul::Functions qw(app_prefix is_arrayref throw); use Data::Validation; use MRO::Compat; use Scalar::Util qw(blessed refaddr weaken); use TryCatch; __PACKAGE__->config( scrubbing => FALSE, scrub_chars => q([\'\"/\:]) ); __PACKAGE__->mk_accessors( qw(context domain_attributes domain_class domain_model scrubbing scrub_chars) ); __PACKAGE__->mk_encoding_methods( qw(_get_req_array _get_req_value) ); sub COMPONENT { my ($class, $app, $config) = @_; $class->_setup_plugins( $app ); my $comp = $class->next::method( $app, $config ); my $usul = CatalystX::Usul->new( $app, {} ); for (grep { not defined $comp->{ $_ } } keys %{ $usul }) { $comp->{ $_ } = $usul->{ $_ }; # Attribute mixin } return $comp; } sub ACCEPT_CONTEXT { my ($self, $c, @rest) = @_; blessed $c or return $self->build_per_context_instance( $c, @rest ); my $s = $c->stash; my $key = q(__InstancePerContext_).(blessed $self ? refaddr $self : $self); return $s->{ $key } ||= $self->build_per_context_instance( $c, @rest ); } sub build_per_context_instance { my ($self, $c, @rest) = @_; my $attrs = { ref $self ? %{ $self } : () }; # Clone self my $new = bless $attrs, blessed $self || $self; if (blessed $c) { $new->{context} = $c; weaken( $new->{context} ) } return $new; } sub check_field { my ($self, $id, $value) = @_; return $self->_validator->check_field( $id, $value ); } sub check_form { my ($self, $form) = @_; my $c = $self->context; my $s = $c->stash; my $prefix = ($s->{form}->{name} || app_prefix blessed $self).q(.); try { $form = $self->_validator->check_form( $prefix, $form ) } catch ($e) { my $last = pop @{ $e->args }; $c->error( $e->args ); throw $last; } return $form; } sub form { my ($self, @rest) = @_; my $s = $self->context->stash; my $method = $s->{form}->{name}.q(_form); return $self->$method( @rest ); } sub loc { my ($self, @rest) = @_; return $self->next::method( $self->context->stash, @rest ); } sub query_array { my ($self, @rest) = @_; return $self->_query_by_type( q(array), @rest ); } sub query_value { my ($self, @rest) = @_; return $self->_query_by_type( q(value), @rest ); } sub query_value_by_fields { my ($self, @fields) = @_; return { map { $_->[ 0 ] => $_->[ 1 ] } grep { defined $_->[ 1 ] } map { [ $_, $self->query_value( $_ ) ] } @fields }; } sub scrub { my ($self, $value) = @_; defined $value or return; my $pattern = $self->scrub_chars; $value =~ s{ $pattern }{}gmx; return $value; } # Private methods sub _get_req_array { my ($self, $attr) = @_; my $value = $self->context->req->params->{ $attr || NUL }; $value = defined $value ? $value : []; is_arrayref $value or $value = [ $value ]; return $value; } sub _get_req_value { my ($self, $attr) = @_; my $value = $self->context->req->params->{ $attr || NUL }; is_arrayref $value and $value = $value->[ 0 ]; return $value; } sub _query_by_type { my ($self, $type, @rest) = @_; (my $enc = lc ($self->encoding || q(guess))) =~ s{ [-] }{_}gmx; my $method = q(_get_req_).$type.q(_).$enc.q(_encoding); my $value = $self->$method( @rest ); $self->scrubbing or return $value; unless ($type eq q(array)) { $value = $self->scrub( $value ) } else { @{ $value } = map { $self->scrub( $_ ) } @{ $value } } return $value; } sub _setup_plugins { my ($self, $app) = @_; my $plugins; $plugins = __PACKAGE__->get_inherited( q(_m_plugins) ) and return $plugins; my $config = { search_paths => [ q(::Plugin::Model) ], %{ $app->config->{ setup_plugins } || {} } }; $plugins = __PACKAGE__->setup_plugins( $config ); return __PACKAGE__->set_inherited( q(_m_plugins), $plugins ); } sub _validator { my $self = shift; my $s = $self->context->stash; my $attrs = { exception => $self->exception_class, constraints => $s->{constraints} || {}, fields => $s->{fields } || {}, filters => $s->{filters } || {} }; return Data::Validation->new( $attrs ); } 1; __END__ =pod =head1 Name CatalystX::Usul::Model - Interface model base class =head1 Version 0.5.$Revision: 1139 $ =head1 Synopsis package CatalystX::Usul; use parent qw(CatalystX::Usul::Base CatalystX::Usul::File); package CatalystX::Usul::Model; use parent qw(Catalyst::Model CatalystX::Usul CatalystX::Usul::IPC); package YourApp::Model::YourModel; use parent qw(CatalystX::Usul::Model); =head1 Description Common core interface model methods =head1 Subroutines/Methods =head2 COMPONENT Defines the following accessors: =over 3 =item scrubbing Boolean used by L</query_array> and L</query_value> to determine if input value should be cleaned of potentially dangerous characters =item scrub_chars List of characters to scrub from input values. Defaults to '"/\; =back Loads model plugins including; =over 3 =item L<CatalystX::Usul::Plugin::Model::StashHelper> =back =head2 ACCEPT_CONTEXT Calls L</build_per_context_instance> for each new context =head2 build_per_context_instance Called by L</ACCEPT_CONTEXT>. Takes a copy of the Catalyst object so that we don't have to pass C<< $c->stash >> into L<CatalystX::Usul/loc> =head2 check_field $self->check_field( $id, $val ); Expose L<Data::Validation/check_field> =head2 check_form $self->check_form( \%fields ); Expose L<Data::Validation/check_form> =head2 form $self->form( @rest ); Calls the form method to stuff the stash with the data for the requested form. Uses the C<< $c->stash->{form}->{name} >> value to construct the method name =head2 loc $local_text = $self->loc( $key, $args ); Localizes the message. Calls L<CatalystX::Usul/loc> =head2 query_array $array_ref = $self->query_array( $attr ); Returns the requested parameter in a list context. Uses the B<encoding> attribute to generate the method call to decode the input values. The decode method is provided by L<CatalystX::Usul::Encoding>. Will try to guess the encoding if one is not provided =head2 query_value $scalar_value = $self->query_value( $attr ); Returns the requested parameter in a scalar context. Uses B<encoding> attribute to generate the method call to decode the input value. The decode method is provided by L<CatalystX::Usul::Encoding>. Will try to guess the encoding if one is not provided =head2 query_value_by_fields $hash_ref = $self->query_value_by_fields( @fields ); Returns a hash_ref of fields and their values if the values are defined by the request. Calls L</query_value> for each of supplied fields =head2 scrub $value = $self->scrub( $value ); Removes the C<< $self->scrub_chars >> from the value =head2 _get_req_array my $array_ref = $self->_get_req_array( $attr ); Takes a request object that must implement a C<params> method which returns a hash ref. The method returns the value for C<$attr> from that hash. This method will always return a array ref. This method is wrapped by L<Catalystx::Usul::Encoding/mk_encoding_methods> and as such is not called directly =head2 _get_req_value my $value = $self->_get_req_value( $attr ); Takes a request object that must implement a C<params> method which returns a hash ref. The method returns the value for C<$attr> from that hash. This method will always return a scalar. This method is wrapped by L<Catalystx::Usul::Encoding/mk_encoding_methods> and as such is not called directly =head1 Configuration and Environment None =head1 Diagnostics None =head1 Dependencies =over 3 =item L<Catalyst::Model> =item L<CatalystX::Usul> =item L<CatalystX::Usul::Encoding> =item L<CatalystX::Usul::IPC> =item L<Data::Validation> =item L<Scalar::Util> =back =head1 Incompatibilities There are no known incompatibilities in this module. =head1 Bugs and Limitations There are no known bugs in this module. Please report problems to the address below. Patches are welcome =head1 Author Peter Flanigan, C<< <Support at RoxSoft.co.uk> >> =head1 License and Copyright Copyright (c) 2008-2009 Peter Flanigan. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic> This program is distributed in the hope that it will be useful, but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE =cut # Local Variables: # mode: perl # tab-width: 3 # End: