File Coverage

lib/Catalyst/Plugin/Params/Profile.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

=head1 NAME

Catalyst::Plugin::Params::Profile - Parameter checking with Params::Profile

=head1 SYNOPSIS

    package MyAPP;
    use Catalyst qw/Params::Profile/;

    # In a controller
    MyAPP->register_profile(
                    'method'    => 'subroto',
                    'profile'   => {
                                testkey1 => { required => 1 },
                                testkey2 => {
                                        required => 1,
                                        allow => qr/^\d+$/,
                                    },
                                testkey3 => {
                                        allow => qr/^\w+$/,
                                    },
                                },
                );

    sub subroto : Private {
        my (%params) = @_;

        return unlesss $c->validate('params' => \%params);
        ### OR
        my %opts = $c->check_params or return;

        ### DO SOME STUFF HERE ...

        my $profile = $c->get_profile('method' => 'subroto');
    }


    ### Multiple Profile
    MyAPP->register_profile(
                    'method'    => 'subalso',
                    'profile'   => [
                                    'subroto',
                                    {
                                    testkey4 => { required => 1 },
                                    testkey5 => {
                                            required => 1,
                                            allow => qr/^\d+$/,
                                        },
                                    testkey6 => {
                                            allow => qr/^\w+$/,
                                        },
                                    },
                                ],
                );


    sub subalso : Local {
        my (%params) = @_;

        ### Checks parameters agains profile of subroto and above registered
        ### profile
        return unlesss $c->validate('params' => \%params);

        ### DO SOME STUFF HERE ...
    }


=head1 DESCRIPTION

Catalyst::Plugin::Params::Profile provides a mechanism for a centralised
Params::Check or a Data::FormValidater profile. You can bind a profile to a
class::subroutine, then, when you are in a subroutine you can simply call
$c->check($params) of $c->validate($params) to validate against this profile.

For more information read the manual of C<Params::Profile> , the methods below
are just an interface on it.

=head1 Public Methods

See C<Params::Profile> for more information about the specific methods,
the onse listed below are the most important.

=over 4

=item $c->register_profile('method' => $METHOD, 'profile' => \%PROFILE);

=item $c->get_profile('method' => $METHOD);

=item $c->validate('params' => \%PARAMS);

=item $c->check('params' =>  \%PARAMS);

=back

=head2 $c->check_params;

Checks $c->req->params against the profile of the calling sub. It returns
a HASHREF containing validate parameters, or undef on failure. It will also
log to Catalyst::Log about what happened.

Extra options to this sub are:

=over 4

=item params OPTIONAL

Validate against params instead of $c->req->params

=item profile OPTIONAL

Validate against profile instead of profile of calling sub

=item allow_unknown OPTIONAL

Pass the unknown parameters to the return HREF rather than filtering them out.

=item dv OPTIONAL

Instead of returning a hashref containing validated params, return the
Data::FormValidator::Results object.

NOTE: Only tested with Data::FormValidator yet!!

=back

=head1 XMLRPC

This module also registers a method name called C<system.methodHelp> into
the Server::XMLRPC plugin when it is loaded. This method will try to explain
in plaintext the arguments for the subroutine by parsing the given profile.

Example output when system.methodHelp is called with one argument containing
the name of the method you'd like to be explained:

    Required arguments are:
     * customer_id
     * username
     * product

    Optional arguments are:
     * roaming
     * card_type

NOTE: This currently only works for Data::FormValidator profiles.

=cut

