#!/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 <kool.name at gmail.com> # #
# ############################################################################ #
# #
# ############################################################################ #
# # 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: <http://www.gnu.org/licenses/> # #
# ############################################################################ #
# #
################################################################################
###################
# 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];
}
}