File Coverage

blib/lib/Mojolicious/Plugin/FormFields.pm

Criterion	Covered	Total	%
statement	251	257	97.6
branch	65	78	83.3
condition	38	62	61.2
subroutine	51	52	98.0
pod	1	1	100.0
total	406	450	90.2

package Mojolicious::Plugin::FormFields;

# TODO: We're not much of a subclass now
use Mojo::Base 'Mojolicious::Plugin::ParamExpand';

our $VERSION = '0.04';

sub register
{
  my ($self, $app, $config) = @_;
  my $ns = 'formfields.fields';

  $config->{separator} = Mojolicious::Plugin::FormFields::Field->separator;
  $self->SUPER::register($app, $config);

  $app->helper(field => sub {
      my $c    = shift;
      my $name = shift || '';
      $c->stash->{$ns}->{$name} ||= Mojolicious::Plugin::FormFields::Field->new($c, $name, @_);
      $c->stash->{$ns}->{$name};
  });

  $app->helper(fields => sub {
      my $c    = shift;
      my $name = shift || '';
      $c->stash->{$ns}->{$name} ||= Mojolicious::Plugin::FormFields::ScopedField->new($c, $name, @_);
      $c->stash->{$ns}->{$name};
  });

  my $methods = $config->{methods};
  my $helper = $methods->{valid} // 'valid';
  $app->helper($helper => sub {
      my $c = shift;
      my $valid = 1;
      my $errors = {};

      # TODO: skip keys used by fields()
      while(my ($name, $field) = each %{$c->stash->{$ns}}) {
	  if(!$field->valid) {
	      $valid = 0;
	      $errors->{$name} = $field->error;
	  }
      }

      $c->stash->{"$ns.errors"} = $errors;
      $valid;
  });

  $helper = $methods->{errors} // 'errors';
  $app->helper($helper => sub {
      my ($c, $name) = @_;
      my $errors = $c->stash->{"$ns.errors"} // {};
      $name ? { $name => $errors->{$name} } : $errors;
  });
}

package Mojolicious::Plugin::FormFields::Field;

use Mojo::Base -strict;
use Scalar::Util;
use Carp ();
use Validate::Tiny;

use overload
    '@{}' => '_to_fields',
    '""'  => '_to_string',
    bool  => sub { 1 },
    fallback => 1;

my $SEPARATOR = '.';

sub new
{
    my $class = shift;
    my ($c, $name, $object) = @_;
    Carp::croak 'field name required' unless $name;

    my $self = bless {
	c       => $c,
	name    => $name,
	object  => $object,
	checks  => [],
	filters => []
    }, $class;

    Scalar::Util::weaken $self->{c};
    $self;
}

sub checkbox
{
    my $self = shift;

    my $value;
    $value = shift if @_ % 2;
    $value //= 1;

    my %options = @_;
    $options{value} = $value;

    $self->input('checkbox', %options);
}

sub file
{
    my ($self, %options) = @_;
    $options{id} //= _dom_id($self->{name});

    $self->{c}->file_field($self->{name}, %options);
}

sub input
{
    my ($self, $type, %options) = @_;
    my $value = $self->_lookup_value;

    $options{id} //= _dom_id($self->{name});
    $options{value} //= $value if defined $value;
    $options{type} = $type;

    if($type eq 'checkbox' || $type eq 'radio') {
	$options{checked} = 'checked'
	    if !exists $options{checked} && defined $value && $value eq $options{value};
    }

    $self->{c}->input_tag($self->{name}, %options);
}

sub hidden
{
    my ($self, %options) = @_;
    $self->input('hidden', %options);
}

sub radio
{
    my ($self, $value, %options) = @_;
    Carp::croak 'value required' unless defined $value;

    $options{id} //= _dom_id($self->{name}, $value);
    $options{value} = $value;

    $self->input('radio', %options);
}

sub select
{
    my $self = shift;
    my $options = @_ % 2 ? shift : [];
    my %attr = @_;
    $attr{id} //= _dom_id($self->{name});

    my $c = $self->{c};
    my $name = $self->{name};
    my $field;

    if(defined $c->param($name)) {
	$field = $c->select_field($name, $options, %attr);
    }
    else {
	# Make select_field select the value
	$c->param($name, $self->_lookup_value);
	$field = $c->select_field($name, $options, %attr);
	$c->param($name, undef);
    }

    $field;
}

sub password
{
    my ($self, %options) = @_;
    $options{id} //= _dom_id($self->{name});

    $self->{c}->password_field($self->{name}, %options);
}

sub label
{
    my $self = shift;

    my $text;
    $text = pop if ref $_[-1] eq 'CODE';
    $text = shift if @_ % 2;	# step on CODE
    $text //= _default_label($self->{name});

    my %options = @_;
    $options{for} //= _dom_id($self->{name});

    $self->{c}->tag('label', %options, $text)
}

sub text
{
    my ($self, %options) = @_;
    $self->input('text', %options);
}

sub textarea
{
    my ($self, %options) = @_;
    $options{id} //= _dom_id($self->{name});

    my $size = delete $options{size};
    if($size && $size =~ /^(\d+)[xX](\d+)$/) {
	$options{rows} = $1;
	$options{cols} = $2;
    }

    $self->{c}->text_area($self->{name}, %options, sub { $self->_lookup_value || '' });
}

sub each
{
    my $self = shift;
    my $block = pop;
    my $fields = $self->_to_fields;

    return $fields unless ref($block) eq 'CODE';

    local $_;
    $block->() for @$fields;

    return;
}

sub check
{
    my $self = shift;
    push @{$self->{checks}}, $self->{name} => shift;
    $self;
}

sub filter
{
    my $self = shift;
    my $data = ref $_[0] eq 'CODE' ? shift : Validate::Tiny::filter(@_);
    push @{$self->{filters}}, $self->{name} => $data;
    $self;
}

# Just a single value
sub error
{
    my $self = shift;
    $self->{result}->{error}->{$self->{name}};
}

sub separator { $SEPARATOR; }

sub valid
{
    my $self = shift;
    return $self->{result}->{success} if defined $self->{result};

    my $result;
    my $name  = $self->{name};
    my $value = $self->{c}->param($name);
    my $field = { $name => $value };
    my $rules = {
	fields  => [ $name ],
	checks  => $self->{checks},
	filters => $self->{filters}
    };

    # A bit of massaging For the is_equal() validation
    my $eq = $self->{eq_to_field};
    if($eq) {
	$field->{$eq} = $self->{c}->param($eq);
	push @{$rules->{fields}}, $eq;
    }

    $result = Validate::Tiny::validate($field, $rules);
    $self->{c}->param($name, $result->{data}->{$name}) if @{$self->{filters}};
    $self->{result} = $result;

    $result->{success};
}

sub is_equal
{
    my $self = shift;
    $self->{eq_to_field} = $_[0];
    push @{$self->{checks}}, $self->{name} => Validate::Tiny::is_equal(@_);
}

# Avoid AUTOLOAD call
sub DESTROY { }

