File Coverage

blib/lib/HTTP/GetImages.pm

Criterion	Covered	Total	%
statement	24	243	9.8
branch	0	154	0.0
condition	0	104	0.0
subroutine	8	17	47.0
pod	6	8	75.0
total	38	526	7.2

package HTTP::GetImages;

use vars qw /$EXTENSIONS_RE $EXTENSIONS_BAD $VERSION/;

$VERSION=0.343;

=head1 NAME

HTTP::GetImages - Spider to recover and store images from web pages.

=head1 SYNOPSIS

	use HTTP::GetImages;

	$_ = new HTTP::GetImages (
		dir  => '.',
		todo => ['http://www.google.com/',],
		dont => ['http://www.somewhere/ignorethis.html','http://and.this.html'],
		chat => 1,
	);

	$_->print_imgs;
	$_->print_done;
	$_->print_failed;
	$_->print_ignored;

	my $hash = $_->imgs_as_hash;
	foreach (keys %{$hash}){
		warn "$_ = ",$hash->{$_},"\n";
	}

	exit;

=head1 DESCRIPTION

This module allow syou to automate the searching, recovery and local storage
of images from the web, including those linked by anchor (C), mage (C)
and image map (C) elements.

Supply a URI or list of URIs to process, and C will recurse
over every link it finds, searching for images.

By supplying a list of URIs, you can restrict the search to certain webservers
and directories, or exclude it from certain webservers and directories.

You can also decide to reject images that are too small or too large.

=head1 DEPENDENCIES

	LWP::UserAgent;
	HTTP::Request;
	HTML::TokeParser;

=cut

use LWP::UserAgent;
use HTTP::Request;
use HTML::TokeParser;
use Carp;
use strict;
use warnings;
no strict 'refs';

=head1 PACKAGE GLOBAL VARIABLE

=head2 $CHAT

Set to above zero if you'd like a real-time report to C.
Defaults to off.

=cut

my $CHAT;

# Default values to apply to $self->{ext_ok}
$EXTENSIONS_RE = '(jpg|jpeg|bmp|gif|png|xbm|xmp)';

# Default values for $self->{ext_bad}
$EXTENSIONS_BAD = '(wmv|avi|rm|mpg|asf|ram|asx|mpeg|mp3)';


=head1 CONSTRUCTOR METHOD new

Besides the class reference, accepts name=>value pairs:

=over 4

=item max_attempts

The maximum attempts the agent should make to access the site. Default is three.

=item dir

the path to the directory in which to store images (no trailing oblique necessary);

=item rename

Default value is 0, which allows images to be saved with their original names.
If set with a value of 1, images will be given new names based on the time
they were saved at. If set to 2, images will be given filenames according to their
source location.

=item todo

one or more URL to process: can be an anonymous array, array reference, or scalar.

=item dont

As C, above, but URLs should be ignored.

If one of these is C, then will ignore all B documents
that do not match exactly those in the C array of URLs to process.
If one of these is C, will ignore no documents.

=item ext_ok

A regular expression 'or' list of image extensions to match.

Will be applied at the end of a filename, after a point, and is insensitive to case.

Defaults to C<(jpg|jpeg|bmp|gif|png|xbm|xmp)>.

=item ext_bad

As C (above), but default value is:C<(wmv|avi|rm|mpg|asf|ram|asx|mpeg|mp3)>

=item match_url

The minimum path a URL must contain. This can be a scalar or an array reference.

=item min_size.

The minimum size an image can be if it is to be saved.

=item max_size

The maximum size an image can be if it is to be saved.

=back

The object has several private variables, which
you can access for the results when the job is done.
However, do check out the public methods for accessing
these.

=over 4

=item DONE

a hash keys of which are the original URLs of the images, value being are the local filenames.

=item FAILED

a hash, keys of which are the failed URLs, values being short reasons.

=cut

