root/lang/perl/HTML-AutoForm/trunk/lib/HTML/AutoForm.pm @ 25405

package HTML::AutoForm;

use strict;
use warnings;
use utf8;
use Scalar::Util;

use Class::Accessor::Lite;
use HTML::AutoForm::Error;
use HTML::AutoForm::Field;
use HTML::AutoForm::Field::AnyText;
use HTML::AutoForm::Field::InputCheckable;
use HTML::AutoForm::Field::InputSet;
use HTML::AutoForm::Field::Checkbox;
use HTML::AutoForm::Field::Hidden;
use HTML::AutoForm::Field::Radio;
use HTML::AutoForm::Field::Option;
use HTML::AutoForm::Field::Password;
use HTML::AutoForm::Field::Select;
use HTML::AutoForm::Field::Text;
use HTML::AutoForm::Field::Textarea;

our $VERSION;
our %Defaults;
our $DEFAULT_LANG;

BEGIN {
    $VERSION = '0.01';
    %Defaults = (
        secure => 1,
        action => undef,
        fields => undef, # need to be copied
    );
    Class::Accessor::Lite->mk_accessors(keys %Defaults);
    $DEFAULT_LANG = 'en';
};

sub load_locale {
    my $klass = shift;
    my $locale = shift;
    require "HTML/AutoForm/Error/${locale}.pm";
}

sub new {
    my $klass = shift;
    my %args = @_ == 1 ? %{$_[0]} : @_;
    my $fields = delete $args{fields} || [];
    for my $n qw(action) {
        die 'mandatory attribute "' . $n . '" is missing'
            unless defined $args{$n};
    }
    my $self = bless {
        %Defaults,
        %args,
        fields => [], # filled afterwards
    }, $klass;
    die 'fields should be supplied in: tag => attributes style'
        unless @$fields % 2 == 0;
    for (my $i = 0; $i < @$fields; $i += 2) {
        my $name = $fields->[$i];
        my $opts = $fields->[$i + 1];
        die 'field type is missing or invalid'
            unless $opts->{type} =~ /^(text|hidden|password|radio|select|checkbox|textarea)$/;
        my $field_klass = 'HTML::AutoForm::Field::' . ucfirst $opts->{type};
        push @{$self->{fields}}, $field_klass->new(
            %$opts,
            name => $name,
        );
    }
    $self;
}

sub field {
    my ($self, $n) = @_;
    for my $f (@{$self->{fields}}) {
        return $f
            if $f->name eq $n;
    }
    return;
}

# the default renderer
sub render {
    my ($self, $app) = @_;
    my $query = $app->query;
    
    my $do_validate = $query->request_method eq 'POST'
            || (! $self->secure && %{$query->Vars});
    
    my $html = join(
        '',
        '<form action="',
        _escape_html($self->action),
        '"',
        ($self->secure ? ' method="POST"' : ''),
        '>',
        '<table class="autoform_table">',
        (map {
            sub {
                my $field = shift;
                my @values = $query->param($_->name);
                if ($field->type eq 'hidden') {
                    return ${$_->render(\@values)};
                }
                my @r = (
                    '<tr><th>',
                    _escape_html($field->label),
                    '</th><td>',
                    ${$field->render(\@values)},
                );
                if ($do_validate) {
                    print STDERR "validating: ", $field->name, "\n";
                    if (my $err = $field->validate(\@values)) {
                        push(
                            @r,
                            '<div class="autoform_error">',
                            _escape_html('※' . $err->message),
                            '</div>',
                        );
                    }
                }
                push @r, '</td></tr>';
                @r;
            }->($_)
        } @{$self->{fields}}),
        $self->secure
            ? (
                '<input type="hidden" name="__nanoa_csrf_key" value="',
                # TODO: use a different id
                _escape_html($app->session->session_id),
                '" />',
            ) : (),
        '<tr><th></th><td><input type="submit" value="投稿する" /></td></tr>',
        '</table></form>',
    );
    $html;
}

sub validate {
    my ($self, $app) = @_;
    my $query = $app->query;
    
    for my $f (@{$self->{fields}}) {
        if (my $error = $f->validate($query)) {
            return;
        } elsif (my $h = $f->custom) {
            if (my $error = $h->($f, $query)) {
                return;
            }
        }
    }
    if ($self->secure) {
        my $ok;
        if (my $csrf_key = $query->param('__nanoa_csrf_key')) {
            if ($csrf_key eq $app->session->session_id) {
                $ok = 1;
            }
        }
        return
            unless $ok;
    }
    1;
}

sub _build_element {
    my ($tag, $base, $extra, $omit, $append) = @_;
    my %attr = (
        (map {
            ($_ => $base->{$_})
        } grep {
            ! exists $omit->{$_} && ! /^(allow_multiple|label|required)$/
        } keys %$base),
        %$extra,
    );
    my $html = join(
        '',
        '<' . $tag,
        (map {
            ' ' . $_ . '="' . _escape_html($attr{$_}) . '"'
        } sort grep {
            defined $attr{$_}
        } keys %attr),
        defined $append ? ('>', $append, '</', $tag, '>') : ' />',
    );
    $html;
}

sub _escape_html {
    my $str = shift;
    $str =~ s/&/&amp;/g;
    $str =~ s/>/&gt;/g;
    $str =~ s/</&lt;/g;
    $str =~ s/"/&quot;/g;
    $str =~ s/'/&#39;/g;
    $str;
}

1;

__END__

=head1 NAME

HTML::AutoForm - a standalone HTML form validator and renderer

=head1 SYNOPSIS

    # build form object
    my $form = HTML::AutoForm->new(
        fields => [
            username => {
                type       => 'text',
                required   => 1,
                min_length => 6,
                max_length => 8,
                regexp     => qr/^[0-9a-z_]+$/,
            },
            password => {
                type       => 'password',
                required   => 1,
                min_length => 8,
                regexp     => qr/^[0-9A-Za-z_-]+$/,
            },
            password2 => {
                type       => 'password',
                label      => 'Password (repeat)',
                required   => 1,
                validate   => sub {
                    my $q = shift;
                    $q->param('password') eq $q->param('password2');
               },
            },
            sex  => {
                type       => 'radio',
                options    => [
                    male   => {},
                    female => {},
                },
                required   => undef,
            },
            country => {
                type       => 'select',
                options    => [ qw/Australia Japan .../, ],
                required   => 1,
            },
            # add more
        ],
    );

=head1 DESCRIPTION

HTML::AutoForm is a simple form validator and renderer.

=head1 METHODS

=head2 new

=head2 secure

=head2 action

=head2 fields

=head2 field

=head2 render

=head2 validate

=head2 load_locale

=head1 AUTHOR

Kazuho Oku E<lt>kazuhooku !@#$%^&* gmail.comE<gt>

=head1 LICENSE

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

=cut