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

	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;

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

package HTTP::GetImages;

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

$VERSION=0.343;

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

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

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

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

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

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

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

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__