/[Grep]/lib/Grep/Source.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /lib/Grep/Source.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 85 by dpavlin, Fri Feb 23 20:47:08 2007 UTC revision 102 by dpavlin, Sun Mar 4 22:16:23 2007 UTC
# Line 7  package Grep::Source; Line 7  package Grep::Source;
7    
8  use Carp qw/verbose/;  use Carp qw/verbose/;
9  use Module::Pluggable search_path => 'Grep::Source', sub_name => 'sources', require => 1;  use Module::Pluggable search_path => 'Grep::Source', sub_name => 'sources', require => 1;
10  use base qw(Class::Accessor);  use base qw(Class::Accessor Jifty::Object);
11  Grep::Source->mk_accessors( qw(feed uri q new_items collection) );  Grep::Source->mk_accessors( qw(feed uri q new_items collection) );
12    
13  use HTML::TreeBuilder;  use HTML::TreeBuilder;
14  use WWW::Mechanize;  use WWW::Mechanize;
15  use XML::Feed;  use XML::Feed;
16  use URI;  use URI;
17    use HTML::ResolveLink;
18    
19  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
20    
# Line 100  sub search { Line 101  sub search {
101    
102          $self->uri( $uri );          $self->uri( $uri );
103    
104          Jifty->log->info( $message );          $self->log->info( $message );
105    
106          $self->collection( Grep::Model::ItemCollection->new() );          $self->collection( Grep::Model::ItemCollection->new() );
107    
108          my $class = $self->feed->source || 'Grep::Source::Feed';          my $class = $self->feed->source || 'Grep::Source::Feed';
109          Jifty->log->debug("using $class");          $self->log->debug("using $class");
110    
111          $class->fetch( $self );          my $parent = $self;
112            $class->fetch( $parent );
113            undef $parent;
114    
115          Grep::Search->finish if $self->new_items;          Grep::Search->finish if $self->new_items;
116    
# Line 130  sub add_record { Line 133  sub add_record {
133    
134          my $i = Grep::Model::Item->new();          my $i = Grep::Model::Item->new();
135    
136          my ($ok,$msg) = $i->load_or_create( @_ );          my $rec = {@_};
137    
138            $self->log->debug("resolving links using base ", $rec->{link});
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          $msg ||= '';          $msg ||= '';
145    
146          if ( $ok ) {          if ( $ok ) {
147                  Jifty->log->debug("item ", $i->id, ": $msg");                  $self->log->debug("item ", $i->id, ": $msg");
148                  $self->collection->add_record( $i );                  $self->collection->add_record( $i );
149    
150                  # is new record?                  # is new record?
# Line 162  sub content_class { Line 171  sub content_class {
171          my $content = shift or die "no content?";          my $content = shift or die "no content?";
172    
173          foreach my $s ( $self->sources ) {          foreach my $s ( $self->sources ) {
174                  Jifty->log->debug("testing source class $s");                  $self->log->debug("testing source class $s");
175                  if ( $s->can('content_have') ) {                  if ( $s->can('content_have') ) {
176                          my $regex =     $s->content_have( $content ) or                          my $regex =     $s->content_have( $content ) or
177                                  die "${s}->content_have didn't return anything";                                  die "${s}->content_have didn't return anything";
178                          die "${s}->content_have didn't return regex but ", dump( $regex ), " ref ", ref( $regex )                          die "${s}->content_have didn't return regex but ", dump( $regex ), " ref ", ref( $regex )
179                                  unless ( ref($regex) eq 'Regexp' );                                  unless ( ref($regex) eq 'Regexp' );
180                          if ( $content =~ $regex ) {                          if ( $content =~ $regex ) {
181                                  Jifty->log->debug("${s}->content_have succesful");                                  $self->log->debug("${s}->content_have succesful");
182                                  return $s;                                  return $s;
183                          }                          }
184                  }                  }
# Line 188  sub scrape { Line 197  sub scrape {
197    
198          my $args = {@_};          my $args = {@_};
199    
200          warn "scrape got args ",dump($args);          $self->log->debug("scrape with args ",dump($args));
201    
202          my ($feed,$uri,$q) = ($self->feed, $self->uri,$self->q);          my ($feed,$uri,$q) = ($self->feed, $self->uri,$self->q);
203          die "no uri" unless ($uri);          die "no uri" unless ($uri);
204          die "feed is not a Grep::Model::Feed but ", ref $feed unless $feed->isa('Grep::Model::Feed');          die "feed is not a Grep::Model::Feed but ", ref $feed unless $feed->isa('Grep::Model::Feed');
205    
206          sub save_html {          sub mech_warn {
207                  my ( $file, $content ) = @_;                  my $m = shift || return;
208                  if ( -w '/tmp/grep' ) {                  warn $m;
                         open(my $f, '>', "/tmp/grep/${file}.html") or die "can't open $file: $!";  
                         print $f $content or die "can't write to $file: $!";  
                         close $f or die "can't close $file: $!";  
                 }  
209          }          }
210    
211          my $mech = WWW::Mechanize->new();          my $mech = WWW::Mechanize->new(
212                    cookie_jar => {},
213                    onwarn => \&mech_warn,
214                    onerror => \&mech_warn,
215            );
216    
217          $mech->get( $uri );          $mech->get( $uri );
218    
219          save_html( 'get', $mech->content );          $self->save( 'get.html', $mech->content );
220    
221          if ( $args->{submit_form} ) {          if ( my $form = $args->{submit_form} ) {
222                  warn "submit form on $uri\n";                  $self->log->debug("submit form on $uri with ", dump( $form ));
223                  $mech->submit_form( %{ $args->{submit_form} } ) or die "can't submit form";                  $mech->submit_form( %$form ) or die "can't submit form ", dump( $form );
224                  save_html( 'submit', $mech->content );                  $self->save( 'submit.html', $mech->content );
225          }          }
226    
227          warn "parse result page\n";          $self->log->debug("parse result page");
228    
229          my $tree = HTML::TreeBuilder->new or die "can't create html tree";          my $tree = HTML::TreeBuilder->new or die "can't create html tree";
230          $tree->parse( $mech->content ) or die "can't parse fetched content";          $tree->parse( $mech->content ) or die "can't parse fetched content";
# Line 223  sub scrape { Line 232  sub scrape {
232          die "wrapper doesn't have 3 elements but ", $#{ $args->{wrapper} } unless ( $#{ $args->{wrapper} } == 2 );          die "wrapper doesn't have 3 elements but ", $#{ $args->{wrapper} } unless ( $#{ $args->{wrapper} } == 2 );
233          my ( $el,$attr,$value ) = @{ $args->{wrapper} };          my ( $el,$attr,$value ) = @{ $args->{wrapper} };
234    
235          warn "looking for <$el $attr=\"$value\">";          $self->log->debug("looking for <$el $attr=\"$value\">");
236    
237          my $div = $tree->look_down( '_tag', $el, sub {          my $div = $tree->look_down( '_tag', $el, sub {
                         warn dump( $_[0]->attr( $attr ) ),$/;  
238                          ( $_[0]->attr( $attr ) || '' ) eq $value;                          ( $_[0]->attr( $attr ) || '' ) eq $value;
239          });          });
240    
241          die "can't find results wrapper <$el $attr=\"$value\">" unless ( $div );          if ( ! $div ) {
242                    warn "can't find results wrapper <$el $attr=\"$value\">";
243                    return;
244            }
245    
246          my $max = 5;          my $max = 5;
247          my $nr = 1;          my $nr = 1;
# Line 247  sub scrape { Line 258  sub scrape {
258                          $page_uri->query( undef );                          $page_uri->query( undef );
259                          $page_uri = $page_uri->canonical;                          $page_uri = $page_uri->canonical;
260    
261                          warn "fetching page: ",$a->as_text," from $page_uri\n";                          $self->log->debug("fetching page: ",$a->as_text," from $page_uri");
262                          if ( $mech->follow_link( url => $a->attr('href') ) ) {                          if ( $mech->follow_link( url => $a->attr('href') ) ) {
263    
264                                  save_html( "page-${nr}", $mech->content );                                  $self->save( "page-${nr}.html", $mech->content );
265    
266                                  my $page_tree = HTML::TreeBuilder->new or die "can't create page tree";                                  my $page_tree = HTML::TreeBuilder->new or die "can't create page tree";
267                                  $page_tree->parse( $mech->content ) or die "can't parse page at $page_uri";                                  $page_tree->parse( $mech->content ) or die "can't parse page at $page_uri";
268    
269                                  my ( $el,$attr,$value ) = @{ $args->{scrape} };                                  ( $el,$attr,$value ) = @{ $args->{scrape} };
270                                  my $div = $page_tree->look_down( '_tag', $el, sub { ( $_[0]->attr( $attr ) || '' ) eq $value } );                                  $div = $page_tree->look_down( '_tag', $el, sub { ( $_[0]->attr( $attr ) || '' ) eq $value } );
271    
272                                  die "can't find <$el $attr=\"$value\">" unless ($div);                                  die "can't find <$el $attr=\"$value\">" unless ($div);
273    
# Line 288  sub scrape { Line 299  sub scrape {
299    
300  }  }
301    
302    =head2 save
303    
304      save( 'name', $content );
305    
306    Save dumps into C</tmp/grep> if writable
307    
308    =cut
309    
310    sub save {
311            my $self = shift;
312            my ( $file, $content ) = @_;
313            return unless ( defined($file) && defined($content) );
314            if ( -w '/tmp/grep' ) {
315                    open(my $f, '>', "/tmp/grep/$file") or die "can't open $file: $!";
316                    print $f $content or die "can't write to $file: $!";
317                    close $f or die "can't close $file: $!";
318                    $self->log->debug("saved $file ",length($content)," bytes");
319            }
320    }
321    
322  1;  1;
Legend:
Removed from v.85  
changed lines
  Added in v.102
  ViewVC Help
Powered by ViewVC 1.1.26