HTML::Field - Generation of HTML form elements

 use HTML::Field;

 ########## Creation of Field objects ##############

 # A text field:
 my $field1 = HTML::Field->new('Textfield',
                  name      => 'fieldname',
                  value     => 'current value',
                  default   => 'default value',
                  size      => 15,
                  maxlength => 15 );

 # A Pasword field (has the same attributes as 'Textfield'):
 my $field2 = HTML::Field->new('Passwd',
                  name      => 'fieldname',
                  value     => 'current value',
                  default   => 'default value',
                  size      => 15,
                  maxlength => 15 );

 # A hidden field:
 my $hidden = HTML::Field->new('Hidden',
                  name      => 'sid',
                  value     => 'cgiasf25k',
                  default   => undef );

 # A text area:
 my $area = HTML::Field->new('Textarea',
                  name      => 'address',
                  cols      => 40,
                  rows      => 4 );

 # A 'select' tag. Options are given in an array reference; labels are  
 # given in a hash keyed by the options: 
 my $select = HTML::Field->new('Select',
                  name      => 'select_color',
                  options   => [qw(red yellow brown)],
                  default   => 'red',
                  labels    => {red    => 'Color of apples',
                                yellow => 'Color of mangos!',
                                brown  => 'Color of chocolate'},
                  multiple  => undef,  # Multiple is either true or false
                  size      => 1 );    # Size of select box

 # A radio button. Note that it will generate the HTML for all of its
 # options, and those will be named as 'name_option'
 my $radio_buttons = HTML::Field->new('Radio',
                  name      => 'Flavors',
                  options   => [qw(Lemon Strawberry Grapefruit)],
                  default   => 'Grapefruit' );

 # A single checkbox:
 my $checkbox = HTML::Field->new('Checkbox', 
                  name      => 'Additional',
                  option    => 'Strawberry',
                  default   => 1,
                  read_only_tags => { true => 'X', false => 'o'});

 # Render editable HTML
 my ($key, $value) = $field->editable_html;

 # Render read-only value
 ($key, $value) = $field->readonly_html;

 # Render editable HTML for a new element
 ($key, $value) = $field->creation_html;

 # Set a field's value from a CGI object, hash reference or scalar:
 my $value = $field->value($cgi);

 # or, get the filed's value:
 $value = $field->value;

 


 # The 'read_only_tags' attribute sets the representation of a
 # check box or of radio buttons for a 'read only' rendering. 
 # This feature can be used to load different images to represent
 # 'checked' radio buttons or check boxes.

 # Primary Key text field:
 my $field1 = HTML::Field->new('Textfield',
                  name        => 'login',
                  size        => 15,
                  maxlength   => 15,
                  primary_key => 1 );

 # When a text field is marked as 'primary' key, then
 # it will not be editable once it has a value. This means that if you 
 # are displaying an empty form this will be an editable text field, 
 # but if you are displaying a database record for edition, then this 
 # field will not be editable and it will also be present as a hidden
 # field in order to get sent back to the script.

 # Primary key autogenerated by the database:
 my $serial = HTML::Field->new('Textfield',
                  name        => 'company_id',
                  size        => 4,
                  maxlength   => 4,
                  auto        => 1 );

 # The same as above applies if the field value is generated by the 
 # database. In that case, the  value will never be editable; if the 
 # field has no value then a place holder will be returned instead. 

 $field->value($cgi);
 $field->value($hash_ref);
 $field->value(4);

 field_option

package HTML::Field;

use Carp;
use strict;

our $AUTOLOAD;
our $VERSION = '1.19';
our $XHTML   = 0;

# The following hash contains HTML attributes common to all form elements.
# By modifying the values of the hash you would actually change the default
# value since it is fed directly into the object during its creation.
my %autoloadable = (
    accesskey => undef,
    id        => undef,
    title     => undef,
    class     => undef,
    style     => undef,
    lang      => undef,
    dir       => undef,
    disabled  => undef,
    readonly  => undef,
    tabindex  => undef
);

# These are the available field types
my %packages = (
    Textfield   => 'HTML::Field::Textfield',
    Textarea    => 'HTML::Field::Textarea',
    Checkbox    => 'HTML::Field::Checkbox',
    Hidden      => 'HTML::Field::Hidden',
    Password    => 'HTML::Field::Password',
    Radiobutton => 'HTML::Field::Radiobutton',
    Radio       => 'HTML::Field::Radio',
    Select      => 'HTML::Field::Select',
);