sub new { my ($class) = (shift);
	warn "Making new ",__PACKAGE__ if $CHAT;
    unless (defined $class) {
    	carp "Usage: ".__PACKAGE__."->new( {key=>value} )\n";
    	return undef;
	}
	my %args;

	# Take parameters and place in object slots/set as instance variables
	if (ref $_[0] eq 'HASH'){	%args = %{$_[0]} }
	elsif (not ref $_[0]){		%args = @_ }
	else {
		carp "Usage: $class->new( { key=>values, } )";
		return undef;
	}
	my $self = bless {}, $class;

	# Slots that have default values:
	# $self->{min_size};
	# $self->{match_url}
	# $self->{dir},
	# $todo,= []
	$self->{dont} = [];
	# $MINIMGSIZE
	$self->{ext_ok} = $EXTENSIONS_RE;	# Defualt extensions to use
	$self->{ext_bad} = $EXTENSIONS_BAD; # Ditto for ignore.
	$self->{rename} = 0;
	$self->{max_attempts} = 3;

	# Set/overwrite public slots with user's values
	foreach (keys %args) {
		$self->{lc $_} = $args{$_};
		warn "$_ -> $self->{$_}\n" if $CHAT;
	}

	# Catch parameter errors
	if (not exists $self->{dir} or not defined $self->{dir}){
		croak "No 'dir' slot defined";
	}
	if (!-d $self->{dir}){
		croak "The dir to save to <$self->{dir}> could not be found or is not a directory";
	}
	if (not exists $self->{todo}){
		croak "The 'todo' slot is not defined";
	}

	# React to user slots
	if (exists $self->{chat} and defined $self->{chat}){
		$CHAT = 1;
		warn "Chat mode on";
	} else { undef $CHAT	}

	# Turn scalars into arrays for later use
	if (exists $self->{match_url} and not ref $self->{match_url}){
		$self->{match_url} = [$self->{match_url}];
	}
	if (exists $self->{todo} and not ref $self->{todo}){
		$self->{todo} = [$self->{todo}];
	}
	if (exists $self->{dont} and not ref $self->{dont}){
		$self->{dont} = [$self->{dont}];
	}
	@_ = @{$self->{todo}};
	$self->{todo} = {};
	foreach (@_){ $self->{todo}->{$_} = 1 }
	if ($self->{dont}){
		@_ = @{$self->{dont}};
		$self->{dont} = {};
		foreach (@_){ $self->{dont}->{$_} = 1 }
	}

	# Slots that are not adjustable by user:
	$self->{DONE}	= {};
	$self->{FAILED} = {};

	DOC:
	while (keys %{$self->{todo}} ){
		@_ = keys %{$self->{todo}};
		my $doc_url = shift @_;
		warn "-"x60,"\n" if $CHAT;
		my ($doc,$p);
		# If using match_url feature: ignore doc if not match start of one string
		if (exists $self->{match_url}){
			foreach (@{$self->{match_url}}){
				if ($doc_url !~ /^$_/){
					warn "URL out of scope: $doc_url $_\n" if $CHAT;
					delete $self->{todo}->{$doc_url};
					next DOC;
				} else {
					warn "URL ok by $_\n" if $CHAT;
				}
			}
		}

		if (exists $self->{FAILED}->{$doc_url} or exists $self->{DONE}->{$doc_url}){
			warn "Already done $doc_url.\n" if $CHAT;
			delete $self->{todo}->{$doc_url};
			next DOC;
		}

		if (exists $self->{dont}->{$doc_url}){
			warn "In IGNORE list: $doc_url.\n" if $CHAT;
			delete $self->{todo}->{$doc_url};
			next DOC;
		}

		if (exists $self->{dont}->{ALL} and not $self->{todo}->{$doc_url}){
			warn "Not in TODO list: $doc_url.\n" if $CHAT;
			delete $self->{todo}->{$doc_url};
			next DOC;
		}

		# Not in do list, not an image, not run with IGNORE NONE option
		if (not exists $self->{todo}->{$doc_url} and $doc_url !~ m|(\.$self->{ext_ok})$|i
		and not exists $self->{dont}->{NONE}){
			warn "Not in DO list - ignoring $doc_url .\n" if $CHAT;
			$self->{dont}->{$doc_url} = "Ignoring";
			delete $self->{todo}->{$doc_url};
			next DOC;
		}

		unless ($doc = $self->get_document($doc_url)){
			warn "Agent could not open $doc_url" if $CHAT;
			$self->{FAILED}->{$doc_url} = "Agent couldn't open document";
			delete $self->{todo}->{$doc_url};
			next DOC;
		}

		# If an image, save it
		if ($doc_url =~ m|(\.$self->{ext_ok})$|i) {
			$self->{DONE}->{$doc_url} = $self->_save_img($doc_url,$doc);
			warn "OK: $doc_url" if $CHAT;
			delete $self->{todo}->{$doc_url};
			next DOC;
		} else {
			$self->{DONE}->{$doc_url} = "Did HTML.";
			delete $self->{todo}->{$doc_url};
		}

		# Otherwise try to parse it
		unless ($p = new HTML::TokeParser( \$doc )){
			warn "* Couldn't create parser from \$doc\n" if $CHAT;
			$self->{FAILED}->{$doc_url} = "Couldn't create agent parser";
			delete $self->{todo}->{$doc_url};
			next DOC;
		}
		warn "OK - parsing document $doc_url ...\n" if $CHAT;

		while (my $token = $p->get_token){

			if (@$token[1] eq 'img' and exists @$token[2]->{src}){
				warn "*** Found image: @$token[2]->{src}\n" if $CHAT;
				my $uri = &abs_url( $doc_url, @$token[2]->{src} );
				if ($uri and not exists $self->{IGNORE0}->{$uri} and not exists $self->{DONE}->{$uri} and not exists $self->{FAILED}->{$uri}
				){
					$self->{todo}->{$uri} = 1;
				} else {
					warn "\t ignoring that img.\n" if $CHAT;
				}
			}
			elsif (@$token[1] =~ /^(area|a)$/ and exists @$token[2]->{href} and @$token[0] eq 'S'){
				warn "*** Found link: @$token[2]->{href}\n" if $CHAT;
				my $uri = &abs_url( $doc_url, @$token[2]->{href} );
				if ($uri and not exists $self->{dont}->{$uri} and not exists $self->{DONE}->{$uri} and not exists $self->{FAILED}->{$uri}
				and not (exists $self->{dont}->{ALL} and not exists $self->{todo}->{$uri})
				){
					$self->{todo}->{$uri} = 1;
				} else {
					warn "\t ignoring that link.\n" if $CHAT;
				}
			}
			elsif (@$token[1] eq 'frame' and exists(@$token[2]->{src})){	# This block (DL)
				warn "*** Found frame: @$token[2]->{src}\n" if $CHAT;
				my $uri = &abs_url( $doc_url, @$token[2]->{src} );
				if ($uri and not exists $self->{IGNORE0}->{$uri} and not exists $self->{DONE}->{$uri} and not exists $self->{FAILED}->{$uri}
				and not (exists $self->{dont}->{ALL} and not exists $self->{todo}->{$uri})				){
					$self->{todo}->{$uri} = 1;
				} else {
					warn "\t ignoring that frame.\n" if $CHAT;
				}
			}
		}	# Next token
		delete $self->{todo}->{$doc_url};
	} # Next DOC

	return $self;
} # End sub new





