File Coverage

blib/lib/WWW/Mechanize/FormFiller.pm

Criterion	Covered	Total	%
statement	144	144	100.0
branch	48	54	88.8
condition	7	9	77.7
subroutine	19	19	100.0
pod	5	8	62.5
total	223	234	95.3

package WWW::Mechanize::FormFiller;
use strict;
use Carp;

use vars qw( $VERSION @ISA );

$VERSION = '0.13';
@ISA = ();

sub load_value_class {
  my ($class) = @_;
  if ($class) {
    no strict 'refs';

    my $full_class = "WWW::Mechanize::FormFiller::Value::$class";

    unless (defined eval '${' . $full_class . '::VERSION}') {
      eval "use $full_class";
      Carp::confess $@ if $@;
    };
  } else {
    Carp::croak "No class name given to load" unless $class;
  };
};

sub new {
  my ($class,%args) = @_;
  my $self = {
    values => {},
    default => undef
  };
  bless $self, $class;

  if (exists $args{default}) {
    my ($class,@args) = @{$args{default}};
    load_value_class($class);
    no strict 'refs';
    $self->{default} = "WWW::Mechanize::FormFiller::Value::$class"->new(undef, @args);
  };

  if (exists $args{values}) {
    if (ref $args{values} eq 'ARRAY') {
      for my $value (@{$args{values}}) {
        if (ref $value eq 'ARRAY') {
          my ($name,$class,@args) = @$value;
          if ($class) {
            $self->add_filler( $name, $class, @args );
          } else {
            Carp::croak "Each element of the values array must have at least 2 elements (name and class)" unless defined $class;
            Carp::croak "Each element of the values array must have a class name" unless $class;
          };
        } else {
          Carp::croak "Each element of the values array must be an array reference";
        };
      }
    } else {
      Carp::croak "values parameter must be an array reference";
    };
  };
  return $self;
};

sub add_filler {
  my ($self,$name,$class,@args) = @_;
  load_value_class($class);

  if ($class) {
    no strict 'refs';
    $self->add_value( $name, "WWW::Mechanize::FormFiller::Value::$class"->new($name, @args));
  } else {
    Carp::croak "A value must have at least a class name and a field name (which may be undef though)" ;
  };
};

sub add_value {
  my ($self, $name, $value) = @_;
  if (ref $name and UNIVERSAL::isa($name,'Regexp')) {
    $self->{values}->{byre}->{$name} = $value;
  } else {
    $self->{values}->{byname}->{$name} = $value;
  };
  $value;
};

sub default {
  my ($self,$newdefault) = @_;
  my $result = $self->{default};
  $self->{default} = $newdefault if (@_ > 1);
  $result;
};

sub find_filler {
  my ($self,$input) = @_;
  croak "No input given" unless defined $input;
  my $value;
  if (exists $self->{values}->{byname}->{$input->name()}) {
    $value = $self->{values}->{byname}->{$input->name};
  } elsif (grep { $input->name =~ /$_/ } keys %{$self->{values}->{byre}}) {
    my $match = (grep { $input->name =~ /$_/ } keys %{$self->{values}->{byre}})[0];
    $value = $self->{values}->{byre}->{$match};
  } elsif ($input->type eq "image") {
    # Image inputs are really buttons, and if they have no (user) specified value,
    # we don't ask about them.
  } elsif ($self->default) {
    $value = $self->default();
  };
  $value;
};

sub fill_form {
  my ($self,$form) = @_;
  for my $input ($form->inputs) {
    my $value = $self->find_filler($input);
    # We leave all values alone whenever we don't know what to do with them
    if (defined $value) {
      # Hmm - who cares about whether a value was hidden/readonly ??
      no warnings;
      local $^W = undef;
      my $v = $value->value($input);
      undef $v if ($input->type() eq "checkbox" and $v eq "");
      eval { $input->value( $v ) };
      $@ and croak "Field '" .$input->name. "' had illegal value: $v";
    };
  };
};

sub fillout {
  my $self_class = shift;
  my $self = ref $self_class ? $self_class : $self_class->new();
  my $form;

  while (@_) {
    if (ref $_[0] and eval { UNIVERSAL::isa($_[0],'HTML::Form') }) {
      croak "Two HTML::Form objects passed into fillout()" if ($form);
      $form = shift;
    } else {
      my $field = shift;
      if (ref $_[0] eq 'ARRAY') {
        my $args = shift;
        $self->add_filler($field,@$args);
      } else {
        my $value = shift;
        $self->add_filler($field,'Fixed',$value);
      };
    };
  };
  $self->fill_form($form) if $form;
  $self;
};

1;
__END__