git.maemo.org Git - pkg-perl/blob - deb-src/libwww-mechanize-perl/libwww-mechanize-perl-1.34/bin/mech-dump

   1 #!/usr/bin/perl -w
   2
   3 =head1 NAME
   4
   5 mech-dump - Dumps information about a web page
   6
   7 =cut
   8
   9 use warnings;
  10 use strict;
  11 use WWW::Mechanize;
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 my @actions;
  16 my $absolute;
  17
  18 my $user;
  19 my $pass;
  20 my $agent;
  21 my $agent_alias;
  22
  23 GetOptions(
  24     'user=s'        => \$user,
  25     'password=s'    => \$pass,
  26     forms           => sub { push( @actions, \&dump_forms ); },
  27     links           => sub { push( @actions, \&dump_links ); },
  28     images          => sub { push( @actions, \&dump_images ); },
  29     all             => sub { push( @actions, \&dump_forms, \&dump_links, \&dump_images ); },
  30     absolute        => \$absolute,
  31     'agent=s'       => \$agent,
  32     'agent-alias=s' => \$agent_alias,
  33     help            => sub { pod2usage(1); },
  34 ) or pod2usage(2);
  35
  36 =head1 SYNOPSIS
  37
  38 mech-dump [options] [file|url]
  39
  40 Options:
  41
  42     --forms         Dump table of forms (default action)
  43     --links         Dump table of links
  44     --images        Dump table of images
  45     --all           Dump all three of the above, in that order
  46
  47     --user=user     Set the username
  48     --password=pass Set the password
  49
  50     --agent=agent   Specify the UserAgent to pass
  51     --agent-alias=alias
  52                     Specify the alias for the UserAgent to pass.
  53                     Pick one of:
  54                         * Windows IE 6
  55                         * Windows Mozilla
  56                         * Mac Safari
  57                         * Mac Mozilla
  58                         * Linux Mozilla
  59                         * Linux Konqueror
  60
  61     --absolute      Show URLs as absolute, even if relative in the page
  62     --help          Show this message
  63
  64 The order of the options specified is relevant.  Repeated options
  65 get repeated dumps.
  66
  67 =cut
  68
  69 my $uri = shift or die "Must specify a URL or file to check.  See --help for details.\n";
  70 if ( -e $uri ) {
  71     require URI::file;
  72     $uri = URI::file->new_abs( $uri )->as_string;
  73 }
  74
  75 @actions = (\&dump_forms) unless @actions;
  76
  77 my $mech = WWW::Mechanize->new( cookie_jar => undef );
  78 if ( defined $agent ) {
  79     $mech->agent( $agent );
  80 }
  81 elsif ( defined $agent_alias ) {
  82     $mech->agent_alias( $agent_alias );
  83 }
  84 $mech->env_proxy();
  85 my $response = $mech->get( $uri );
  86 if (!$response->is_success and defined ($response->www_authenticate)) {
  87     if (!defined $user or !defined $pass) {
  88         die("Page requires username and password, but none specified.\n");
  89     }
  90     $mech->credentials($user,$pass);
  91     $response = $mech->get( $uri );
  92     $response->is_success or die "Can't fetch $uri with username and password\n", $response->status_line, "\n";
  93 }
  94 $mech->is_html or die qq{$uri returns type "}, $mech->ct, qq{", not "text/html"\n};
  95
  96 for my $action ( @actions ) {
  97     $action->( $mech );
  98 }
  99
 100 sub dump_links {
 101     my $mech = shift;
 102     $mech->dump_links( undef, $absolute );
 103     return;
 104 }
 105
 106 sub dump_images {
 107     my $mech = shift;
 108     $mech->dump_images( undef, $absolute );
 109     return;
 110 }
 111
 112 sub dump_forms {
 113     my $mech = shift;
 114     $mech->dump_forms( undef, $absolute );
 115     return;
 116 }