{   package Catalyst::Plugin::Params::Profile;

    use strict;
    use warnings;

    use Catalyst::ActionContainer;
    use Tree::Simple;
    use Class::C3;

    our $VERSION = '0.05';

    use base qw/Params::Profile/;

    ### Override _raise_warning of paramsprofile to log to Catalyst
    ### debug engine
    sub _raise_warning {
        my ($c, $warning) = @_;

        ### Do not warn on missing profile, this will be shown in a nice
        ### formatted table in debug mode ;)
        return if $warning =~ /No profile for/;

        $c->log->debug($warning) if $c->debug;
    }


    ### Extend setup_actions to check Params::Profile registered methods,
    ### and generate a nice table containing Params::Profile specific
    ### informatie. We will also register a method 'system.methodHelp' into
    ### the Server::XMLRPC module when this module is available.
    sub setup_actions {
        my $c = shift;
        $c->next::method( @_ );

        ### Generate nice table containing Params::Profile specific
        ### information
        $c->_check_profiles;

        $c->error('WARNING: Profiles are not correct!') unless
                    Params::Profile->verify_profiles;

        if ($c->registered_plugins('Server::XMLRPC')) {
            $c->server->xmlrpc->add_private_method('system.methodHelp', sub
                {
                    my ($class, @args) = @_;
                    my $action = $class->server->xmlrpc->dispatcher->{
                                        'Path'
                                    }->methods->{$args[0]};
                    my $ns = $action->class .'::'. $action->name;
                    $class->stash->{xmlrpc} = $class->_describe_pp_plaintext(
                                    profile => $ns,
                                );
                }
            );
        }
    }

    sub _check_profiles {
        my ($c) = @_;
        my $actions = {};

        for my $controller ($c->controllers) {
            my @containers = $c->dispatcher->get_containers($c->controller($controller)->action_namespace);

            for my $container (@containers) {
                my $container_actions     = $container->actions;

                for my $action ( keys %{ $container_actions } ) {
                    next if $action =~ /^_.*/;

                    my $action_obj  = $container_actions->{$action};

                    $actions->{
                            $action_obj->class . '::' . $action_obj->name
                        } = $action_obj;
                }
            }
        }

        return 1 if scalar(keys %{ $actions }) < 1;

        { # Table creation
            my $nogotable = Text::SimpleTable->new(
                [ 20, 'Private'],
                [ 38, 'Class'  ],
                [ 12, 'Method' ],
            );

            my $show_nogotable;
            foreach my $method (%{$actions}) {
                my $action = $actions->{$method};
                next unless (
                        $action &&
                        !$action->attributes->{Private} &&
                        !$c->get_profile('method' => $method)
                    );
                $show_nogotable = 1;
                $nogotable->row(
                                '/'.$action->reverse,
                                $action->class,
                                $action->name,
                            );
            }

            $c->log->debug("WARNING: Missing profiles:\n" . $nogotable->draw)
                    if $c->debug && $show_nogotable;
        }
    }

    sub _describe_pp_plaintext {
        my ($self, %opts) = @_;
        my ($profile,$txt);

        ### Check if option profile is a profile or a methodname
        if (!UNIVERSAL::isa($opts{profile},'HASH')) {
            $profile = $self->get_profile(method => $opts{profile}) or return;
        } else {
            $profile = $opts{profile};
        }

        ### Check for Data::FormValidator profile
        return 'No help available for this method' unless
                    UNIVERSAL::isa($profile->{required}, 'ARRAY') ||
                    UNIVERSAL::isa($profile->{optional}, 'ARRAY');

        ### Create describe string
        if ($profile->{required}) {
            $txt .= "Required arguments are:";
            $txt .= "\n * " . $_ for @{$profile->{required}};
            $txt .= "\n\n";
        }
        if ($profile->{optional}) {
            $txt .= "Optional arguments are:";
            $txt .= "\n * " . $_ for @{$profile->{optional}};
            $txt .= "\n\n";
        }
        if ($profile->{constraint_methods} && $opts{constraints}) {
            $txt .= "Given constraints are:";
            while (my ($key, $value) = each %{$profile->{constraint_methods}}) {
                $txt .= "\n $key => " . scalar($value);
            }
        }

        return $txt;
    }

    sub check_params {
        my ($c, %args) = @_;
        my (%ok_params);
        ### Extra option: allow_unknown
        ### allow_unknown: do not filter out parameters we do not know

        ### Get options
        my %params = $args{params} || %{ $c->req->params };

        ### Get caller
        my $caller_sub = $args{method} || [caller(1)]->[3];

        local $Params::Check::VERBOSE = undef;
        local $Params::Check::ALLOW_UNKNOWN = 1 if $args{allow_unknown};

        my $result = $c->check(
                method  => $caller_sub,
                params  => \%params,
            );

        if (
            UNIVERSAL::isa($result, 'Data::FormValidator::Results')
        ) {
            my $dv = $result;

            ### Go into error when parameters validate AND
            ### we have no unknown params or pass_unknown is 1
            unless ($dv->success) {
                my $errmsg = "Problems validating profile:";
                ### Go log something
                $errmsg .= "\n        Missing params:\n        * " .
                            join("\n        * ", $dv->missing)
                            if $dv->has_missing;
                $errmsg .= "\n        Invalid params:\n        * " .
                            join("\n        * ", $dv->invalid)
                            if $dv->has_invalid;
                $errmsg .= "\n        Unknown params:\n        * " .
                            join("\n        * ", $dv->unknown)
                            if $dv->has_unknown;
                $c->log->debug($errmsg) if $c->debug;
                return;
            }

            return $dv if $args{dv};

            ### Force dv->valid to return as href
            my $href = $dv->valid;

            ### Return all params or only validated ones.
            return $args{allow_unknown} ? \%params : $href;
        } else {
            if (my $errmsg = Params::Check::last_error()) {
                $c->log->debug("Problems validating profile:\n" .
                        Params::Check::last_error()) if $c->debug;
            }
            return $result;
        }

        return;
    }
}

1;

__END__

=head1 AUTHOR

Michiel Ootjers E<lt>[e-mail]<gt>.

and

Jos Boumans E<lt>[e-mail]<gt>.

=head1 TODO

=over 4

=item profile explanation

Fix the profile explanation to explain profiles other than
C<Data::FormValidator>

=back

=head1 BUG REPORTS

Please submit all bugs regarding C<Catalyst::Plugin::Params::Profile> to
C<[e-mail]>

=head1 SOURCE

Please send your improvements as pull request via bitbucket.org to
C<https://bitbucket.org/michielootjers/catalyst-plugin-params-profile>

=head1 COPYRIGHT

This module is
copyright (c) 2002-2013 Michiel Ootjers E<lt>[e-mail]<gt>.
All rights reserved.

This library is free software;
you may redistribute and/or modify it under the same
terms as Perl itself.

=cut