# @(#)$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: