File Coverage

blib/lib/HTML/Tested/Value.pm

Criterion	Covered	Total	%
statement	124	136	91.1
branch	51	64	79.6
condition	27	38	71.0
subroutine	34	37	91.8
pod	11	19	57.8
total	247	294	84.0

=head1 NAME

HTML::Tested::Value - Base class for most HTML::Tested widgets.

=head1 DESCRIPTION

This class provides the most basic HTML::Tested widget - simple value to be
output in the template.

=head1 METHODS

=cut

use strict;
use warnings FATAL => 'all';

package HTML::Tested::Value;
use HTML::Entities;
use HTML::Tested::Seal;
use Carp;
use Data::Dumper;

sub setup_datetime_option {
	my ($self, $dto, $opts) = @_;
	$opts ||= $self->options;
	eval "use DateTime::Format::Strptime";
	confess "Unable to use DateTime::Format::Strptime: $@" if $@;
	$dto = { pattern => $dto } unless ref($dto);
	$opts->{is_datetime} = DateTime::Format::Strptime->new($dto);
	$self->compile;
}

=head2 $class->new($parent, $name, %opts)

Creates new L named C<$name> at parent class C<$parent>.

C<%opts> is a hash containing various options changing behaviour of this widget.

See OPTIONS section for description of available options.

=cut
sub new {
	my ($class, $parent, $name, %opts) = @_;
	my $self = bless({ name => $name, _options => \%opts
			, constraints => [], validators => [] }, $class);
	my $cs = $opts{constraints} || [];
	$self->push_constraint($_) for @$cs;

	my $dto = $self->options->{is_datetime};
	$self->setup_datetime_option($dto) if $dto;
	return $self;
}

sub _get_option {
	my ($self, $caller, $wname, $opname) = @_;
	if ($caller && ref($caller)) {
		my $n = "__ht__$wname\_$opname";
		return $caller->{$n} if exists $caller->{$n};
	}
	return $self->options->{$opname};
}

=head2 $widget->name

Returns the name of the widget.

=cut
sub name { return shift()->{name}; }

=head2 $widget->options

Returns hash of options assigned to this widget. See OPTIONS section for
description of available options.

=cut
sub options { return shift()->{_options}; }

=head2 $widget->value_to_string($name, $val, $caller, $stash)

This function is called from C to return final string which will be
rendered into stash. For HTML::Tested::Value it simply returns $val.

C<$caller> is the object calling this function. C<$stash> is read-only hash of
the values accummulated so far.

=cut
sub value_to_string {
	my ($self, $name, $val) = @_;
	return $val;
}

=head2 $widget->encode_value($val)

Uses HTML::Entities to encode $val.

=cut
sub encode_value {
	my ($self, $val) = @_;
	confess ref($self) . "->" . $self->name . ": Non scalar value $val\n"
		. Dumper($val) if ref($val);
	return encode_entities($val, '<>&"' . "'");
}

sub get_default_value {
	my ($self, $caller, $n) = @_;
	my $func = $caller->{"__$n\_defval"} || $self->{__defval};
	return $func->($self, $n, $caller);
}

=head2 $widget->get_value($caller, $id)

It is called from $widget->render to get the value to render. If the value
is C C will be used to get default value for the
widget.

=cut
sub get_value {
	my ($self, $caller, $id, $n) = @_;
	return $caller->{$n} // $self->get_default_value($caller, $n);
}

=head2 $widget->seal_value($value, $caller)

If C option is used, this function is called from $widget->render to
seal the value before putting it to stash.  See HTML::Tested::Seal for sealing
description.

This function maintains cache of sealed values in caller. Thus promising that
the same value will map to the same id during request.

=cut
sub seal_value {
	my ($self, $val, $caller) = @_;
	return HTML::Tested::Seal->instance->encrypt($val);
}

sub transform_value {
	my ($self, $caller, $val, $n) = @_;
	my $func = $caller->{"__$n\_transform"} || $self->{__transform};
	return $func->($self, $val, $caller, $n);
}

sub prepare_value {
	my ($self, $caller, $id, $n) = @_;
	my $val = $self->get_value($caller, $id, $n);
	return undef unless defined($val);
	return $self->transform_value($caller, $val, $n);
}

sub _render_i {
	my ($self, $caller, $stash, $id, $n) = @_;
	my $val = $self->prepare_value($caller, $id, $n);
	return unless defined($val);
	return $self->value_to_string($id, $val, $caller, $stash);
}

=head2 $widget->render($caller, $stash, $id, $name)

Renders widget into $stash. For HTML::Tested::Value it essentially means
assigning $stash->{ $name } with $widget->get_value.

=cut
sub render {
	my ($self, $caller, $stash, $id, $n) = @_;
	my $func = $caller->{"__$n\_render"} || $self->{__render};
	my $res = $func->($self, $caller, $stash, $id, $n);
	$stash->{$n} = $res if defined($res);
}

sub bless_from_tree { return $_[1]; }

=head2 $widget->push_constraint($constraint)

C<$constraint> should be ARRAY reference with the following format:

[ TYPE, OP, COOKIE ]

where C is type of the constraint, C is the operation to be done on
the constraint and cookie is optional method for the application to recognize
specific constraint.

Available types are:

=over

=item C

With OP being regexp string (or C value) (e.g. [ regexp => '\d+' ] or [
regexp => qr/\d+/ ]).

=item C

Ensures that the value is defined. C doesn't matter here
(e.g. [ defined => '' ]).