#
# SUB get_document
# Accepts a URL, returns the source of the document at the URL
#	or undef on failure
#
sub get_document { my ($self,$url) = (shift,shift);		# Recieve as argument the URL to access
	if ($url =~ m|(\.$self->{ext_bad})$|i) {				# (DL)
		warn "Ignoring - extension on the 'bad' list" if $CHAT;
		return undef;
	}
	my ($req,$res);
	my $ua = LWP::UserAgent->new;						# Create a new UserAgent
	for my $attempt (1..$self->{max_attempts}){
		if ($attempt!=1 and $attempt-1 == $self->{max_attempts}){
			$ua->agent('MSIE Internet Explorer 6.0 (Mozilla compatible'); # Naughty?
		} else {
			$ua->agent('Perl::'.__PACKAGE__.' v'.$VERSION);	# Give it a type name
		}
		warn "Attempt ($attempt) to access <$url>...\n"  if $CHAT;
		$req = new HTTP::Request('GET', $url); 			# Format URL request
		next if not defined $req;
		$res = $ua->request($req);						# $res is the object UA returned
		last if $res->is_success();					# If not successful
	}
	if (not defined $req){
		warn "...could not GET.\n" if $CHAT;
		return undef;
	}
	if (not $res->is_success()) {						# If not successful
		warn"...failed.\n"  if $CHAT;
		return undef
	}

	warn "...ok.\n" if $CHAT;
	# Test size
	if ((exists $self->{max_size} or exists $self->{min_size})
	and $url =~ m|(\.$self->{ext_ok})$|i) {
		$_ = length ($res->content);
		if (defined $_ and $self->{min_size} and $_ < $self->{min_size}){
			warn "Image size too small, ignoring.\n" if $CHAT;
			$self->{dont}->{$url} = "Size $_ bytes is too small.";
			return undef;
		}
		elsif (defined $_ and $self->{max_size} and $_ > $self->{max_size}){
			warn "Image size too large, ignoring.\n" if $CHAT;
			$self->{dont}->{$url} = "Size $_ bytes is too large.";
			return undef;
		}
	}
	return $res->content;							# $res->content  is the HTML the UA returned from the URL
}