# The following class method switches from HTML to XHTML 
sub xhtml {
    my $class = shift;
    my $xhtml = shift;

    if ( defined $xhtml ) {
        $XHTML = $xhtml;
    }
    return $XHTML;
}

# This is the constructor for the class and its descendants. 
# Each descendant class is responsible of adding attributes  
# to the different lists (_autoloadable, etc).               

sub new {
    my $super = shift;
    my $type  = shift;

    # Check if the required type exists
    my $class = $packages{$type};
    croak "Type $type was not recognized\n" unless defined $class;

    # Create object of the requested type
    my $self = {
        name        => undef,
        default     => undef,
        value       => undef,
        primary_key => undef,
        auto        => undef,

        # List of  valued html tag attributes used
        # to generate the tags (like size="10")
        _valued_html_attr =>
          [qw(accesskey id title class style lang dir tabindex)],

        # List of non-valued html tag attributes used to generate
        # the tags (like 'checked' in a radio button)
        _nonvalued_html_attr => [qw(disabled readonly)],

        # Hash of object attributes whose accessors/mutators 
        # will be through AUTOLOAD
        _autoloadable => {%autoloadable},

        # Defaults for the autoloadable, Field class attributes
        %autoloadable,

        # And finally consider what the user wants!
        @_
    };
    bless $self, $class;

    croak "You must name your $class!"
      unless defined $self->name;    # Name is a mandatory argument

    $self->reset_value
      unless defined $self->value;   # Enforce default

    # Now perform any subclass-specific initialization
    $self->initialize;

    return $self;
}

sub name {
    my $self = shift;

    croak 'You cannot modify the name of a ' . ref $self if @_;
    return $self->{name};
}

sub default {
    my $self = shift;
    $self->{default} = shift if (@_);
    return $self->{default};
}

# Shall receive a scalar value, a hash of values from which it has to pick
# its value (one to one) or else a CGI object (many values to one field).
# In case there are several form elements to pick from the given object, 
# then this method would be overriden by a subclass, which would then
# compute a scalar value.
# It returns the value of the field (after modification, if any).
sub value {
    my $self = shift;
    if (@_) {
        my $value = shift;
      SWITCH: {
            ref($value) eq 'CGI'
              && do {
                $self->{value} = $value->param( $self->name );
                last SWITCH;
              };
            ref($value)
              && do {
                $self->{value} = $value->{ $self->name };
                last SWITCH;
              };
            $self->{value} = $value;
        }
    }
    return $self->{value};
}

# This one sets the value of a field equal to the default
sub reset_value {
    my $self = shift;
    $self->value( $self->default );
    return;
}

# This method will display the read-only value of the field. It must
# be overriden by those fields whose read only html is different from their
# simple value or by those of multiple fields.
# It returns a list of name, value pairs that can be used to build a hash
# suitable for HTML::Template.
sub readonly_html {
    my $self = shift;
    return ( $self->name, $self->value );
}

# This method should return the HTML form element that will be used to
# display the editable fields.
# It MUST be overriden.
# It must return a list of name, value pairs that can be used to build a
# hash suitable for HTML::Template.
sub editable_html {
    my $self = shift;
    carp "The html method in class " 
        . ref($self) . " has not been implemented"
        ;
}

# create_html will return the editable HTML form element that will be used
# for record creation. It will allow for primary key edition (except
# for fields marked as auto.)
sub creation_html {
    my $self = shift;
    return $self->editable_html;
}

# This method will help for the generation of HTML tags by generating the
# attributes list of every tag.
sub _editable_html {
    my $self = shift;
    my $tag  = '';
    foreach ( @{ $self->{_valued_html_attr} } ) {
        $tag .= " $_=\"" . $self->$_ . '"' if defined $self->$_;
    }
    foreach ( @{ $self->{_nonvalued_html_attr} } ) {
        if ( $self->$_ ) {
            $tag .= " $_";
            $tag .= qq{="$_"} if $self->xhtml;
        }
    }
    return $tag;
}

#   Autoload routine to create simple accessor/mutators      #
#   for descendants of this class. Note that descendants     #
#   must have a '_autoloadable' field containing a hash      #
#   reference with the list of fields that can be accessed   #
#   using this routine.                                      #
sub AUTOLOAD {
    my $self = shift;
    my $type = ref($self) || croak 'Called a non-existent class method';
    my $name = $AUTOLOAD;
    $name =~ s/.*:://;
    return unless $name =~ /[^A-Z]/;
    croak "Cannot access method '$name' in class $type"
      unless ( exists $self->{_autoloadable}->{$name} );
    if (@_) {
        return $self->{$name} = shift;
    }
    else {
        return $self->{$name};
    }
}

#####################################################################
#####################################################################
##################### Subclasses begin here #########################
#####################################################################
#####################################################################

package HTML::Field::Checkbox;

use Carp;
use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

# read_only_tags are the representations of the checkbox in a non-editable
# scenario. You can pass any text you want to represent a 'true' state
# or a 'false' state, like images or other characters.
sub initialize {
    my $self = shift;
    $self->{readonly_tags} = { true => '+', false => '-' }
      unless defined $self->{readonly_tags};
    push @{ $self->{_nonvalued_html_attr} }, 'checked';
    return $self;
}

# Value is only boolean.
my %true  = map { $_ => 1 } ( 1, 'on',  'ON',  'On',  't', 'T' );
my %false = map { $_ => 1 } ( 0, 'off', 'OFF', 'Off', 'f', 'F' );

sub value {
    my $self = shift;
    if (@_) {
        $self->SUPER::value(@_);

        if ( defined $self->{value} && exists $true{ $self->{value} } ) {
            $self->{value} = 1;
        }
        elsif ( not( defined $self->{value} )
            || exists $false{ $self->{value} } )
        {
            $self->{value} = undef;
        }
        else {
            croak "Unrecognized value for checkbox: $self->{value}\n";
        }
    }
    return $self->{value};
}

sub checked {
    my $self = shift;
    return $self->value;
}

sub editable_html {
    my $self = shift;
    my $field =
        '<input type="checkbox" name="'
      . $self->name . '"'
      . ' value="on"'
      ;
    if ($self->checked) {
        $field .= 'checked';
        $field .= '="checked"' if $self->xhtml;
    }
    $field .= $self->_editable_html;
    $field .= HTML::Field->xhtml ? '/>' : '>';
    return ( $self->name, $field );
}

sub readonly_tags {
    my $self = shift;
    if (@_) {
        my %args = @_;
        croak 
            "readonly_tags must be called with the following arguments:\n"
            . "true => 'representation t', false => 'representation f'"
            unless ( exists $args{true} && exists $args{false} )
            ;
            
        $self->{readonly_tags} = \%args;
        return;
    }
    if ( $self->value ) {
        return $self->{readonly_tags}->{'true'};
    }
    else {
        return $self->{readonly_tags}->{'false'};
    }
}

sub readonly_html {
    my $self = shift;
    return ( $self->name, $self->readonly_tags );
}

#####################################################################
#####################################################################
#####################################################################

package HTML::Field::Hidden;

use Carp;
use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

sub initialize {
    my $self = shift;
    $self->{_autoloadable}->{auto}++;
    return $self;
}

sub creation_html {
    my $self = shift;

    return ( $self->name, '<!-- auto generated primary key -->' )
      if ( $self->{auto} );

    return $self->editable_html;
}

sub editable_html {
    my $self = shift;
    croak 'All hidden fields must have a value'
      unless defined $self->value;
    my $tag =
        '<input type="hidden" name="'
      . $self->name
      . '" value="'
      . $self->value . '"'
      ;
    $tag .= HTML::Field->xhtml ? '/>' : '>';
    return ( $self->name, $tag );
}

sub readonly_html {
    my $self = shift;
    return ($self->name, '<!-- Hidden field -->');
}

#####################################################################
#####################################################################
#####################################################################

package HTML::Field::Password;

use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

sub initialize {
    my $self = shift;
    push @{ $self->{_valued_html_attr} }, 'size', 'maxlength';
    foreach (qw{size maxlength}) {
        $self->{_autoloadable}->{$_}++;
    }
    return $self;
}

sub editable_html {
    my $self = shift;
    my $field =
        '<input type="password" name="'
      . $self->name . '"'
      . $self->_editable_html
      ;
    $field .= ' value="' . $self->value . '"' if defined $self->value;
    $field .= HTML::Field->xhtml() ? '/>' : '>';
    return ( $self->name, $field );
}

sub readonly_html {
    return '*****';
}

#####################################################################
#####################################################################
#####################################################################

package HTML::Field::Select;

use Carp;
use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

sub initialize {
    my $self = shift;
    push @{ $self->{_valued_html_attr} },    'size';
    push @{ $self->{_nonvalued_html_attr} }, 'multiple';
    foreach (qw{size multiple options labels}) {
        $self->{_autoloadable}->{$_}++;
    }

    croak "HTML::Field::Select object does not contain options\n"
      unless ( defined $self->options
        && ref( $self->options ) eq 'ARRAY' );

    croak "HTML::Field::Select labels should be a hash reference\n"
      if ( defined $self->labels && ref( $self->labels ) ne 'HASH' );

    return $self;
}

sub editable_html {
    my $self = shift;

    croak "HTML::Field::Select object does not contain options\n"
      unless ( defined $self->options
        && ref( $self->options ) eq 'ARRAY' );

    croak "HTML::Field::Select labels should be a hash reference\n"
      if ( defined $self->labels && ref( $self->labels ) ne 'HASH' );

    my %labels;
    if ( defined $self->labels ) {
        %labels = %{ $self->labels };
    }

    my $field =   '<select name="' 
                . $self->name 
                . '"' 
                . $self->_editable_html
                . '>'
                ;

    foreach my $option ( @{ $self->options } ) {
        $field .= "\n\t<option value=\"$option\"";
        if ( defined $self->value && $self->value eq $option ) {
            $field .=
              HTML::Field->xhtml
              ? ' selected="selected"'
              : ' selected';
        }
        $field .= '>';
        if ( defined $labels{$option} ) {
            $field .= "$labels{$option}</option>";
        }
        else {
            $field .= "$option</option>";
        }
    }
    $field .= "\n</select>";
    return ( $self->name, $field );
}

sub readonly_html {
    my $self = shift;
    return '-----' unless defined $self->value;
    if (defined $self->labels && exists $self->labels->{ $self->value }) {
        return ( $self->name, $self->labels->{ $self->value } );
    }
    else {
        return ( $self->name, $self->value );
    }
}


#####################################################################
#####################################################################
#####################################################################

package HTML::Field::Radio;

use Carp;
use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

sub initialize {
    my $self = shift;

    $self->{_autoloadable}->{options}++;
    croak "A radio button must have an array of 'options'"
      unless ( defined $self->options
        && ref( $self->options ) eq 'ARRAY' );

    $self->{readonly_tags} = { true => '+', false => '-' }
      unless defined $self->{readonly_tags};

    return $self;
}

sub readonly_tags {
    my $self = shift;
    if (@_) {
        my %args = @_;
        croak 
            "read_only_tags must be called with the following arguments:\n"
          . "true => 'representation t', false => 'representation f'"
          unless ( exists $args{true} && exists $args{false} );
        $self->{readonly_tags} = \%args;
        return;
    }

    return $self->{readonly_tags};
}

sub editable_html {
    my $self = shift;

    croak "HTML::Field::Radio object does not contain options\n"
      unless ( defined $self->options
        && ref( $self->options ) eq 'ARRAY' );
    
    my %tags;
    foreach my $opt ( @{ $self->options } ) {
        my $name = $self->name . '_' . $opt;
        $tags{$name} = '<input type="radio" name="' 
            . $self->name . '" option="' . $opt . '"'
            . $self->_editable_html
            ;
        if ( $self->value eq $opt ) {
            $tags{$name} .= ' checked';
            $tags{$name} .= q{="checked"} if $self->xhtml;
        }
        $tags{$name} .= $self->xhtml ? '/>' : '>';
    }
    
    return %tags;
}

sub readonly_html {
    my $self = shift;
    
    my %tags;
    foreach my $opt ( @{ $self->options } ) {
        my $name = $self->name . '_' . $opt;
        $tags{$name} = 
            $self->value eq $opt
                ? $self->readonly_tags->{true}
                : $self->readonly_tags->{false}
                ;
    }
    
    return %tags;
}

#####################################################################
#####################################################################
#####################################################################

package HTML::Field::Textarea;

use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

sub initialize {
    my $self = shift;
    push @{ $self->{_valued_html_attr} }, 'cols', 'rows';
    foreach ( 'cols', 'rows' ) {
        $self->{_autoloadable}->{$_}++;
    }
    return $self;
}

sub editable_html {
    my $self = shift;
    my $field =
      '<textarea name="' . $self->name . '"' . $self->_editable_html . '>';
    $field .= $self->value if defined $self->value;
    $field .= '</textarea>';
    return ( $self->name, $field );
}

#####################################################################
#####################################################################
#####################################################################

package HTML::Field::Textfield;

use strict;
use vars qw(@ISA);

@ISA = ('HTML::Field');

sub initialize {
    my $self = shift;
    push @{ $self->{_valued_html_attr} }, 'size', 'maxlength';
    foreach (qw{size maxlength auto primary_key}) {
        $self->{_autoloadable}->{$_}++;
    }
    return $self;
}

sub creation_html {
    my $self = shift;

    return ( $self->name, '<!-- auto generated primary key -->' )
      if ( $self->{auto} );

    return $self->_generate_html;
}

sub editable_html {
    my $self = shift;

    # If this field is a primary key or if it is marked as 'auto'
    # and has a value, then it should not be editable but it should return
    # its read-only value and a hidden field:
    if (  ( defined $self->{primary_key} || defined $self->{auto} )
        &&  defined $self->value )
    {
        my $field = $self->value
          . ' <input type="hidden" name="'
          . $self->name
          . '" value="'
          . $self->value
          . '"'
          ;
        $field .= HTML::Field->xhtml ? '/>' : '>';
        return ( $self->name, $field );
    }

    return $self->_generate_html;
}

# Finally, this method generates the standard text field
sub _generate_html {
    my $self = shift;
    my $field = '<input type="text" name="' 
                . $self->name . '"' 
                . $self->_editable_html
                ;
    $field .= ' value="' . $self->value . '"' if defined $self->value;
    $field .= HTML::Field->xhtml() ? '/>' : '>';
    return ( $self->name, $field );
}

1;

# $Id: Field.pm,v 1.19 2009/11/26 00:37:41 julio Exp $
# $Log: Field.pm,v $
# Revision 1.19  2009/11/26 00:37:41  julio
# Corrected test requirement in Textfield.t
#
# Revision 1.18  2009/06/27 22:46:03  julio
# Removed attribute 'wrap' from Textarea
#
# Revision 1.17  2009/05/27 23:21:45  julio
# Updated $VERSION
#
# Revision 1.16  2009/05/27 22:51:10  julio
# If an object other than CGI is given to the value method, it is
# assumed to work as a hash reference. This includes hash references.
# This is to work with DBIx::DataModel based classes.
# Miscellaneous changes to the documentation.
#
# Revision 1.15  2009/05/01 22:05:31  julio
# Fixed problem with hidden fields' readonly_html.
#
# Revision 1.14  2009/05/01 21:50:23  julio
# Fixed bug in checkbox. It was not returning the html field correctly
# when the field was valued.
#
# Revision 1.13  2009/05/01 05:13:29  julio
# Completed documentation on each subclass and fixed Hidden, Textfield
# and Checkbox to conform to the new docs.
#
# Revision 1.12  2009/04/28 20:18:45  julio
# Removed Radiobutton.
#
# Revision 1.11  2009/04/28 20:15:54  julio
# Added HTML::Field::Radio
#
# Revision 1.10  2009/04/27 04:13:31  julio
# After a looong time!
#
# Revision 1.9  2007/10/13 03:51:30  julio
# HTML::Field::Hidden no longer needs to know its value at creation time.
#
# Revision 1.8  2007/09/27 05:59:42  julio
# Added documentation regarding 'default' for HTML::Field::Checkbox.
# Fixed redundant condition in _editable_html.
#
# Revision 1.7  2007/09/26 04:41:22  julio
# Added xhtml switch! I still need to do tests
# and documentation; the current tests passed OK.
#
# Revision 1.6  2007/08/12 02:24:58  julio
# Added method creation_html, docs and tests
#
# Revision 1.5  2007/08/10 02:57:17  julio
# Integrated POD into this file
#
# Revision 1.4  2007/08/10 01:49:45  julio
# Only ran perltidy on this file
#
# Revision 1.3  2007/08/10 01:26:32  julio
# Added logic to implement primary_key and auto into text fields
#
# Revision 1.2  2006/12/10 01:33:11  julio
# Improved test coverage for parent class
#
# Revision 1.1  2006/12/10 00:34:52  julio
# Initial revision
#
# Revision 0.0  2006/12/01 03:26:05  julio
# Initial revision