=item C

Any user defined constraint - second parameter should be function to call.
It gets the value and the caller as the arguments.

For example [ 'my_foo' => sub { my ($v, $caller) = @_; return is_ok? } ].

=back

=cut
sub push_constraint {
	my ($self, $c) = @_;
	my $func;
	push @{ $self->{constraints} }, $c;
	confess "Constraint should be of [ TYPE, OP ] format"
			unless ($c && ref($c) eq 'ARRAY');
	if ($c->[0] eq 'regexp') {
		my $rexp = $c->[1];
		$func = sub {
			my $v = shift;
			return defined($v) ? $v =~ /$rexp/ : undef;
		};
	} elsif ($c->[0] eq 'defined') {
		$func = sub { return defined($_[0]); };
	} elsif ($c->[1]) {
		$func = $c->[1];
	} else {
		confess "Unknown type " . $c->[0] . " found!\n";
	}
	push @{ $self->{validators} }, $func if $func;
}

=head2 $widget->validate($value, $caller)

Validate value returning list of failed constraints in the format specified
above.

I.e. the C<$value> is "constraint-clean" when C returns empty list.

Validate is disabled if C widget option is set.

=cut
sub validate {
	my ($self, $caller) = @_;
	my $n = $self->name;
	my $val = $caller->$n;
	return () if $caller->ht_get_widget_option($n, "no_validate");
	return ([ $n, 'integer' ]) if (defined($val)
			&& $caller->ht_get_widget_option($n, "is_integer")
			&& $val !~ /^\d+$/);
	my $vs = $self->{validators};
	my @res;
	for (my $i = 0; $i < @$vs; $i++) {
		next if $vs->[$i]->($val, $caller);
		push @res, [ $n, @{ $self->{constraints}->[$i] } ];
	}
	return @res;
}

sub unseal_value {
	my ($self, $val, $caller) = @_;
	return HTML::Tested::Seal->instance->decrypt($val);
}

sub merge_one_value { shift()->absorb_one_value(@_); }

=head2 $widget->absorb_one_value($parent, $val, @path)

Parses C<$val> and puts the result into C<$parent> object. C<@path> is used for
widgets aggregating other widgets (such as C).

=cut
sub absorb_one_value {
	my ($self, $root, $val, @path) = @_;
	return if $self->options->{is_trusted};
	$val = $self->unseal_value($val, $root)
			if $self->options->{"is_sealed"};
	my $dtfs = $self->options->{"is_datetime"};
	$val = $dtfs->parse_datetime($val) if $dtfs;
	$root->{ $self->name } = (defined($val) && $val eq ""
			&& !$self->options->{keep_empty_string}) ? undef : $val;
}

sub _set_callback {
	my ($self, $caller, $n, $what, $func) = @_;
	my $obj = ($caller && ref($caller)) ? $caller : $self;
	my $key = ($caller && ref($caller)) ? "__$n\_$what" : "__$what";
	$obj->{$key} = $func;
}

sub _trans_datetime {
	my ($self, $dtfs, $val, $caller, $n) = @_;
	return $dtfs->format_datetime($val) if $val;
}

sub compile {
	my ($self, $caller) = @_;
	my $n = $self->name;
	my $trans = $self->can('encode_value');
	my $func = $self->can('_render_i');
	my $defval = sub { return '' };
	if ($self->_get_option($caller, $n, 'is_disabled')) {
		$func = $defval;
	} elsif (my $dtfs = $self->_get_option($caller, $n, "is_datetime")) {
		$trans = sub { return shift()->_trans_datetime($dtfs, @_); };
	} elsif ($self->_get_option($caller, $n, "is_sealed")) {
		$trans = sub {
			my $this = shift;
			my $val = shift;
			$val = $this->seal_value($val, @_);
			return $this->encode_value($val, @_);
		};
	} elsif ($self->_get_option($caller, $n, "is_trusted")) {
		$trans = sub { return $_[1]; };
	}

	my $dval = $self->_get_option($caller, $n, "default_value");
	if (defined($dval)) {
		$defval = ref($dval) eq 'CODE' ? $dval : sub { return $dval; };
	} elsif ($self->_get_option($caller, $n, "skip_undef")) {
		$defval = sub { return undef; };
	}

	$self->_set_callback($caller, $n, 'render', $func);
	$self->_set_callback($caller, $n, 'transform', $trans);
	$self->_set_callback($caller, $n, 'defval', $defval);
}

1;

=head1 OPTIONS

Options can be used to customize widget behaviour. Each widget is free to
define its own options. They can be set per class or per object using
C. The options can be retrieved using
C.

C defines the following options:

=over

=item is_sealed

The widget value is encrypted before rendering it. The value is decrypted from
the request parameters in transparent fashion.

=item is_disabled

The widget is disabled: it is rendered as blank value.

=item default_value

Default value for the widget. It is rendered if current widget value is
C.

=item skip_undef

Normally, if widget value is C, the widget is rendered as blank value.
When this option is set the widget will not appear in the stash at all.

=item constraints

Array reference containing widget value constraints. See C
documentation for the individual entry format.

=item is_trusted

Do not perform the escaping of special characters on the value. Improperly
setting this option may result in XSS security breach.

=item is_integer

Ensures that the value is integer.

=back

=head1 AUTHOR

Boris Sukholitko ([e-mail])

=head1 COPYRIGHT

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

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

HTML::Tested

=cut