File Coverage

blib/lib/WWW/Mechanize.pm

Criterion	Covered	Total	%
statement	826	863	95.7
branch	416	468	88.8
condition	229	266	86.0
subroutine	103	107	96.2
pod	76	76	100.0
total	1650	1780	92.7

package WWW::Mechanize;

#ABSTRACT: Handy web browsing in a Perl object


use strict;
use warnings;

our $VERSION = '2.20';

use Tie::RefHash       ();
use HTTP::Request 1.30 ();
use HTML::Form 1.00    ();
use HTML::TokeParser   ();

use parent '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, $number ) = @_;
    $number ||= 1;

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

    my $input = $form->find_input( $name, undef, $number );
    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->find_input( $name, undef, $number )->value($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
        = map { $_ || () } @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;

    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 );

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

    return $res;
}    # _update_page


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);
                    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 $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;    ## no perlimports
        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;           ## no perlimports
    return &Carp::croak;    ## no critic
}

1;                          # End of module

__END__