File Coverage

blib/lib/Jifty/Param/Schema.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

package Jifty::Param::Schema;

=head1 NAME

Jifty::Param::Schema - Declare parameters of a Jifty action with ease.

=head1 SYNOPSIS

    package MyApp::Action::Login;
    use Jifty::Param::Schema;
    use Jifty::Action schema {

    param email =>
        label is 'Email address',
        is mandatory,
        ajax validates;

    param password =>
        type is 'password',
        label is 'Password',
        is mandatory;

    param remember =>
        type is 'checkbox',
        label is 'Remember me?',
        hints is 'If you want, your browser can remember your login for you',
        default is 0;

    };

=head1 DESCRIPTION

This module provides a simple syntax to declare action parameters.

It re-exports C and C from L, for setting
parameter fields that must be recomputed at request-time:

    param name =>
        default is defer { Jifty->web->current_user->name };

See L for more information about C.

=head2 schema

The C block from a L subclass describes an action
for a Jifty application.

Within the C block, the localization function C<_> is redefined
with C, so that it resolves into a dynamic value that will be
recalculated upon each request, according to the user's current language
preference.

=head2 param

Each C statement inside the C block sets out the name
and attributes used to describe one named parameter, which is then used
to build a L object.  That class defines possible field names
to use in the declarative syntax here.

The C function is not available outside the C block.

=head1 ALIASES

In addition to the labels provided by L and
L, this module offers the following aliases:

    ajax validates,             # ajax_validates is 1
    ajax canonicalizes,         # ajax_canonicalizes is 1
    order is -1,                # sort_order is -1
    default is 0,               # default_value is 0
    valid are qw( 1 2 3 ),      # valid_values are qw( 1 2 3 )
    available are qw( 1 2 3 ),  # available_values are qw( 1 2 3 )
    render as 'select',         # render_as is 'select'

=head1 SEE ALSO

L, L

=cut

use strict;
use warnings;
use Jifty::I18N;
use Jifty::Param;
use Scalar::Defer;
use SUPER;

use Object::Declare (
    mapping => {
        param => 'Jifty::Param',
    },
    aliases => {
        default     => 'default_value',
        available   => 'available_values',
        valid       => 'valid_values',
        render      => 'render_as',
        order       => 'sort_order',
    },
    copula  => {
        is      => '',
        are     => '',
        as      => '',
        ajax    => 'ajax_',
    }
);
use Exporter::Lite;
use Class::Data::Inheritable;

our @EXPORT = qw( defer lazy param schema );

sub schema (&) {
    my $code = shift;
    my $from = caller;

    no warnings 'redefine';

    # See the perldoc for an explanation of why we're redefining
    # the localization method _().
    local *_ = sub { my $args = \@_; defer { _(@$args) } };

    Class::Data::Inheritable::mk_classdata($from => qw/PARAMS/);
    my @params = &declare($code);

    # The .99 here is a flag for Jifty::Action::Record to mark autogenerated orders
    my $count = 10000.99;
    foreach my $param (@params) {
        next if !ref($param) or defined($param->sort_order);
        $param->sort_order($count);
        $count += 10;
    }

    if ( my $super_params = $from->super('PARAMS') ) {
        my $super = $super_params->();
        # XXX: skip the merge_params if the parent class' PARAMS is
        # empty to avoid the currently kludgy merge_params
        # implementation to pollute scalar::defer with undetermined
        # behaviour
        $from->PARAMS(
            ($super && keys %$super)
            ? merge_params( $super, {@params} )
            : {@params} );
    }
    else {
        $from->PARAMS( {@params} );
    }

    no strict 'refs';
    push @{$from . '::ISA'}, 'Jifty::Action'
        unless $from->isa('Jifty::Action');
    return;
}

use Hash::Merge ();
no warnings 'uninitialized';
use constant MERGE_PARAM_BEHAVIOUR => {
    SCALAR => {
            SCALAR => sub { length($_[1]) ? $_[1] : $_[0] },
            ARRAY  => sub { [ @{$_[1]} ] },
            HASH   => sub { $_[1] } },
    ARRAY => {
            SCALAR => sub { length($_[1]) ? $_[1] : $_[0] },
            ARRAY  => sub { [ @{$_[1]} ] },
            HASH   => sub { $_[1] } },
    HASH => {
            SCALAR => sub { length($_[1]) ? $_[1] : $_[0] },
            ARRAY  => sub { [ @{$_[1]} ] },
            HASH   => sub { Hash::Merge::_merge_hashes( $Hash::Merge::context, $_[0], $_[1] ) } }
};

my $prev_behaviour = Hash::Merge::get_behavior();
# the behavior name must be upper-case
Hash::Merge::specify_behavior( MERGE_PARAM_BEHAVIOUR, 'MERGE_PARAMS' );
Hash::Merge::set_behavior( $prev_behaviour );
my $merge = Hash::Merge->new('MERGE_PARAMS');

=head2 merge_params HASHREF HASHREF

Takes two hashrefs. Merges them together and returns the merged hashref.

    - Empty fields in subclasses don't override nonempty fields in superclass anymore.
    - Arrays don't merge; e.g. if parent class's valid_values is [1,2,3,4], and
      subclass's valid_values() is [1,2], they don't somehow become [1,2,3,4,1,2].

BUG: This should either be a private routine or factored out into Jifty::Util



=cut

sub merge_params {
    # We pull this deref and re-ref trick to un-bless any
    # Jifty::Params which might exist; Hash::Merge pre-0.10 merged
    # objects and hahrefs with no complaint, but 0.10 doesn't.  This
    # is a horrible, horrible hack, and will hopeflly be able to be
    # backed out if and when Hash::Merge reverts to the old behavior.
    my $field_type = {};
    my @types;
    for my $m (@_) {
        my @t;
        for (keys %{$m}) {
            push @t, ref $m->{$_};
            $field_type->{$_} = ref $m->{$_};
            bless $m->{$_}, "HASH";
        }
        push @types, \@t;
    }
    my $rv = $merge->merge(@_);
    for my $m (@_) {
        my @t = @{shift @types};
        for (keys %{$m}) {
            bless $m->{$_}, shift @t;
        }
    }

    for ( keys %$rv ) {
        bless $rv->{$_}, $field_type->{$_}
            if $field_type->{$_};
    }
    return $rv;
}

1;