our $AUTOLOAD;
sub AUTOLOAD
{
    my $self   = shift;
   (my $method = $AUTOLOAD) =~ s/[^':]+:://g;

    if($method =~ /^is_/) {
	my $check = Validate::Tiny->can($method);
	die qq|Can't locate object method "$method" via package "${ \__PACKAGE__ }"| unless $check;

	push @{$self->{checks}}, $self->{name} => $check->(@_);
    }
    else {
	# TODO: What's the use case for this?
	# field('name')->trim instead of field('name')->filter('trim')?
	push @{$self->{filters}}, $self->{name} => Validate::Tiny::filter($method);
    }

    $self->{result} = undef;	# reset previous validation
    $self;
}

sub _to_string { shift->_lookup_value; }

sub _to_fields
{
    my $self  = shift;
    my $value = $self->_lookup_value;

    my $fields = [];
    return $fields unless ref($value) eq 'ARRAY';

    my $i = -1;
    while(++$i < @$value) {
	push @$fields, $self->{c}->fields($self->_path($i), $self->{object});
    }

    $fields;
}

sub _dom_id
{
    my @name = @_;
    s/[^\w]+/-/g for @name;
    join '-', @name;
}

sub _default_label
{
    my $label = (split /\Q$SEPARATOR/, shift)[-1];
    $label =~ s/[^-a-z0-9]+/ /ig;
    ucfirst $label;
}

sub _invalid_parameter
{
    my ($field, $message) = @_;
    Carp::croak "Invalid parameter '$field': $message";
}

sub _path { "$_[0]->{name}${SEPARATOR}$_[1]" }

sub _lookup_value
{
    my $self = shift;
    return $self->{value} if defined $self->{value};

    my $name = $self->{name};
    my $object = $self->{object};
    my @path = split /\Q$SEPARATOR/, $name;

    if(!$object) {
	$object = $self->{c}->stash($path[0]);
	_invalid_parameter($name, "nothing in the stash for '$path[0]'") unless $object;
    }

    # Remove the stash key for $object
    shift @path;

    while(defined(my $accessor = shift @path)) {
	my $isa = ref($object);

	# We don't handle the case where one of these return an array
	if(Scalar::Util::blessed($object) && $object->can($accessor)) {
	    $object = $object->$accessor;
	}
	elsif($isa eq 'HASH') {
	    # If blessed and !can() do we _really_ want to look inside?
	    $object = $object->{$accessor};
	}
	elsif($isa eq 'ARRAY') {
	    _invalid_parameter($name, "non-numeric index '$accessor' used to access an ARRAY")
		unless $accessor =~ /^\d+$/;

	    $object = $object->[$accessor];
	}
	else {
	    my $type = $isa || 'type that is not a reference';
	    _invalid_parameter($name, "cannot use '$accessor' on a $type");
	}
    }

    $self->{value} = $object;
}

package Mojolicious::Plugin::FormFields::ScopedField;

use Mojo::Base -strict;
use Carp ();

our @ISA = 'Mojolicious::Plugin::FormFields::Field';

my $sep = __PACKAGE__->separator;

sub new
{
    my $class = shift;
    Carp::croak 'object name required' unless $_[1];  # 0 arg is controller instance

    my $self = $class->SUPER::new(@_);
    $self->{fields} = {};
    $self->{errors} = {};
    $self->{index} = $1 if $self->{name} =~ /\Q$sep\E(\d+)$/;

    $self;
}

sub index  { shift->{index} }

# This is the caller's view of the object, which can differ from $self->{object}.
# For example, given 'user.orders.0.id' {object} will be user and object() will be user.orders.0
sub object { shift->_lookup_value }

for my $m (qw(checkbox fields file hidden input label password radio select text textarea check filter is_equal)) {
    no strict 'refs';
    *$m = sub {
	my $self = shift;
	my $name = shift;
	Carp::croak 'field name required' unless $name;

	return $self->_fields($name) if $m eq 'fields';

	my $field = $self->_field($name);
	$self->{fields}->{$name} = 1;

	return $field->error if $m eq 'error';

	# TODO: compare things in different scopes, e.g., user.password => account.password
	return $field->$m($self->_path(shift), @_) if $m eq 'is_equal';

	$field->$m(@_);
    };
}

sub errors
{
    my ($self, $name) = @_;
    $name ? $self->_field($name)->error : $self->{errors};
}

sub valid
{
    my ($self, $name) = @_;
    return $self->_field($name)->valid if $name;

    $self->{errors} = {};

    my $valid = 1;
    for my $name (keys %{$self->{fields}}) {
	my $field = $self->_field($name);
	unless($field->valid) {
	    $valid = 0;
	    $self->{errors}->{$name} = $field->error;
	}
    }

    $valid;
}

our $AUTOLOAD;
sub AUTOLOAD
{
    my $self = shift;
    my $name = shift;
    Carp::croak 'field name required' unless $name;

   (my $method = $AUTOLOAD) =~ s/[^':]+:://g;
    $self->_field($name)->$method(@_);
    # Some hacky shit going on here...
    $self->{fields}->{$name} = 1;

    $self;
}

sub _field
{
    my ($self, $name) = @_;
    $self->{c}->field($self->_path($name), $self->{object});
}

sub _fields
{
    my ($self, $name) = @_;
    $self->{c}->fields($self->_path($name), $self->{object});
}

1;

__END__