# PRIVATE METHOD _save_img
#
# Accepts and the actual image source.
# Won't store same image twice.
#
# Returns the path the image was saved at.

sub _save_img { my ($self,$url,$img) = (shift,shift,shift,shift);
	local *OUT;
	my $filename;
	# Remvoe any file path from the $url
	if (exists $self->{DONE}->{$url} or exists $self->{FAILED}->{$url}){
		warn "Already got this one ($url), not saving.\n" if $CHAT;
		return undef;
	}
	$url =~ m|/([^./]+)(\.$self->{ext_ok})$|i;
	if ($self->{rename}){
		$filename = $self->{dir}.'/'.(join'',localtime).$2;
	} elsif ($self->{rename} == 2){				# )
		$filename = $url;					# } DL
		$filename =~ s/\/|\:|\~|\?/_/g;		# )
		$filename = $self->{dir}.'\\'.$filename;	# )
	} else {
		$filename = "$self->{dir}/$1$2";
	}
	warn "Saving image as <$filename>...\n"  if $CHAT;
	open OUT,">$filename" or warn "Couldn't open to save <$filename>!" and return "Failed to save.";
		binmode OUT;
		print OUT $img;
	close OUT;
	warn "...ok.\n" if $CHAT;
	return $filename;
}


#
# SUB abs_url returns an absolute URL for a $child_url linked from $parent_url
#
# DOC http://www.netverifier.com/pin/nicolette/jezfuzchr001.html
# SRC /pin/nicolette/jezfuzchr001.jpg
#
sub abs_url { my ($parent_url,$child_url) = (shift,shift);
	if ($child_url =~/^#/){
		return undef;
	}
	my $hack;
	if ($child_url =~ m|^/|) {
		$parent_url =~ s|^(http://[\w.]+)?/.*$|$1|i;
		return $parent_url.$child_url;
	}
	if ($child_url =~ m|^\.\.\/|i){
		$parent_url =~ s/\/[^\/|^~]+$//; # Strip filename (fix: DL)
		if ($parent_url =~ /\/$/){$parent_url =~ s/\/$//;}	# (DL)
		if ($child_url =~ /^\.\//){$child_url =~ s/^\.\///;}	# (DL)
		while ($child_url=~s/^\.\.\///gs ){
			$parent_url =~s/[^\/]+\/?$//;
		}
		$child_url = $parent_url.$child_url;
	} elsif ($child_url !~ m/^http:\/\//i){
		# Assume relative path needs dir
		$parent_url =~ s/\/[^\/]+$//;	# Strip filename
		if ($parent_url =~ /\/$/){ chop $parent_url }
		$child_url = $parent_url .'/'.$child_url;
	}
	return $child_url;
}


=head2 METHOD print_imgs

Print a list of the images saved.

=cut

sub print_imgs { my $self=shift;
	foreach (keys %{$self->{DONE}}){
		next if $_!~$self->{ext_ok};	# hack hack
		print "From $_\n\t$self->{DONE}->{$_}\n";
	}
}

=head2 METHOD imgs_as_hash

Returns a reference to a hash of images saved,
where keys are new image locations, values are original locations.

=cut

sub imgs_as_hash { my $self=shift;
	my $n = {};;
	foreach (keys %{$self->{DONE}}){
		next if $_!~$self->{ext_ok};	# hack hack
		$n->{$self->{DONE}->{$_}} = $_;
	}
	return $n;
}

=head2 METHOD print_done

Print a list of the URLs accessed
and return a reference to a hash of the same.

=cut

sub print_done { my $self=shift;
	foreach (keys %{$self->{DONE}}){
		print "At $_\n\t$self->{DONE}->{$_}\n";
	}
	return \$self->{DONE};
}

=head2 METHOD print_failed

Print a list of the URLs failed, and reasons
and return a reference to a hash of the same.

=cut

sub print_failed { my $self=shift;
	foreach (keys %{$self->{FAILED}}){
		print "At $_\n\t$self->{FAILED}->{$_}\n";
	}
	return \$self->{FAILED};
}

=head2 METHOD print_ignored

Print a list of the URLs ignored
and return a reference to a hash of the same.

=cut

sub print_ignored { my $self=shift;
	foreach (keys %{$self->{IGNORED}}){
		print "At $_\n\t$self->{IGNORED}->{$_}\n";
	}
	return \$self->{IGNORED};
}





1; # Return a true value for 'use'
__END__