#!/usr/bin/perl ################################################################################ # # # ############################################################################ # # # Title : HTML::Scrape::Tie::Word.pm # # # # Description : For use with tie(), ties a scalar to HTML::Scrape with a # # # # Machine for scraping random word websites. At the moment # # # # it supports < zokutou.co.uk > only. # # # # Coded by : Justin "HEYO--!" Lee # # # # Version : 00.04.01.03 # # # # Date : 2008-12-15 # # # # License : GNU General Public License v.2 # # # # Copyright (C) 2008 Justin Lee # # # ############################################################################ # # # # ############################################################################ # # # This program is free software; you can redistribute it and/or # # # # modify it under the terms of the GNU General Public License version 2 # # # # as published by the Free Software Foundation. # # # # # # # # This program is distributed in the hope that it will be useful, # # # # but WITHOUT ANY WARRANTY; without even the implied warranty of # # # # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # # # # GNU General Public License for more details. # # # # # # # # You should have received a copy of the GNU General Public License # # # # along with this program; if not, write to the Free Software # # # # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # # # # 02110-1301, USA. Or, see: # # # ############################################################################ # # # ################################################################################ ################### # CONFIG AND SUCH # ######################## # That wonderful stuff # ######################## package HTML::Scrape::Tie::Word; ################ # use lib LIB; # ################# # This needs to be changed # to inherit the same lib # as main (or the calling # package anyway). use lib join('/',split(/(?:\\|\/)+/,$ENV{'USERPROFILE'}),'library','perl'); # hax :) use strict; use warnings; use Carp; use LWP::Simple; use HTML::Scrape qw(put); # module by pc486 <3 my %MACHINE = ( 'ZOKUTOU' => [ # find the table { 'tag' => 'table', 'require' => { 'width' => qr/95%/, 'border' => 2, 'align' => qr/CENTER/i, 'cellpadding' => 8, 'cellspacing' => 0, 'bordercolor' => qr/85A1CC/i, 'bgcolor' => qr/BABFFF/i } }, # find the word's element { 'tag' => 'h4' }, # grab the word { 'text' => put('word') }, ], ); ############### # TIE METHODS # ############################### # Everything you need to tie! # ############################### sub TIESCALAR { my $class = shift; my $self = { # the url 'url' => _sanity_check(shift), # the scraper to use 'machine' => _sanity_check(shift), # the amount, shift or 1 prevents SOME idiocy 'get' => _sanity_check(int(shift or 1)), }; if (@_) { croak 'Usage error'; } # undef $class if url doesn't exist unless (defined($self->{'url'})) { carp 'Undefined url'; undef($class); } # test various aspects of, then setup the scraper if possible if (defined($self->{'machine'})) { # make sure the machine indicated by the user exists unless (exists($MACHINE{uc($self->{'machine'})})) { carp 'Invalid machine name'; undef($class); } # build the scraper unless ($self->{'scraper'} = new HTML::Scrape ( Machine => $MACHINE{uc($self->{'machine'})} ) ) { carp 'HTML::Scrape failed'; undef($class); } } else { carp 'No machine given'; undef($class); } # make sure 0 < GET < 4, else GET = 1 unless ($self->{'get'} > 0 and $self->{'get'} < 4) { $self->{'get'} = 1; } # if there were errors (undef $class) return 0 unless (defined($class)) { carp "Correct: tie \$word, 'ScrapeWord', (\$url,\$get)\n" . "Incorrect: tie \$word, 'ScrapeWord', [\$url,\$get]\n"; return 0; } # WE MADE IT! Bless me. ;-) return bless $self, $class; } sub FETCH { my $self = shift; my @word; # confess (die) if $self isn't right unless (ref($self)) { confess 'Reference error'; } # FETCH should not be assigned if (@_) { croak 'Usage error'; } # grab the words (if 1 < GET < 4) or word if GET == 1 # do a sleep 1; after each get to keep the servers happy... # this script isn't really fast anyway, what's another second? for (my $i = $self->{'get'}; $i--; ) { push(@word,_scrape_url($self->{'url'},$self->{'scraper'})); # sleep only if we're doing more than one sleep 1 if $i; unless (defined($word[-1])) { croak 'Error on word #' . @word . ' of ' . $self->{'get'}; } } _fisher_yates_shuffle(\@word) if @word > 1; return shift(@word); } # not quite implemented sub STORE { my $self = shift; my $conf = shift; # confess (die) if $self isn't right unless (ref($self)) { confess 'Reference error'; } # only one variable should come in if (@_) { croak 'Usage error'; } carp 'On-the-fly configuration changes and other such wonderful things not yet implemented'; } sub DESTROY { my $self = shift; # confess (die) if $self isn't right unless (ref($self)) { confess 'Reference error'; } undef($self); } ######################## # INTERNAL SUBROUTINES # #################################### # Just for use inside the module~! # #################################### ############### # _scrape_url # ################ # tsv() from ScrapeTest.pl is # fucking cryptic ;) # # grab the html, then scrape # it with the machine sub _scrape_url { my ($url,$scraper) = (shift,shift); unless (defined($url)) { confess 'No url provided to scraper'; return undef; } unless (defined($scraper)) { confess 'HOW CAN I SCRAPE WITH NO SCRAPER?'; return undef; } # must be predeclared my ($html,$word,$junk); # get html unless ($html = get($url)) { carp "Could not get HTML for: $url"; return undef; } # parse the scrape unless (defined($word = _scrape_parse($scraper->scrape($html,1)))) { carp 'Parser didn\'t like the junk it got'; return undef; } return $word; } ################# # _sanity_check # ################## # Plans for this sub are to have it # check for a hash ref, decode and # return it for TIESCALAR(). sub _sanity_check { my $r = shift; return undef unless defined($r); # nothingness breeds nothing return undef if ref($r); return $r; } ################# # _scrape_parse # ################## # Parses the garbage that # HTML::Scrape spits out # ;) <3 sub _scrape_parse { my $junk = shift; unless (defined($junk)) { carp 'Missing junk'; return undef; } unless (ref($junk) =~ /HASH/io) { confess "Weird error: @{[ref($junk) or 'No reference' ]}"; } unless (exists($junk->{'word'})) { confess 'Wrong machine? This is most likely a weird error'; } unless ($junk->{'word'} =~ /^(?:\s*\w+\s*)$/o) { carp 'YOU LIE! That\'s probably not a word'; return undef; } return $junk->{'word'}; } ######################### # _fisher_yates_shuffle # ########################## # from the perl cookbook # # let it be known that I love # this little tidbit of code # # shuffles an array of length # greater than one sub _fisher_yates_shuffle { my $array = shift; my $i; for ($i = @$array; --$i; ) { my $j = int rand ($i+1); next if $i == $j; @$array[$i,$j] = @$array[$j,$i]; } }