lib/Grep/Source.pm

# Dobrica Pavlinusic, <dpavlin@rot13.org> 02/22/07 20:30:00 CET

use strict;
use warnings;

package Grep::Source;

use Carp qw/verbose/;
use Module::Pluggable search_path => 'Grep::Source', sub_name => 'sources', require => 1;
use base qw(Class::Accessor Jifty::Object);
Grep::Source->mk_accessors( qw(feed uri q new_items collection) );

use HTML::TreeBuilder;
use WWW::Mechanize;
use XML::Feed;
use URI;
use HTML::ResolveLink;

use Data::Dump qw/dump/;

=head1 NAME

Grep::Source - base class for implementation of different sources for Grep

=head1 METHODS

This is mostly documentation because most of methods are implemented by plugins.

=head2 sources

  my @sources = Grep::Source->sources();

Returns all available sources.

=cut

Jifty->log->debug("Found source plugins: ", join(", ", __PACKAGE__->sources() ) );

=head2 new

  my $source = Grep::Source->new({ feed => $feed_record });

This will also setup:

=head2 feed

isa L<Grep::Model::Feed>

=head2 search

  my $collection = $source->search( 'query string' );

It will also setup following accessors:

=head2 q

Search query 

=head2 uri

URI of feed with embedded search query

=head2 new_items

Number of new items in result collection

=head2 collection

Actuall results which is L<Grep::Model::ItemCollection>, so following will
work:

  print "and ", $self->collection->count, " total items";


Also setups number of new items

  print $source->new_items, " items new";

=cut

sub search {
        my $self = shift;

        my $q = shift;

        $q ? $self->q( $q ) : $q = $self->q;

        die "no q?" unless ( $self->q );
        die "no feed?" unless ( $self->feed );
        die "feed not Grep::Model::Feed" unless ( $self->feed->isa('Grep::Model::Feed') );

        my $message;
        my $uri = $self->feed->uri;
        if ($uri =~ m/%s/) {
                $uri = $self->feed->search_uri( $q );
                $message = 'Searching';
        } else {
                $message = 'Fetching';
        }
        $message .= ' ' . $self->feed->title . " at $uri";

        $self->uri( $uri );

        $self->log->info( $message );

        $self->collection( Grep::Model::ItemCollection->new() );

        my $class = $self->feed->source || 'Grep::Source::Feed';
        $self->log->debug("using $class");

        my $parent = $self;
        $class->fetch( $parent );
        undef $parent;

        Grep::Search->finish if $self->new_items;

        return $self->collection;
}

=head2 add_record

Plugins will be called with parametar C<$parent> so they can call this method to add
record into result collection (and store in cache and index).

  $parent->add_record( id => 42, foo => 'bar', ... );

This will also update L</new_items>

=cut

sub add_record {
        my $self = shift;

        my $i = Grep::Model::Item->new();

        my $rec = {@_};

        warn "resolving links";
        my $resolver = HTML::ResolveLink->new( base => $rec->{link} );
        $rec->{content} = $resolver->resolve( $rec->{content} );

        my ($ok,$msg) = $i->load_or_create( %$rec );

        $msg ||= '';

        if ( $ok ) {
                $self->log->debug("item ", $i->id, ": $msg");
                $self->collection->add_record( $i );

                # is new record?
                if ( $msg !~ m/^Found/ ) {
                        Grep::Search->add( $i );
                        $self->new_items( ( $self->new_items || 0 ) + 1 );
                }
        } else {
                warn "can't add entry ", dump( @_ ), "\n";
        }
}

=head2 content_class

Return class registred for particular content.

  my $class = $source->content_class( $content );

=cut

sub content_class {
        my $self = shift;

        my $content = shift or die "no content?";

        foreach my $s ( $self->sources ) {
                $self->log->debug("testing source class $s");
                if ( $s->can('content_have') ) {
                        my $regex =     $s->content_have( $content ) or
                                die "${s}->content_have didn't return anything";
                        die "${s}->content_have didn't return regex but ", dump( $regex ), " ref ", ref( $regex )
                                unless ( ref($regex) eq 'Regexp' );
                        if ( $content =~ $regex ) {
                                $self->log->debug("${s}->content_have succesful");
                                return $s;
                        }
                }
        }
}

=head2 scrape

Create semi-complex L<WWW::Mechanize> rules to scrape page


=cut

