File Coverage

blib/lib/WWW/Mechanize.pm

Criterion	Covered	Total	%
statement	844	881	95.8
branch	423	480	88.1
condition	227	264	85.9
subroutine	105	109	96.3
pod	76	76	100.0
total	1675	1810	92.5

package WWW::Mechanize;

#ABSTRACT: Handy web browsing in a Perl object


use strict;
use warnings;

our $VERSION = '2.16';

use Tie::RefHash ();
use HTTP::Request 1.30 ();
use HTML::Form 1.00 ();
use HTML::TokeParser ();
use Scalar::Util qw( tainted );

use base 'LWP::UserAgent';

our $HAS_ZLIB;
BEGIN {
    $HAS_ZLIB = eval {require Compress::Zlib; 1;};
}


sub new {
    my $class = shift;

    my %parent_params = (
        agent       => "WWW-Mechanize/$VERSION",
        cookie_jar  => {},
    );

    my %mech_params = (
        autocheck       => ($class eq 'WWW::Mechanize' ? 1 : 0),
        onwarn          => \&WWW::Mechanize::_warn,
        onerror         => \&WWW::Mechanize::_die,
        quiet           => 0,
        stack_depth     => 8675309,     # Arbitrarily humongous stack
        headers         => {},
        noproxy         => 0,
        strict_forms    => 0,           # pass-through to HTML::Form
        verbose_forms   => 0,           # pass-through to HTML::Form
        marked_sections => 1,
    );

    my %passed_params = @_;

    # Keep the mech-specific params before creating the object.
    while ( my($key,$value) = each %passed_params ) {
        if ( exists $mech_params{$key} ) {
            $mech_params{$key} = $value;
        }
        else {
            $parent_params{$key} = $value;
        }
    }

    my $self = $class->SUPER::new( %parent_params );
    bless $self, $class;

    # Use the mech params now that we have a mech object.
    for my $param ( keys %mech_params ) {
        $self->{$param} = $mech_params{$param};
    }
    $self->{page_stack} = [];
    $self->env_proxy() unless $mech_params{noproxy};

    # libwww-perl 5.800 (and before, I assume) has a problem where
    # $ua->{proxy} can be undef and clone() doesn't handle it.
    $self->{proxy} = {} unless defined $self->{proxy};
    push( @{$self->requests_redirectable}, 'POST' );

    $self->_reset_page();

    return $self;
}

# overriding LWP::UA's static method
sub _agent { "WWW-Mechanize/$VERSION" }


my %known_agents = (
    'Windows IE 6'      => 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)',
    'Windows Mozilla'   => 'Mozilla/5.0 (Windows; U; Windows NT 5.0; en-US; rv:1.4b) Gecko/20030516 Mozilla Firebird/0.6',
    'Mac Safari'        => 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-us) AppleWebKit/85 (KHTML, like Gecko) Safari/85',
    'Mac Mozilla'       => 'Mozilla/5.0 (Macintosh; U; PPC Mac OS X Mach-O; en-US; rv:1.4a) Gecko/20030401',
    'Linux Mozilla'     => 'Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.4) Gecko/20030624',
    'Linux Konqueror'   => 'Mozilla/5.0 (compatible; Konqueror/3; Linux)',
);

sub agent_alias {
    my $self = shift;
    my $alias = shift;

    if ( defined $known_agents{$alias} ) {
        return $self->agent( $known_agents{$alias} );
    }
    else {
        $self->warn( qq{Unknown agent alias "$alias"} );
        return $self->agent();
    }
}


sub known_agent_aliases {
    my @aliases = sort keys %known_agents;
    return @aliases;
}


