File Coverage

script/mech-dump

Criterion	Covered	Total	%
statement	65	101	64.3
branch	19	40	47.5
condition	0	3	0.0
subroutine	12	21	57.1
pod			n/a
total	96	165	58.1

#!/usr/bin/perl

# PODNAME: mech-dump
# ABSTRACT: Dumps information about a web page

use warnings;
use strict;
use WWW::Mechanize ();
use Getopt::Long;
use Pod::Usage;

use HTTP::Cookies;
my @actions;
my $absolute;
my $all;

my $user;
my $pass;
my $agent;
my $agent_alias;
my $cookie_filename;

my %command_line_options = (
    'user=s'     => \$user,
    'password=s' => \$pass,
    headers      => sub { push( @actions, \&dump_headers ) },
    forms        => sub { push( @actions, \&dump_forms ) },
    links        => sub { push( @actions, \&dump_links ) },
    images       => sub { push( @actions, \&dump_images ) },
    all          => sub {
        $all++;
        push(
            @actions,
            \&dump_headers, \&dump_forms, \&dump_links, \&dump_images
        );
    },
    text            => sub { push( @actions, \&dump_text ) },
    'absolute!'     => \$absolute,
    'agent=s'       => \$agent,
    'agent-alias=s' => \$agent_alias,
    'cookie-file=s' => \$cookie_filename,
    help            => sub { pod2usage(1); },
    version => sub { print STDERR $WWW::Mechanize::VERSION, "\n"; exit 0; },
    'completions' => sub { completions(@ARGV); },
);
GetOptions(%command_line_options) or pod2usage(2);

sub completions {
    my (@words) = @_;
    my @opts;
    foreach ( sort keys %command_line_options ) {
        if (m/^ (? [^!]+) ! $/msx) {
            push @opts, $+{opt}, 'no-' . $+{opt};
        }
        elsif (m/^ (? [^=]+) = [siof]{1} $/msx) {
            push @opts, ( split qr{\|}, $+{opt} );
        }
        else {
            push @opts, $_;
        }
    }
    print join "\n", ( map { q{--} . $_ } @opts );
    print "\n";
    exit 0;
}


my @uris = @ARGV
    or die "Must specify a URL or file to check.  See --help for details.\n";

@actions = ( \&dump_forms ) unless @actions;

binmode( STDOUT, ':utf8' );

my $mech = WWW::Mechanize->new( autocheck => 0 );
if ( defined $agent ) {
    $mech->agent($agent);
}
elsif ( defined $agent_alias ) {
    $mech->agent_alias($agent_alias);
}
if ( defined $cookie_filename ) {
    my $cookies = HTTP::Cookies->new(
        file           => $cookie_filename,
        autosave       => 1,
        ignore_discard => 1
    );
    $cookies->load();
    $mech->cookie_jar($cookies);
}
else {
    $mech->cookie_jar(undef);
}

$mech->env_proxy();
foreach my $uri (@uris) {
    my $no_ct_check;
    if ( -e $uri ) {
        require URI::file;
        $uri         = URI::file->new_abs($uri)->as_string;
        $no_ct_check = 1;    # we don't have to check the content type
    }

    my $response = $mech->get($uri);
    if ( !$response->is_success ) {
        if ( defined( $response->www_authenticate ) ) {
            if ( !defined $user or !defined $pass ) {
                die(
                    "Page requires username and password, but none specified.\n"
                );
            }
            $mech->credentials( $user, $pass );
            $response = $mech->get($uri);
            $response->is_success
                or die "Can't fetch $uri with username and password\n",
                $response->status_line, "\n";
        }
        else {
            die "$uri returns status ", $response->code, "\n";
        }
    }

    unless ($no_ct_check) {
        $mech->is_html
            or die qq{$uri returns type "}, $mech->ct,
            qq{", not "text/html"\n};
    }

    foreach my $action (@actions) {
        $action->($mech);
        print "\n" if @actions;
    }
}

sub dump_headers {
    my $mech = shift;
    print "--> Headers:\n" if $all;
    $mech->dump_headers(undef);
    return;
}

sub dump_forms {
    my $mech = shift;
    print "--> Forms:\n" if $all;
    $mech->dump_forms(undef);
    return;
}

sub dump_links {
    my $mech = shift;
    print "--> Links:\n" if $all;
    $mech->dump_links( undef, $absolute );
    return;
}

sub dump_images {
    my $mech = shift;
    print "--> Images:\n" if $all;
    $mech->dump_images( undef, $absolute );
    return;
}

sub dump_text {
    my $mech = shift;
    $mech->dump_text();
    return;
}

__END__