File Coverage

blib/lib/HTML/Prototype/Helper/Tag.pm

Criterion	Covered	Total	%
statement	9	74	12.1
branch	0	28	0.0
condition	0	38	0.0
subroutine	3	16	18.7
pod	6	6	100.0
total	18	162	11.1

package HTML::Prototype::Helper::Tag;

use strict;
use base qw/Class::Accessor::Fast/;
__PACKAGE__->mk_accessors(
    qw/object object_name method_name template_object local_binding auto_index/
);
use vars qw/$USE_ASXML_FOR_TAG/;
$USE_ASXML_FOR_TAG = 0;

=head1 NAME

HTML::Prototype::Helper::Tag - Defines a tag object needed by HTML::Prototype

=head1 SYNOPSIS

	use HTML::Prototype::Helper;

=head1 DESCRIPTION

Defines a tag object needed by HTML::Prototype

=head2 REMARKS

Until version 1.43, the internal function I<$self->_tag> used I<$tag->as_XML>
as its return value. By now, it will use I<$tag->as_HTML( $entities )> to
invokee I. This behaviour can be overridden
by setting I<$HTML::Prototype::Helper::Tag::USE_ASXML_FOR_TAG> to 1.

=head2 METHODS

=over 4

=item HTML::Prototype::Helper::Tag->new( $object_name, $method_name, $template_object, $local_binding, $object )

=cut

sub new {
    my ( $class, $object_name, $method_name, $template_object, $local_binding,
        $object )
      = @_;

    my $self = $class->SUPER::new();

    $self->object($object);
    $self->object_name($object_name);
    $self->method_name($method_name);
    $self->template_object($template_object);
    $self->local_binding($local_binding);

    if ( $object_name =~ s/\[\]$// ) {
        $self->auto_index( $self->template_object->instance_variable_get($`) );
        $self->object_name($object_name);
    }

    return $self;
}

=item $tag->object_name( [$object_name] )

=item $tag->method_name( [$method_name] )

=item $tag->template_object( [$template_object] )

=item $tag->local_binding( [$local_binding] )

=item $tag->object( [$object] )

=cut

sub object {
    my $self = shift;
    @_ = ( $self->template_object->instance_variable_get( $self->object_name ) )
      unless @_;
    return $self->_object_accessor(@_);
}

=item $tag->value( )

=cut

sub value {
    my $self    = shift;
    my $coderef =
      $self->object ? $self->object->can( $self->method_name ) : undef;
    return $coderef ? $self->object->$coderef() : '';
}

=item $tag->value_before_type_cast( )

=cut

sub value_before_type_cast {
    my $self = shift;

    my $value = '';
    if ( defined $self->object ) {
        my $coderef =
             $self->object->can( $self->method_name . '_before_type_cast' )
          || $self->object->can( $self->method_name );
        $value = $self->object->$coderef() if $coderef;
    }

    return $value;
}

=item $tag->to_input_field_tag( $field_type, \%options )

=cut

sub to_input_field_tag {
    my ( $self, $field_type, $options ) = @_;

    $options ||= {};
    $options->{size} ||= $options->{maxlength} || 30;
    delete $options->{size} if 'hidden' eq lc $field_type;
    $options->{type} = $field_type;
    $options->{value} ||= $self->value_before_type_cast()
      unless 'file' eq lc $field_type;

    $self->_add_default_name_and_id($options);
    return $self->_tag( "input", $options );
}

=item $tag->to_content_tag( $tag_name, $value, \%options )

=cut

sub to_content_tag {
    my ( $self, $tag_name, $options ) = @_;

    return $self->_content_tag( $tag_name, $self->value(), $options || {} );
}

sub _add_default_name_and_id {
    my ( $self, $options ) = @_;

    $options ||= {};

    my $index;
    if (   ( $index = delete $options->{index} )
        || ( $index = $self->auto_index ) )
    {
        $options->{name} ||= $self->_tag_name_with_index($index);
        $options->{id}   ||= $self->_tag_id_with_index($index);
    }
    else {
        $options->{name} ||= $self->_tag_name;
        $options->{id}   ||= $self->_tag_id;
    }
}

sub _tag_name {
    my $self = shift;

    return $self->object_name . '[' . $self->method_name . ']';
}

sub _tag_name_with_index {
    my ( $self, $index ) = @_;

    return $self->object_name . '[' . $index . '][' . $self->method_name . ']';
}

sub _tag_id {
    my $self = shift;

    return $self->object_name . '_' . $self->method_name;
}

sub _tag_id_with_index {
    my ( $self, $index ) = @_;

    return $self->object_name . '_' . $index . '_' . $self->method_name;
}

sub _tag {
    my ( $self, $name, $options, $starttag ) = @_;
    $starttag ||= 0;
    $options  ||= {};
    my $entities =
      defined $options->{entities}
      ? delete $options->{entities}
      : '<>&';
    my $tag = HTML::Element->new( $name, %$options );
    if ($starttag) {
        return $tag->starttag($entities);
    }
    elsif ($USE_ASXML_FOR_TAG) {
        return $tag->as_XML;
    }
    else {
        $tag->as_HTML($entities);
    }
}

sub _content_tag {
    my ( $self, $name, $content, $html_options ) = @_;
    $html_options ||= {};
    my $entities =
      defined $html_options->{entities}
      ? delete $html_options->{entities}
      : '<>&';
    my $tag = HTML::Element->new( $name, %$html_options );
    $tag->push_content( ref $content eq 'ARRAY' ? @{$content} : $content );
    return $tag->as_HTML($entities);
}

=back

=head1 SEE ALSO

L, L

=head1 AUTHOR

Sascha Kiefer, C

Built around Prototype by Sam Stephenson.
Much code is ported from Ruby on Rails javascript helpers.

=head1 LICENSE

This library is free software. You can redistribute it and/or modify it under
the same terms as perl itself.

=cut

1;