sub get {
    my $self = shift;
    my $uri = shift;

    $uri = $self->_uri_with_base( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->SUPER::get( $uri->as_string, @_ );
}


sub post {
    my $self = shift;
    my $uri = shift;

    $uri = $self->_uri_with_base( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->SUPER::post( $uri->as_string, @_ );
}


sub put {
    my $self = shift;
    my $uri = shift;

    $uri = $self->_uri_with_base( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->_SUPER_put( $uri->as_string, @_ );
}


# Added until LWP::UserAgent has it.
sub _SUPER_put {
    require HTTP::Request::Common;
    my($self, @parameters) = @_;
    my @suff = $self->_process_colonic_headers(\@parameters,1);
    return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
}


sub head {
    my $self = shift;
    my $uri = shift;

    $uri = $self->_uri_with_base( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->SUPER::head( $uri->as_string, @_ );
}


sub delete {
    my $self = shift;
    my $uri = shift;

    $uri = $self->_uri_with_base( $uri );

    # It appears we are returning a super-class method,
    # but it in turn calls the request() method here in Mechanize
    return $self->SUPER::delete( $uri->as_string, @_ );
}

sub _uri_with_base {
    my $self = shift;
    my $uri = shift;

    $uri = $uri->url if ref($uri) eq 'WWW::Mechanize::Link';

    $uri = $self->base
            ? URI->new_abs( $uri, $self->base )
            : URI->new( $uri );

    return $uri;
}


sub reload {
    my $self = shift;

    return unless my $req = $self->{req};

    # LWP::UserAgent sets up a request_prepare handler that calls
    # $self->cookie_jar->add_cookie_header($req)
    #
    # HTTP::Cookies::add_cookie_header always preserves existing
    # cookies in a request object
    #
    # we pass an existing request to _make_request
    #
    # result: cookies will get repeated every time someone calls
    # ->reload, sooner or later leading to a "request too big" from
    # the server
    #
    # until https://rt.cpan.org/Public/Bug/Display.html?id=75897 is
    # fixed, let's clear the cookies from the existing request
    $req->remove_header('Cookie');

    return $self->_update_page( $req, $self->_make_request( $req, @_ ) );
}


sub back {
    my $self = shift;

    my $stack = $self->{page_stack};
    return unless $stack && @{$stack};

    my $popped = pop @{$self->{page_stack}};
    my $req    = $popped->{req};
    my $res    = $popped->{res};

    $self->_update_page( $req, $res );

    return 1;
}


sub clear_history {
    my $self = shift;

    delete $self->{page_stack};

    return 1;
}


sub history_count {
    my $self = shift;

    # If we don't have a "current" page, we certainly don't have any previous
    # ones.
    return 0 unless $self->{req} && $self->{res};

    my $stack = $self->{page_stack};

    return 1 unless $stack;

    return 1 + @$stack;
}


sub history {
    my $self = shift;
    my $n    = shift;

    return undef unless $self->{req} && $self->{res};

    if ($n == 0) {
      return { req => $self->{req}, res => $self->{res} };
    }

    my $stack = $self->{page_stack};
    return undef unless $stack && @$stack >= $n;

    return { req => $stack->[-$n]{req}, res => $stack->[-$n]{res} };
}


sub success {
    my $self = shift;

    return $self->res && $self->res->is_success;
}



sub uri {
    my $self = shift;
    return $self->response ? $self->response->request->uri : undef;
}

sub res {           my $self = shift; return $self->{res}; }
sub response {      my $self = shift; return $self->{res}; }
sub status {        my $self = shift; return $self->{status}; }
sub ct {            my $self = shift; return $self->{ct}; }
sub content_type {  my $self = shift; return $self->{ct}; }
sub base {          my $self = shift; return $self->{base}; }
sub is_html {
    my $self = shift;
    return defined $self->ct &&
        ($self->ct eq 'text/html' || $self->ct eq 'application/xhtml+xml');
}


sub title {
    my $self = shift;

    return unless $self->is_html;

    if ( not defined $self->{title} ) {
        require HTML::HeadParser;
        my $p = HTML::HeadParser->new;
        $p->parse($self->content);
        $self->{title} = $p->header('Title');
    }
    return $self->{title};
}


sub redirects {
    my $self = shift;

    return $self->response->redirects;
}


sub content {
    my $self = shift;
    my %params = @_;

    my $content = $self->{content};
    if (delete $params{raw}) {
        $content = $self->response()->content();
    }
    elsif (delete $params{decoded_by_headers}) {
        $content = $self->response()->decoded_content(charset => 'none');
    }
    elsif (my $charset = delete $params{charset}) {
        $content = $self->response()->decoded_content(charset => $charset);
    }
    elsif ( $self->is_html ) {
        if ( exists $params{base_href} ) {
            my $base_href = (delete $params{base_href}) || $self->base;
            $content=~s//\n/i;
        }

        if ( my $format = delete $params{format} ) {
            if ( $format eq 'text' ) {
                $content = $self->text;
            }
            else {
                $self->die( qq{Unknown "format" parameter "$format"} );
            }
        }

        $self->_check_unhandled_params( %params );
    }

    return $content;
}


sub text {
    my $self = shift;

    if ( not defined $self->{text} ) {
        unless ( exists $INC{'HTML::TreeBuilder'} ) {
            require HTML::TreeBuilder;
            HTML::TreeBuilder->VERSION(5);
            HTML::TreeBuilder->import('-weak');
        }
        my $tree = HTML::TreeBuilder->new();
        $tree->parse( $self->content );
        $tree->eof();
        $tree->elementify(); # just for safety
        $self->{text} = $tree->as_text();
    }

    return $self->{text};
}

sub _check_unhandled_params {
    my $self  = shift;
    my %params = @_;

    for my $cmd ( sort keys %params ) {
        $self->die( qq{Unknown named argument "$cmd"} );
    }
}


sub links {
    my $self = shift;

    $self->_extract_links() unless $self->{links};

    return @{$self->{links}} if wantarray;
    return $self->{links};
}


sub follow_link {
    my $self = shift;
    $self->die( qq{Needs to get key-value pairs of parameters.} ) if @_ % 2;
    my %params = ( n=>1, @_ );

    if ( $params{n} eq 'all' ) {
        delete $params{n};
        $self->warn( q{follow_link(n=>"all") is not valid} );
    }

    my $link = $self->find_link(%params);
    if ( $link ) {
        return $self->get( $link->url );
    }

    if ( $self->{autocheck} ) {
        $self->die( 'Link not found' );
    }

    return;
}


sub find_link {
    my $self = shift;
    my %params = ( n=>1, @_ );

    my $wantall = ( $params{n} eq 'all' );

    $self->_clean_keys( \%params, qr/^(n|(text|url|url_abs|name|tag|id|class|rel)(_regex)?)$/ );

    my @links = $self->links or return;

    my $nmatches = 0;
    my @matches;
    for my $link ( @links ) {
        if ( _match_any_link_params($link,\%params) ) {
            if ( $wantall ) {
                push( @matches, $link );
            }
            else {
                ++$nmatches;
                return $link if $nmatches >= $params{n};
            }
        }
    } # for @links

    if ( $wantall ) {
        return @matches if wantarray;
        return \@matches;
    }

    return;
} # find_link

# Used by find_links to check for matches
# The logic is such that ALL param criteria that are given must match
sub _match_any_link_params {
    my $link = shift;
    my $p = shift;

    # No conditions, anything matches
    return 1 unless keys %$p;

    return if defined $p->{url}           && !($link->url eq $p->{url} );
    return if defined $p->{url_regex}     && !($link->url =~ $p->{url_regex} );
    return if defined $p->{url_abs}       && !($link->url_abs eq $p->{url_abs} );
    return if defined $p->{url_abs_regex} && !($link->url_abs =~ $p->{url_abs_regex} );
    return if defined $p->{text}          && !(defined($link->text) && $link->text eq $p->{text} );
    return if defined $p->{text_regex}    && !(defined($link->text) && $link->text =~ $p->{text_regex} );
    return if defined $p->{name}          && !(defined($link->name) && $link->name eq $p->{name} );
    return if defined $p->{name_regex}    && !(defined($link->name) && $link->name =~ $p->{name_regex} );
    return if defined $p->{tag}           && !($link->tag && $link->tag eq $p->{tag} );
    return if defined $p->{tag_regex}     && !($link->tag && $link->tag =~ $p->{tag_regex} );

    return if defined $p->{id}            && !($link->attrs->{id} && $link->attrs->{id} eq $p->{id} );
    return if defined $p->{id_regex}      && !($link->attrs->{id} && $link->attrs->{id} =~ $p->{id_regex} );
    return if defined $p->{class}         && !($link->attrs->{class} && $link->attrs->{class} eq $p->{class} );
    return if defined $p->{class_regex}   && !($link->attrs->{class} && $link->attrs->{class} =~ $p->{class_regex} );

    return if defined $p->{rel}         && !($link->attrs->{rel} && $link->attrs->{rel} eq $p->{rel} );
    return if defined $p->{rel_regex}   && !($link->attrs->{rel} && $link->attrs->{rel} =~ $p->{rel_regex} );

    # Success: everything that was defined passed.
    return 1;

}

# Cleans the %params parameter for the find_link and find_image methods.
sub _clean_keys {
    my $self = shift;
    my $params = shift;
    my $rx_keyname = shift;

    for my $key ( keys %$params ) {
        my $val = $params->{$key};
        if ( $key !~ qr/$rx_keyname/ ) {
            $self->warn( qq{Unknown link-finding parameter "$key"} );
            delete $params->{$key};
            next;
        }

        my $key_regex = ( $key =~ /_regex$/ );
        my $val_regex = ( ref($val) eq 'Regexp' );

        if ( $key_regex ) {
            if ( !$val_regex ) {
                $self->warn( qq{$val passed as $key is not a regex} );
                delete $params->{$key};
                next;
            }
        }
        else {
            if ( $val_regex ) {
                $self->warn( qq{$val passed as '$key' is a regex} );
                delete $params->{$key};
                next;
            }
            if ( $val =~ /^\s|\s$/ ) {
                $self->warn( qq{'$val' is space-padded and cannot succeed} );
                delete $params->{$key};
                next;
            }
        }
    } # for keys %params

    return;
} # _clean_keys()



sub find_all_links {
    my $self = shift;
    return $self->find_link( @_, n=>'all' );
}


sub find_all_inputs {
    my $self = shift;
    my %criteria = @_;

    my $form = $self->current_form() or return;

    my @found;
    foreach my $input ( $form->inputs ) { # check every pattern for a match on the current hash
        my $matched = 1;
        foreach my $criterion ( sort keys %criteria ) { # Sort so we're deterministic
            my $field = $criterion;
            my $is_regex = ( $field =~ s/(?:_regex)$// );
            my $what = $input->{$field};
            $matched = defined($what) && (
                $is_regex
                    ? ( $what =~ $criteria{$criterion} )
                    : ( $what eq $criteria{$criterion} )
                );
            last if !$matched;
        }
        push @found, $input if $matched;
    }
    return @found;
}


sub find_all_submits {
    my $self = shift;

    return $self->find_all_inputs( @_, type_regex => qr/^(submit|image)$/ );
}



sub images {
    my $self = shift;

    $self->_extract_images() unless $self->{images};

    return @{$self->{images}} if wantarray;
    return $self->{images};
}


sub find_image {
    my $self = shift;
    my %params = ( n=>1, @_ );

    my $wantall = ( $params{n} eq 'all' );

    $self->_clean_keys( \%params, qr/^(?:n|(?:alt|url|url_abs|tag|id|class)(?:_regex)?)$/ );

    my @images = $self->images or return;

    my $nmatches = 0;
    my @matches;
    for my $image ( @images ) {
        if ( _match_any_image_params($image,\%params) ) {
            if ( $wantall ) {
                push( @matches, $image );
            }
            else {
                ++$nmatches;
                return $image if $nmatches >= $params{n};
            }
        }
    } # for @images

    if ( $wantall ) {
        return @matches if wantarray;
        return \@matches;
    }

    return;
}

# Used by find_images to check for matches
# The logic is such that ALL param criteria that are given must match
sub _match_any_image_params {
    my $image = shift;
    my $p = shift;

    # No conditions, anything matches
    return 1 unless keys %$p;

    return if defined $p->{url}           && !(defined($image->url) && $image->url eq $p->{url} );
    return if defined $p->{url_regex}     && !(defined($image->url) && $image->url =~ $p->{url_regex} );
    return if defined $p->{url_abs}       && !(defined($image->url_abs) && $image->url_abs eq $p->{url_abs} );
    return if defined $p->{url_abs_regex} && !(defined($image->url_abs) && $image->url_abs =~ $p->{url_abs_regex} );
    return if defined $p->{alt}           && !(defined($image->alt) && $image->alt eq $p->{alt} );
    return if defined $p->{alt_regex}     && !(defined($image->alt) && $image->alt =~ $p->{alt_regex} );
    return if defined $p->{tag}           && !($image->tag && $image->tag eq $p->{tag} );
    return if defined $p->{tag_regex}     && !($image->tag && $image->tag =~ $p->{tag_regex} );
    return if defined $p->{id}            && !($image->attrs && $image->attrs->{id} && $image->attrs->{id} eq $p->{id} );
    return if defined $p->{id_regex}      && !($image->attrs && $image->attrs->{id} && $image->attrs->{id} =~ $p->{id_regex} );
    return if defined $p->{class}         && !($image->attrs && $image->attrs->{class} && $image->attrs->{class} eq $p->{class} );
    return if defined $p->{class_regex}   && !($image->attrs && $image->attrs->{class} && $image->attrs->{class} =~ $p->{class_regex} );

    # Success: everything that was defined passed.
    return 1;
}



sub find_all_images {
    my $self = shift;
    return $self->find_image( @_, n=>'all' );
}


sub forms {
    my $self = shift;

    $self->_extract_forms() unless $self->{forms};

    return @{$self->{forms}} if wantarray;
    return $self->{forms};
}

sub current_form {
    my $self = shift;

    if ( !$self->{current_form} ) {
        $self->form_number(1);
    }

    return $self->{current_form};
}


sub form_number {
    my ($self, $form) = @_;
    # XXX Should we die if no $form is defined? Same question for form_name()

    my $forms = $self->forms;
    if ( $forms->[$form-1] ) {
        $self->{current_form} = $forms->[$form-1];
        return wantarray
          ? ($self->{current_form}, $form)
          : $self->{current_form};
    }

    return wantarray ? () : undef;
}


sub form_action {
    my ($self, $action) = @_;

    my $temp;
    my @matches = grep {defined($temp = $_->action) and ($temp =~ m/$action/msx) } $self->forms;

    my $nmatches = @matches;
    if ( $nmatches > 0 ) {
        if ( $nmatches > 1 ) {
            $self->warn( "There are $nmatches forms with action matching $action. The first one was used." )
        }
        return $self->{current_form} = $matches[0];
    }

    return;
}


sub form_name {
    my ( $self, $name, $args ) = @_;
    return $self->form_with( name => $name, $args || () );
}


sub form_id {
    my ( $self, $formid, $args ) = @_;
    defined( my $form = $self->form_with( id => $formid, $args || () ) )
      or $self->warn(qq{ There is no form with ID "$formid"});
    return $form;
}



sub all_forms_with_fields {
    my ($self, @fields) = @_;
    $self->die('no fields provided') unless scalar @fields;

    my @matches;
    FORMS: for my $form (@{ $self->forms }) {
        my @fields_in_form = $form->param();
        for my $field (@fields) {
            next FORMS unless grep { $_ eq $field } @fields_in_form;
        }
        push @matches, $form;
    }
    return @matches;
}



sub form_with_fields {
    my ($self, @fields) = @_;
    $self->die('no fields provided') unless scalar @fields;

    my $nth;
    if ( @fields > 1 && ref $fields[-1] eq 'HASH' ) {
        $nth = ( pop @fields )->{n};
    }

    my @matches = $self->all_forms_with_fields(@fields);
    if ( $nth ) {
        @matches = ( @matches >= $nth ) ? ( $matches[ $nth - 1 ] ) : ();
    }
    my $nmatches = @matches;
    if ( $nmatches > 0 ) {
        if ( $nmatches > 1 ) {
            $self->warn( "There are $nmatches forms with the named fields.  The first one was used." )
        }
        return $self->{current_form} = $matches[0];
    }
    else {
        $self->warn( $nth ? qq{There is no match \#$nth form with the requested fields}
                          : qq{There is no form with the requested fields} );
        return undef;
    }
}



sub all_forms_with {
    my ( $self, %spec ) = @_;

    my $action = delete $spec{action};
    my @forms = grep { !$action || $_->action eq $action } $self->forms;
    foreach my $attr ( keys %spec ) {
        @forms = grep _equal( $spec{$attr}, $_->attr($attr) ), @forms or return;
    }
    return @forms;
}


sub form_with {
    my ( $self, @args ) = @_;

    return if not $self->forms;

    # Determine if we should return the nth instance
    my $nth;
    if ( @args % 2 && ref $args[-1] eq 'HASH' ) {
        $nth = ( pop @args )->{n};
    }

    my %spec = @args;

    my @forms = $self->all_forms_with(%spec);
    if ( $nth ) {
        @forms = ( @forms >= $nth ) ? $forms[ $nth - 1 ] : ();
    }
    if ( @forms > 1 ) {    # Warn if several forms matched.
        # For ->form_with( method => 'POST', action => '', id => undef ) we get:
        # >>There are 2 forms with empty action and no id and method "POST".
        # The first one was used.<<

        $self->warn(
            'There are ' . @forms . ' forms ' . (
                keys %spec    # explain search criteria if there were any
                ? 'with ' . join(
                    ' and ',    # "with ... and ... and ..."
                    map {
                        unless ( defined $spec{$_} ) {    # case $attr => undef
                            qq{no $_};
                        }
                        elsif ( $spec{$_} eq q{} ) {       # case $attr=> ''
                            qq{empty $_};
                        }
                        else {                            # case $attr => $value
                            qq{$_ "$spec{$_}"};
                        }
                      }                # case $attr => undef
                      sort keys %spec  # sort keys to get deterministic messages
                  )
                : q{}
              )
              . '.  The first one was used.'
        );
    }

    return $self->{current_form} = $forms[0];
}

# NOT an object method!
# Expects two values and returns true only when either
# both are defined and eq(ual) or when both are not defined.
sub _equal {
    my ( $x, $y ) = @_;
    defined $x ? defined $y && $x eq $y : !defined $y;
}



sub field {
    my ($self, $name, $value, $number) = @_;
    $number ||= 1;

    my $form = $self->current_form();
    if ($number > 1) {
        $form->find_input($name, undef, $number)->value($value);
    }
    else {
        if ( ref($value) eq 'ARRAY' ) {
            my $input = $form->find_input($name);

            if ( $input->type eq 'file' ) {
                $input->file( shift @$value );
                $input->filename( shift @$value );
                $input->headers( @$value );
            }
            else {
                $form->param($name, $value);
            }
        }
        else {
            $form->value($name => $value);
        }
    }
}


sub select {
    my ($self, $name, $value) = @_;

    my $form = $self->current_form();

    my $input = $form->find_input($name);
    if (!$input) {
        $self->warn( qq{Input "$name" not found} );
        return;
    }

    if ($input->type ne 'option') {
        $self->warn( qq{Input "$name" is not type "select"} );
        return;
    }

    # For $mech->select($name, {n => 3}) or $mech->select($name, {n => [2,4]}),
    # transform the 'n' number(s) into value(s) and put it in $value.
    if (ref($value) eq 'HASH') {
        for (keys %$value) {
            $self->warn(qq{Unknown select value parameter "$_"})
              unless $_ eq 'n';
        }

        if (defined($value->{n})) {
            my @inputs = $form->find_input($name, 'option');
            my @values = ();
            # distinguish between multiple and non-multiple selects
            # (see INPUTS section of `perldoc HTML::Form`)
            if (@inputs == 1) {
                @values = $inputs[0]->possible_values();
            }
            else {
                foreach my $input (@inputs) {
                    my @possible = $input->possible_values();
                    push @values, pop @possible;
                }
            }

            my $n = $value->{n};
            if (ref($n) eq 'ARRAY') {
                $value = [];
                for (@$n) {
                    unless (/^\d+$/) {
                        $self->warn(qq{"n" value "$_" is not a positive integer});
                        return;
                    }
                    push @$value, $values[$_ - 1];  # might be undef
                }
            }
            elsif (!ref($n) && $n =~ /^\d+$/) {
                $value = $values[$n - 1];           # might be undef
            }
            else {
                $self->warn('"n" value is not a positive integer or an array ref');
                return;
            }
        }
        else {
            $self->warn('Hash value is invalid');
            return;
        }
    } # hashref

    if (ref($value) eq 'ARRAY') {
        $form->param($name, $value);
        return 1;
    }

    $form->value($name => $value);
    return 1;
}


sub set_fields {
    my $self = shift;
    my %fields = @_;

    my $form = $self->current_form or $self->die( 'No form defined' );

    FIELD:
    for my $field ( keys %fields ) {
        my $value = $fields{$field};
        my $number = 1;

        if ( ref $value eq 'ARRAY' ) {
            my $input = $form->find_input($field) or next FIELD;

            # Honor &submit_form's documentation, that says that a
            # "file" input's value can be in the form of
            # "[[$filepath, $filename], 1]".
            if (
                $input->type ne 'file'
                || ( $input->type eq 'file' && ref( $value->[0] ) eq 'ARRAY' )
            ) {
                ( $value, $number ) = ( $value->[0], $value->[1] );
            }
        }
        else {
            if ( ref $value eq 'SCALAR' ) {
                my $input = $form->find_input( $field );

                if ( not defined int $$value ) {
                    warn "Only references to integers are supported. Using 0.";
                    $$value = 0;
                }

                my @possible_values = $input->possible_values;
                if ($#possible_values < $$value) {
                    warn "Not enough options for $field to select index $$value";
                    next FIELD;
                }
                $value = $possible_values[ $$value ];
            }
        }
        $self->field($field, $value, $number);
    }
}


sub set_visible {
    my $self = shift;

    my $form = $self->current_form;
    my @inputs = $form->inputs;

    my $num_set = 0;
    for my $value ( @_ ) {
        # Handle type/value pairs an arrayref
        if ( ref $value eq 'ARRAY' ) {
            my ( $type, $value ) = @$value;
            while ( my $input = shift @inputs ) {
                next if $input->type eq 'hidden';
                if ( $input->type eq $type ) {
                    $input->value( $value );
                    $num_set++;
                    last;
                }
            } # while
        }
        # by default, it's a value
        else {
            while ( my $input = shift @inputs ) {
                next if $input->type eq 'hidden';
                $input->value( $value );
                $num_set++;
                last;
            } # while
        }
    } # for

    return $num_set;
} # set_visible()


sub tick {
    my $self = shift;
    my $name = shift;
    my $value = shift;
    my $set = @_ ? shift : 1;  # default to 1 if not passed

    # loop though all the inputs
    my $index = 1;
    while ( my $input = $self->current_form->find_input( $name, 'checkbox', $index ) ) {
        # Sometimes the HTML is malformed and there is no value for the check
        # box, so we just return if the value passed is an empty string
        # (and the form input is found)
        if ($value eq q{}) {
            $input->value($set ? $value : undef);
            return;
        }
        # Can't guarantee that the first element will be undef and the second
        # element will be the right name
        foreach my $val ($input->possible_values()) {
            next unless defined $val;
            if ($val eq $value) {
                $input->value($set ? $value : undef);
                return;
            }
        }

        # move onto the next input
        $index++;
    } # while

    # got this far?  Didn't find anything
    $self->die( qq{No checkbox "$name" for value "$value" in form} );
} # tick()


sub untick {
    shift->tick(shift,shift,undef);
}


sub value {
    my $self = shift;
    my $name = shift;
    my $number = shift || 1;

    my $form = $self->current_form;
    if ( $number > 1 ) {
        return $form->find_input( $name, undef, $number )->value();
    }
    else {
        return $form->value( $name );
    }
} # value


sub click {
    my ($self, $button, $x, $y) = @_;
    for ($x, $y) { $_ = 1 unless defined; }
    my $request = $self->current_form->click($button, $x, $y);
    return $self->request( $request );
}


sub click_button {
    my $self = shift;
    my %args = @_;

    for ( keys %args ) {
        if ( !/^(number|name|value|id|input|x|y)$/ ) {
            $self->warn( qq{Unknown click_button parameter "$_"} );
        }
    }

    my %exclusive_options = (
        id     => 1,
        input  => 1,
        name   => 1,
        number => 1,
        value  => 1,
    );

    my @present_exclusive_options = @exclusive_options{ keys %args };

    if ( scalar @present_exclusive_options > 1 ) {
        $self->die( 'click_button: More than one button selector has been used' );
    }

    for ($args{x}, $args{y}) {
        $_ = 1 unless defined;
    }

    my $form = $self->current_form or $self->die( 'click_button: No form has been selected' );

    my $request;
    if ( $args{name} ) {
        $request = $form->click( $args{name}, $args{x}, $args{y} );
    }
    # 0 is a valid id in HTML5
    elsif ( defined $args{id} ) {
        # HTML::Form expects ids to be prefixed with '#'
        my $input = $form->find_input('#' . $args{id});
        $request = $input->click( $form, $args{x}, $args{y} );
    }
    elsif ( $args{number} ) {
        # changing this 'submit' to qw/submit button image/ will probably break people's code
        my $input = $form->find_input( undef, 'submit', $args{number} );
        $request = $input->click( $form, $args{x}, $args{y} );
    }
    elsif ( $args{input} ) {
        $request = $args{input}->click( $form, $args{x}, $args{y} );
    }
    elsif ( $args{value} ) {
        my @inputs = map { $form->find_input(undef, $_) } qw/submit button image/;
        foreach  my $input ( @inputs ) {
            if ( $input->value && ($args{value} eq $input->value) ) {
                $request = $input->click( $form, $args{x}, $args{y} );
                last;
            }
        } # foreach
    } # $args{value}

    return $self->request( $request );
}


sub submit {
    my $self = shift;

    my $request = $self->current_form->make_request;
    return $self->request( $request );
}


sub submit_form {
    my( $self, %args ) = @_;

    for ( keys %args ) {
        if ( !/^(form_(number|name|fields|id)|(with_)?fields|button|x|y|strict_forms)$/ ) {
            $self->die( qq{Unknown submit_form parameter "$_"} );
        }
    }

    my $fields;
    for (qw/with_fields fields/) {
        if ($args{$_}) {
            if ( ref $args{$_} eq 'HASH' ) {
                $fields = $args{$_};
            }
            else {
                $self->die("$_ arg to submit_form must be a hashref");
            }
            last;
        }
    }

    my @filtered_sets;
    if ( $args{with_fields} ) {
        my @got = $self->all_forms_with_fields(keys %{$fields});
        $self->die("There is no form with the requested fields") if not @got;
        push @filtered_sets, \@got;
    }
    if ( my $form_number = $args{form_number} ) {
        my $got = $self->form_number( $form_number );
        $self->die("There is no form numbered $form_number") if not $got;
        push @filtered_sets, [ $got ];
    }
    if ( my $form_name = $args{form_name} ) {
        my @got = $self->all_forms_with( name => $form_name );
        $self->die(qq{There is no form named "$form_name"}) if not @got;
        push @filtered_sets, \@got;
    }
    if ( my $form_id = $args{form_id} ) {
        my @got = $self->all_forms_with( id => $form_id );
        $self->die(qq{There is no form with ID "$form_id"}) if not @got;
        push @filtered_sets, \@got;
    }

    if (not @filtered_sets) {
        # No form selector was used.
        # Maybe a form was set separately, or we'll default to the first form.
    }
    else {
        # Need to intersect to apply all the various filters.
        # Assume that each filtered set only has a given form object once.
        # So we can count occurrences.
        #
        tie my %c, Tie::RefHash:: or $self->die('Cannot determine a form to use');
        foreach (@filtered_sets) {
            foreach (@$_) {
                ++$c{$_};
            }
        }
        my $expected_count = scalar @filtered_sets;
        my @matched = grep { $c{$_} == $expected_count } keys %c;
        if (not @matched) {
            $self->die('There is no form that satisfies all the criteria');
        }
        if (@matched > 1) {
            $self->die('More than one form satisfies all the criteria');
        }
        $self->{current_form} = $matched[0];
    }

    if (defined($args{strict_forms})) {
        # Strict argument has been passed, set the flag as appropriate
        # this must be done prior to attempting to set the fields
        $self->current_form->strict($args{strict_forms});
    }

    $self->set_fields( %{$fields} ) if $fields;

    my $response;
    if ( $args{button} ) {
        $response = $self->click( $args{button}, $args{x} || 0, $args{y} || 0 );
    }
    else {
        $response = $self->submit();
    }

    return $response;
}


sub add_header {
    my $self = shift;
    my $npairs = 0;

    while ( @_ ) {
        my $key = shift;
        my $value = shift;
        ++$npairs;

        $self->{headers}{$key} = $value;
    }

    return $npairs;
}


sub delete_header {
    my $self = shift;

    while ( @_ ) {
        my $key = shift;

        delete $self->{headers}{$key};
    }

    return;
}



sub quiet {
    my $self = shift;

    $self->{quiet} = $_[0] if @_;

    return $self->{quiet};
}


sub autocheck {
    my $self = shift;

    $self->{autocheck} = $_[0] if @_;

    return $self->{autocheck};
}


sub stack_depth {
    my $self = shift;
    $self->{stack_depth} = shift if @_;
    return $self->{stack_depth};
}


sub save_content {
    my $self = shift;
    my $filename = shift;
    my %opts = @_;
    if (delete $opts{binary}) {
        $opts{binmode} = ':raw';
        $opts{decoded_by_headers} = 1;
    }

    open( my $fh, '>', $filename ) or $self->die( "Unable to create $filename: $!" );
    if ((my $binmode = delete($opts{binmode}) || q{}) || ($self->content_type() !~ m{^text/})) {
        if (length($binmode) && (substr($binmode, 0, 1) eq ':')) {
            binmode $fh, $binmode;
        }
        else {
            binmode $fh;
        }
    }
    print {$fh} $self->content(%opts) or $self->die( "Unable to write to $filename: $!" );
    close $fh or $self->die( "Unable to close $filename: $!" );

    return;
}



sub _get_fh_default_stdout {
    my $self = shift;
    my $p = shift || q{};
    if ( !$p ) {
        return \*STDOUT;
    } elsif ( !ref($p) ) {
        open my $fh, '>', $p or $self->die( "Unable to write to $p: $!" );;
        return $fh;
    } else {
        return $p;
    }
}

sub dump_headers {
    my $self = shift;
    my $fh   = $self->_get_fh_default_stdout(shift);

    print {$fh} $self->response->headers_as_string;

    return;
}



sub dump_links {
    my $self = shift;
    my $fh = shift || \*STDOUT;
    my $absolute = shift;

    for my $link ( $self->links ) {
        my $url = $absolute ? $link->url_abs : $link->url;
        $url = q{} if not defined $url;
        print {$fh} $url, "\n";
    }
    return;
}


sub dump_images {
    my $self = shift;
    my $fh = shift || \*STDOUT;
    my $absolute = shift;

    for my $image ( $self->images ) {
        my $url = $absolute ? $image->url_abs : $image->url;
        $url = q{} if not defined $url;
        print {$fh} $url, "\n";
    }
    return;
}


sub dump_forms {
    my $self = shift;
    my $fh = shift || \*STDOUT;

    for my $form ( $self->forms ) {
        print {$fh} $form->dump, "\n";
    }
    return;
}


sub dump_text {
    my $self = shift;
    my $fh = shift || \*STDOUT;
    my $absolute = shift;

    print {$fh} $self->text, "\n";

    return;
}



sub clone {
    my $self  = shift;
    my $clone = $self->SUPER::clone();

    $clone->cookie_jar( $self->cookie_jar );
    $clone->{headers} = { %{$self->{headers}} };

    return $clone;
}



sub redirect_ok {
    my $self = shift;
    my $prospective_request = shift;
    my $response = shift;

    my $ok = $self->SUPER::redirect_ok( $prospective_request, $response );
    if ( $ok ) {
        $self->{redirected_uri} = $prospective_request->uri;
    }

    return $ok;
}



sub request {
    my $self = shift;
    my $request = shift;

    $self->die( '->request was called without a request parameter' )
        unless $request;

    $request = $self->_modify_request( $request );

    if ( $request->method eq 'GET' || $request->method eq 'POST' ) {
        $self->_push_page_stack();
    }

    return $self->_update_page($request, $self->_make_request( $request, @_ ));
}


sub update_html {
    my $self = shift;
    my $html = shift;

    $self->_reset_page;
    $self->{ct} = 'text/html';
    $self->{content} = $html;

    return;
}


sub credentials {
    my $self = shift;

    # The latest LWP::UserAgent also supports 2 arguments,
    # in which case the first is host:port
    if (@_ == 4 || (@_ == 2 && $_[0] =~ /:\d+$/)) {
        return $self->SUPER::credentials(@_);
    }

    @_ == 2
        or $self->die( 'Invalid # of args for overridden credentials()' );

    return @$self{qw( __username __password )} = @_;
}


sub get_basic_credentials {
    my $self = shift;
    my @cred = grep { defined } @$self{qw( __username __password )};
    return @cred if @cred == 2;
    return $self->SUPER::get_basic_credentials(@_);
}


sub clear_credentials {
    my $self = shift;
    delete @$self{qw( __username __password )};
}


sub _update_page {
    my ($self, $request, $res) = @_;

    $self->{req} = $request;
    $self->{redirected_uri} = $request->uri->as_string;

    $self->{res} = $res;

    $self->{status}  = $res->code;
    $self->{base}    = $res->base;
    $self->{ct}      = $res->content_type || q{};

    if ( $res->is_success ) {
        $self->{uri} = $self->{redirected_uri};
        $self->{last_uri} = $self->{uri};
    }

    if ( $res->is_error ) {
        if ( $self->{autocheck} ) {
            $self->die( 'Error ', $request->method, 'ing ', $request->uri, ': ', $res->message );
        }
    }

    $self->_reset_page;

    # Try to decode the content. Undef will be returned if there's nothing to decompress.
    # See docs in HTTP::Message for details. Do we need to expose the options there?
    my $content = $res->decoded_content();
    $content = $res->content if (not defined $content);

    $content .= _taintedness();

    if ($self->is_html) {
        $self->update_html($content);
    }
    else {
        $self->{content} = $content;
    }

    return $res;
} # _update_page

our $_taintbrush;

# This is lifted wholesale from Test::Taint
sub _taintedness {
    return $_taintbrush if defined $_taintbrush;

    # Somehow we need to get some taintedness into our $_taintbrush.
    # Let's try the easy way first. Either of these should be
    # tainted, unless somebody has untainted them, so this
    # will almost always work on the first try.
    # (Unless, of course, taint checking has been turned off!)
    $_taintbrush = substr("$0$^X", 0, 0);
    return $_taintbrush if tainted( $_taintbrush );

    # Let's try again. Maybe somebody cleaned those.
    $_taintbrush = substr(join(q{}, grep { defined } @ARGV, %ENV), 0, 0);
    return $_taintbrush if tainted( $_taintbrush );

    # If those don't work, go try to open some file from some unsafe
    # source and get data from them.  That data is tainted.
    # (Yes, even reading from /dev/null works!)
    for my $filename ( qw(/dev/null / . ..), values %INC, $0, $^X ) {
        if ( open my $fh, '<', $filename ) {
            my $data;
            if ( defined sysread $fh, $data, 1 ) {
                $_taintbrush = substr( $data, 0, 0 );
                last if tainted( $_taintbrush );
            }
        }
    }

    # Sanity check
    die("Our taintbrush should have zero length!") if length $_taintbrush;

    return $_taintbrush;
}



sub _modify_request {
    my $self = shift;
    my $req = shift;

    # add correct Accept-Encoding header to restore compliance with
    # http://www.freesoft.org/CIE/RFC/2068/158.htm
    # http://use.perl.org/~rhesa/journal/25952
    if (not $req->header( 'Accept-Encoding' ) ) {
        # "identity" means "please! unencoded content only!"
        $req->header( 'Accept-Encoding', $HAS_ZLIB ? 'gzip' : 'identity' );
    }

    my $last = $self->{last_uri};
    if ( $last ) {
        $last = $last->as_string if ref($last);
        $req->header( Referer => $last );
    }
    while ( my($key,$value) = each %{$self->{headers}} ) {
        if ( defined $value ) {
            $req->header( $key => $value );
        }
        else {
            $req->remove_header( $key );
        }
    }

    return $req;
}



sub _make_request {
    my $self = shift;
    return $self->SUPER::request(@_);
}


sub _reset_page {
    my $self = shift;

    $self->{links}        = undef;
    $self->{images}       = undef;
    $self->{forms}        = undef;
    $self->{current_form} = undef;
    $self->{title}        = undef;
    $self->{text}         = undef;

    return;
}


my %link_tags = (
    a      => 'href',
    area   => 'href',
    frame  => 'src',
    iframe => 'src',
    link   => 'href',
    meta   => 'content',
);

sub _new_parser {
    my $self = shift;
    my $content_ref = shift;

    my $parser = HTML::TokeParser->new($content_ref);
    $parser->marked_sections( $self->{marked_sections});
    $parser->xml_mode( $$content_ref=~/^\s*<\?xml/ ); # NOT GENERALLY RELIABLE

    return $parser;
}

sub _extract_links {
    my $self = shift;


    $self->{links} = [];
    if ( defined $self->{content} ) {
        my $parser = $self->_new_parser(\$self->{content});
        while ( my $token = $parser->get_tag( keys %link_tags ) ) {
            my $link = $self->_link_from_token( $token, $parser );
            push( @{$self->{links}}, $link ) if $link;
        } # while
    }

    return;
}


my %image_tags = (
    img   => 'src',
    input => 'src',
);

sub _extract_images {
    my $self = shift;

    $self->{images} = [];

    if ( defined $self->{content} ) {
        if ($self->content_type eq 'text/css') {
            push( @{$self->{images}}, $self->_images_from_css($self->{content}) );
        }
        else {
            my $parser = $self->_new_parser(\$self->{content});
            while ( my $token = $parser->get_tag() ) {
                my ($tag_name, $attrs) = @{$token};
                next if $tag_name =~ m{^/};

                if ($image_tags{$tag_name}) {
                    my $image = $self->_image_from_token( $token, $parser );
                    push( @{$self->{images}}, $image ) if $image;
                }
                elsif ($tag_name eq 'style') {
                    push( @{$self->{images}}, $self->_images_from_css($parser->get_text) );
                }

                if ($attrs->{style}) {
                    push( @{$self->{images}}, $self->_images_from_css($attrs->{style}) );
                }
            } # while
        }
    }

    return;
}

sub _image_from_token {
    my $self = shift;
    my $token = shift;
    my $parser = shift;

    my $tag = $token->[0];
    my $attrs = $token->[1];

    if ( $tag eq 'input' ) {
        my $type = $attrs->{type} or return;
        return unless $type eq 'image';
    }

    require WWW::Mechanize::Image;
    return
        WWW::Mechanize::Image->new({
            tag     => $tag,
            base    => $self->base,
            url     => $attrs->{src},
            name    => $attrs->{name},
            height  => $attrs->{height},
            width   => $attrs->{width},
            alt     => $attrs->{alt},
            attrs   => $attrs,
        });
}

my $STYLE_URL_REGEXP = qr{
    # ex. "url('/site.css')"
    (             # capture non url path of the string
        url       # url
        \s*       #
        \(        # (
        \s*       #
        (['"]?)   # opening ' or "
    )
    (             # the rest is url
        .+?       # non greedy "everything"
    )
    (
        \2        # closing ' or "
        \s*       #
        \)        # )
    )
}xmsi;

sub _images_from_css {
    my $self = shift;
    my $css  = shift;

    my @images;
    while ($css =~ m/$STYLE_URL_REGEXP/g) {
        my $url = $3;
        require WWW::Mechanize::Image;
        push(
            @images,
            WWW::Mechanize::Image->new({
                tag     => 'css',
                base    => $self->base,
                url     => $url,
                name    => undef,
                height  => undef,
                width   => undef,
                alt     => undef,
            })
        );
    }

    return @images;
}

sub _link_from_token {
    my $self = shift;
    my $token = shift;
    my $parser = shift;

    my $tag = $token->[0];
    my $attrs = $token->[1];
    my $url = $attrs->{$link_tags{$tag}};

    my $text;
    my $name;
    if ( $tag eq 'a' ) {
        $text = $parser->get_trimmed_text("/$tag");
        $text = q{} unless defined $text;

        my $onClick = $attrs->{onclick};
        if ( $onClick && ($onClick =~ /^window\.open\(\s*'([^']+)'/) ) {
            $url = $1;
        }
        elsif( $url && $url =~ /^javascript\:\s*(?:void\(\s*)?window\.open\(\s*'([^']+)'/s ){
            $url = $1;
        }
    } # a

    # Of the tags we extract from, only 'AREA' has an alt tag
    # The rest should have a 'name' attribute.
    # ... but we don't do anything with that bit of wisdom now.

    $name = $attrs->{name};

    if ( $tag eq 'meta' ) {
        my $equiv = $attrs->{'http-equiv'};
        my $content = $attrs->{'content'};
        return unless $equiv && (lc $equiv eq 'refresh') && defined $content;

        if ( $content =~ /^\d+\s*;\s*url\s*=\s*(\S+)/i ) {
            $url = $1;
            $url =~ s/^"(.+)"$/$1/ or $url =~ s/^'(.+)'$/$1/;
        }
        else {
            undef $url;
        }
    } # meta

    return unless defined $url;   # probably just a name link or

    require WWW::Mechanize::Link;
    return
        WWW::Mechanize::Link->new({
            url  => $url,
            text => $text,
            name => $name,
            tag  => $tag,
            base => $self->base,
            attrs => $attrs,
        });
} # _link_from_token


sub _extract_forms {
    my $self = shift;

    my @forms = HTML::Form->parse(
        $self->content,
        base    => $self->base,
        strict  => $self->{strict_forms},
        verbose => $self->{verbose_forms},
    );
    $self->{forms} = \@forms;
    for my $form ( @forms ) {
        for my $input ($form->inputs) {
             if ($input->type eq 'file') {
                 $input->value( undef );
             }
        }
    }

    return;
}


sub _push_page_stack {
    my $self = shift;

    my $req = $self->{req};
    my $res = $self->{res};

    return unless $req && $res && $self->stack_depth;

    # Don't push anything if it's a virgin object
    my $stack = $self->{page_stack} ||= [];
    if ( @{$stack} >= $self->stack_depth ) {
        shift @{$stack};
    }
    push( @{$stack}, { req => $req, res => $res } );

    return 1;
}


sub warn {
    my $self = shift;

    return unless my $handler = $self->{onwarn};

    return if $self->quiet;

    return $handler->(@_);
}


sub die {
    my $self = shift;

    return unless my $handler = $self->{onerror};

    return $handler->(@_);
}


# NOT an object method!
sub _warn {
    require Carp;
    return &Carp::carp; ## no critic
}

# NOT an object method!
sub _die {
    require Carp;
    return &Carp::croak; ## no critic
}

1; # End of module

__END__