sub scrape {
        my $self = shift;

        my $args = {@_};

        warn "scrape got args ",dump($args);

        my ($feed,$uri,$q) = ($self->feed, $self->uri,$self->q);
        die "no uri" unless ($uri);
        die "feed is not a Grep::Model::Feed but ", ref $feed unless $feed->isa('Grep::Model::Feed');

        sub mech_warn {
                my $m = shift || return;
                warn $m;
        }

        my $mech = WWW::Mechanize->new(
                cookie_jar => {},
                onwarn => \&mech_warn,
                onerror => \&mech_warn,
        );

        $mech->get( $uri );

        $self->save( 'get.html', $mech->content );

        if ( my $form = $args->{submit_form} ) {
                warn "submit form on $uri with ", dump( $form ),"\n";
                $mech->submit_form( %$form ) or die "can't submit form ", dump( $form );
                $self->save( 'submit.html', $mech->content );
        }

        warn "parse result page\n";

        my $tree = HTML::TreeBuilder->new or die "can't create html tree";
        $tree->parse( $mech->content ) or die "can't parse fetched content";

        die "wrapper doesn't have 3 elements but ", $#{ $args->{wrapper} } unless ( $#{ $args->{wrapper} } == 2 );
        my ( $el,$attr,$value ) = @{ $args->{wrapper} };

        warn "looking for <$el $attr=\"$value\">";

        my $div = $tree->look_down( '_tag', $el, sub {
                        warn dump( $_[0]->attr( $attr ) ),$/;
                        ( $_[0]->attr( $attr ) || '' ) eq $value;
        });

        if ( ! $div ) {
                warn "can't find results wrapper <$el $attr=\"$value\">";
                return;
        }

        my $max = 5;
        my $nr = 1;

        my $base_uri = $uri;
        $base_uri =~ s!\?.*$!!;

        foreach my $dt ( $div->look_down( '_tag', $args->{results} ) ) {
                my $a = $dt->look_down( '_tag', 'a', sub { $_[0]->attr('href') } );
                if ( $a ) {

                        my $href = $a->attr('href') or die "can't find href inside <", $args->{results}, ">";
                        my $page_uri = URI->new_abs( $a->attr('href'), $base_uri );
                        $page_uri->query( undef );
                        $page_uri = $page_uri->canonical;

                        warn "fetching page: ",$a->as_text," from $page_uri\n";
                        if ( $mech->follow_link( url => $a->attr('href') ) ) {

                                $self->save( "page-${nr}.html", $mech->content );

                                my $page_tree = HTML::TreeBuilder->new or die "can't create page tree";
                                $page_tree->parse( $mech->content ) or die "can't parse page at $page_uri";

                                ( $el,$attr,$value ) = @{ $args->{scrape} };
                                $div = $page_tree->look_down( '_tag', $el, sub { ( $_[0]->attr( $attr ) || '' ) eq $value } );

                                die "can't find <$el $attr=\"$value\">" unless ($div);

                                $self->add_record(
                                        in_feed => $feed,
                                        title => $mech->title,
                                        link => $page_uri,
                                        content => $div->as_HTML,
#                                       summary => 
#                                       category => 
#                                       author => 
#                                       issued => 
#                                       modified => 
                                );

                                $mech->back;
                                $page_tree->delete;

                        } else {
                                warn "can't follow uri $page_uri: $!\n";
                        }
                }

                last if ($nr == $max);
                $nr++;
        }

        $tree->delete; # clear memory!

}

=head2 save

  save( 'name', $content );

Save dumps into C</tmp/grep> if writable

=cut

sub save {
        my $self = shift;
        my ( $file, $content ) = @_;
        return unless ( defined($file) && defined($content) );
        if ( -w '/tmp/grep' ) {
                open(my $f, '>', "/tmp/grep/$file") or die "can't open $file: $!";
                print $f $content or die "can't write to $file: $!";
                close $f or die "can't close $file: $!";
                $self->log->debug("saved $file ",length($content)," bytes");
        }
}

1;
1	dpavlin	72	# Dobrica Pavlinusic, <dpavlin@rot13.org> 02/22/07 20:30:00 CET
2
3			use strict;
4			use warnings;
5
6			package Grep::Source;
7
8			use Carp qw/verbose/;
9			use Module::Pluggable search_path => 'Grep::Source', sub_name => 'sources', require => 1;
10	dpavlin	100	use base qw(Class::Accessor Jifty::Object);
11	dpavlin	72	Grep::Source->mk_accessors( qw(feed uri q new_items collection) );
12
13	dpavlin	85	use HTML::TreeBuilder;
14			use WWW::Mechanize;
15			use XML::Feed;
16			use URI;
17	dpavlin	96	use HTML::ResolveLink;
18	dpavlin	85
19	dpavlin	72	use Data::Dump qw/dump/;
20
21			=head1 NAME
22
23			Grep::Source - base class for implementation of different sources for Grep
24
25			=head1 METHODS
26
27			This is mostly documentation because most of methods are implemented by plugins.
28
29			=head2 sources
30
31			my @sources = Grep::Source->sources();
32
33			Returns all available sources.
34
35			=cut
36
37	dpavlin	73	Jifty->log->debug("Found source plugins: ", join(", ", __PACKAGE__->sources() ) );
38	dpavlin	72
39			=head2 new
40
41			my $source = Grep::Source->new({ feed => $feed_record });
42
43	dpavlin	73	This will also setup:
44
45			=head2 feed
46
47			isa L<Grep::Model::Feed>
48
49	dpavlin	72	=head2 search
50
51			my $collection = $source->search( 'query string' );
52
53			It will also setup following accessors:
54
55	dpavlin	73	=head2 q
56	dpavlin	72
57			Search query
58
59	dpavlin	73	=head2 uri
60	dpavlin	72
61			URI of feed with embedded search query
62
63	dpavlin	73	=head2 new_items
64	dpavlin	72
65			Number of new items in result collection
66
67			=head2 collection
68
69			Actuall results which is L<Grep::Model::ItemCollection>, so following will
70			work:
71
72			print "and ", $self->collection->count, " total items";
73
74
75			Also setups number of new items
76
77			print $source->new_items, " items new";
78
79			=cut
80
81			sub search {
82			my $self = shift;
83
84			my $q = shift;
85
86			$q ? $self->q( $q ) : $q = $self->q;
87
88			die "no q?" unless ( $self->q );
89			die "no feed?" unless ( $self->feed );
90			die "feed not Grep::Model::Feed" unless ( $self->feed->isa('Grep::Model::Feed') );
91
92			my $message;
93			my $uri = $self->feed->uri;
94			if ($uri =~ m/%s/) {
95			$uri = $self->feed->search_uri( $q );
96			$message = 'Searching';
97			} else {
98			$message = 'Fetching';
99			}
100			$message .= ' ' . $self->feed->title . " at $uri";
101
102			$self->uri( $uri );
103
104	dpavlin	100	$self->log->info( $message );
105	dpavlin	72
106			$self->collection( Grep::Model::ItemCollection->new() );
107
108	dpavlin	73	my $class = $self->feed->source \|\| 'Grep::Source::Feed';
109	dpavlin	100	$self->log->debug("using $class");
110	dpavlin	72
111	dpavlin	96	my $parent = $self;
112			$class->fetch( $parent );
113			undef $parent;
114	dpavlin	72
115			Grep::Search->finish if $self->new_items;
116
117			return $self->collection;
118			}
119
120			=head2 add_record
121
122	dpavlin	73	Plugins will be called with parametar C<$parent> so they can call this method to add
123			record into result collection (and store in cache and index).
124
125	dpavlin	72	$parent->add_record( id => 42, foo => 'bar', ... );
126
127	dpavlin	73	This will also update L</new_items>
128
129	dpavlin	72	=cut
130
131			sub add_record {
132			my $self = shift;
133
134			my $i = Grep::Model::Item->new();
135
136	dpavlin	96	my $rec = {@_};
137	dpavlin	72
138	dpavlin	96	warn "resolving links";
139			my $resolver = HTML::ResolveLink->new( base => $rec->{link} );
140			$rec->{content} = $resolver->resolve( $rec->{content} );
141
142			my ($ok,$msg) = $i->load_or_create( %$rec );
143
144	dpavlin	72	$msg \|\|= '';
145
146			if ( $ok ) {
147	dpavlin	100	$self->log->debug("item ", $i->id, ": $msg");
148	dpavlin	72	$self->collection->add_record( $i );
149
150			# is new record?
151			if ( $msg !~ m/^Found/ ) {
152			Grep::Search->add( $i );
153	dpavlin	74	$self->new_items( ( $self->new_items \|\| 0 ) + 1 );
154	dpavlin	72	}
155			} else {
156			warn "can't add entry ", dump( @_ ), "\n";
157			}
158			}
159
160	dpavlin	73	=head2 content_class
161
162			Return class registred for particular content.
163
164			my $class = $source->content_class( $content );
165
166			=cut
167
168			sub content_class {
169			my $self = shift;
170
171			my $content = shift or die "no content?";
172
173			foreach my $s ( $self->sources ) {
174	dpavlin	100	$self->log->debug("testing source class $s");
175	dpavlin	82	if ( $s->can('content_have') ) {
176			my $regex = $s->content_have( $content ) or
177			die "${s}->content_have didn't return anything";
178			die "${s}->content_have didn't return regex but ", dump( $regex ), " ref ", ref( $regex )
179			unless ( ref($regex) eq 'Regexp' );
180			if ( $content =~ $regex ) {
181	dpavlin	100	$self->log->debug("${s}->content_have succesful");
182	dpavlin	82	return $s;
183			}
184	dpavlin	73	}
185			}
186			}
187
188	dpavlin	85	=head2 scrape
189
190			Create semi-complex L<WWW::Mechanize> rules to scrape page
191
192
193			=cut
194
195			sub scrape {
196			my $self = shift;
197
198			my $args = {@_};
199
200			warn "scrape got args ",dump($args);
201
202			my ($feed,$uri,$q) = ($self->feed, $self->uri,$self->q);
203			die "no uri" unless ($uri);
204			die "feed is not a Grep::Model::Feed but ", ref $feed unless $feed->isa('Grep::Model::Feed');
205
206	dpavlin	92	sub mech_warn {
207			my $m = shift \|\| return;
208			warn $m;
209			}
210	dpavlin	85
211	dpavlin	92	my $mech = WWW::Mechanize->new(
212			cookie_jar => {},
213			onwarn => \&mech_warn,
214			onerror => \&mech_warn,
215			);
216
217	dpavlin	85	$mech->get( $uri );
218
219	dpavlin	86	$self->save( 'get.html', $mech->content );
220	dpavlin	85
221	dpavlin	92	if ( my $form = $args->{submit_form} ) {
222			warn "submit form on $uri with ", dump( $form ),"\n";
223			$mech->submit_form( %$form ) or die "can't submit form ", dump( $form );
224	dpavlin	86	$self->save( 'submit.html', $mech->content );
225	dpavlin	85	}
226
227			warn "parse result page\n";
228
229			my $tree = HTML::TreeBuilder->new or die "can't create html tree";
230			$tree->parse( $mech->content ) or die "can't parse fetched content";
231
232			die "wrapper doesn't have 3 elements but ", $#{ $args->{wrapper} } unless ( $#{ $args->{wrapper} } == 2 );
233			my ( $el,$attr,$value ) = @{ $args->{wrapper} };
234
235			warn "looking for <$el $attr=\"$value\">";
236
237			my $div = $tree->look_down( '_tag', $el, sub {
238			warn dump( $_[0]->attr( $attr ) ),$/;
239			( $_[0]->attr( $attr ) \|\| '' ) eq $value;
240			});
241
242	dpavlin	88	if ( ! $div ) {
243			warn "can't find results wrapper <$el $attr=\"$value\">";
244			return;
245			}
246	dpavlin	85
247			my $max = 5;
248			my $nr = 1;
249
250			my $base_uri = $uri;
251			$base_uri =~ s!\?.*$!!;
252
253			foreach my $dt ( $div->look_down( '_tag', $args->{results} ) ) {
254			my $a = $dt->look_down( '_tag', 'a', sub { $_[0]->attr('href') } );
255			if ( $a ) {
256
257			my $href = $a->attr('href') or die "can't find href inside <", $args->{results}, ">";
258			my $page_uri = URI->new_abs( $a->attr('href'), $base_uri );
259			$page_uri->query( undef );
260			$page_uri = $page_uri->canonical;
261
262			warn "fetching page: ",$a->as_text," from $page_uri\n";
263			if ( $mech->follow_link( url => $a->attr('href') ) ) {
264
265	dpavlin	86	$self->save( "page-${nr}.html", $mech->content );
266	dpavlin	85
267			my $page_tree = HTML::TreeBuilder->new or die "can't create page tree";
268			$page_tree->parse( $mech->content ) or die "can't parse page at $page_uri";
269
270	dpavlin	92	( $el,$attr,$value ) = @{ $args->{scrape} };
271			$div = $page_tree->look_down( '_tag', $el, sub { ( $_[0]->attr( $attr ) \|\| '' ) eq $value } );
272	dpavlin	85
273			die "can't find <$el $attr=\"$value\">" unless ($div);
274
275			$self->add_record(
276			in_feed => $feed,
277			title => $mech->title,
278			link => $page_uri,
279			content => $div->as_HTML,
280			# summary =>
281			# category =>
282			# author =>
283			# issued =>
284			# modified =>
285			);
286
287			$mech->back;
288			$page_tree->delete;
289
290			} else {
291			warn "can't follow uri $page_uri: $!\n";
292			}
293			}
294
295			last if ($nr == $max);
296			$nr++;
297			}
298
299			$tree->delete; # clear memory!
300
301			}
302
303	dpavlin	86	=head2 save
304
305			save( 'name', $content );
306
307			Save dumps into C</tmp/grep> if writable
308
309			=cut
310
311			sub save {
312			my $self = shift;
313			my ( $file, $content ) = @_;
314	dpavlin	100	return unless ( defined($file) && defined($content) );
315	dpavlin	86	if ( -w '/tmp/grep' ) {
316			open(my $f, '>', "/tmp/grep/$file") or die "can't open $file: $!";
317			print $f $content or die "can't write to $file: $!";
318			close $f or die "can't close $file: $!";
319	dpavlin	100	$self->log->debug("saved $file ",length($content)," bytes");
320	dpavlin	86	}
321			}
322
323	dpavlin	72	1;