File Coverage

blib/lib/WE_Frontend/LinkChecker.pm
Criterion Covered Total %
statement 18 179 10.0
branch 0 74 0.0
condition n/a
subroutine 6 21 28.5
pod 5 7 71.4
total 29 281 10.3


line stmt bran cond sub pod time code
1             # -*- perl -*-
2              
3             #
4             # $Id: LinkChecker.pm,v 1.8 2005/11/04 00:32:48 eserte Exp $
5             # Author: Slaven Rezic
6             #
7             # Copyright (C) 2002 Online Office Berlin. All rights reserved.
8             # Copyright (C) 2002,2003 Slaven Rezic.
9             # This is free software; you can redistribute it and/or modify it under the
10             # terms of the GNU General Public License, see the file COPYING.
11              
12             #
13             # Mail: slaven@rezic.de
14             # WWW: http://we-framework.sourceforge.net
15             #
16              
17             package WE_Frontend::LinkChecker;
18              
19 1     1   74303 use HTML::LinkExtor;
  1         2  
  1         29  
20 1     1   6 use URI;
  1         2  
  1         26  
21 1     1   5 use LWP::UserAgent;
  1         4  
  1         30  
22              
23 1     1   6 use strict;
  1         3  
  1         32  
24 1     1   6 use vars qw($VERSION $VERBOSE);
  1         2  
  1         121  
25             $VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/);
26              
27 1     1   7 use base qw(Class::Accessor);
  1         2  
  1         2563  
28             __PACKAGE__->mk_accessors(qw(Restrict Follow Ignore Url Pending SeenOk SeenError Ua));
29              
30             sub new {
31 0     0 1   my($class, %args) = @_;
32 0           my $self = {};
33 0           bless $self, $class;
34              
35 0           $self->Follow(undef);
36 0           $self->Restrict(undef);
37 0           $self->Ignore(undef);
38 0           while(my($k,$v) = each %args) {
39 0           $self->{ucfirst(substr($k,1))} = $v;
40             }
41 0           $self->SeenOk({});
42 0           $self->SeenError({});
43 0           $self->Pending([]);
44 0           $self;
45             }
46              
47             sub get_all_urls {
48 0     0 0   my $self = shift;
49 0 0         if (ref $self->Url eq 'ARRAY') {
50 0           @{$self->Url};
  0            
51             } else {
52 0           $self->Url;
53             }
54             }
55              
56             sub check_html {
57 0     0 1   my($self) = @_;
58 0           my $html = "";
59 0           $html .= "

Linkcheck results

";
60 0           $html .= "

Configuration

";
61 0           $html .= $self->check_html_header;
62              
63 0           my %fail_urls = $self->check;
64 0           $html .= "

Link errors

";
65 0 0         if (%fail_urls) {
66 0           foreach my $caller (sort keys %fail_urls) {
67 0           $html .= $self->output_failed_url_as_html($caller, $fail_urls{$caller});
68             }
69             } else {
70 0           $html .= "None.

\n";

71             }
72 0           $html .= "Back";
73 0           $html;
74             }
75              
76             sub check_tt {
77 0     0 1   my($self, $tt, $template, $extra_args) = @_;
78 0           my $html;
79 0 0         $tt->process($template, { self => $self,
    0          
80             fail_urls => { $self->check },
81             ($extra_args ? %$extra_args : ()),
82             }, \$html)
83             or die $tt->error;
84 0           $html;
85             }
86              
87             sub check_html_header {
88 0     0 1   my $self = shift;
89 0           my $html = "";
90 0           $html .= "Checked start URLs:
    \n";
91 0           foreach my $url ($self->get_all_urls) {
92 0           $html .= "
  • $url\n"; # XXX escape
  • 93             }
    94 0           $html .= "\n";
    95              
    96 0           $html .= "Restrict to:
      \n";
    97 0 0         if (!$self->Restrict) {
    98 0           $html .= "
  • none\n";
  • 99             } else {
    100 0           foreach my $url (@{ $self->Restrict }) {
      0            
    101 0           $html .= "
  • $url\n"; # XXX escape
  • 102             }
    103             }
    104 0           $html .= "\n";
    105              
    106 0           $html .= "Follow:
      \n";
    107 0 0         if (!$self->Follow) {
    108 0           $html .= "
  • all non-restricted\n";
  • 109             } else {
    110 0           foreach my $url (@{ $self->Follow }) {
      0            
    111 0           $html .= "
  • $url\n"; # XXX escape
  • 112             }
    113             }
    114 0           $html .= "\n";
    115 0           $html;
    116             }
    117              
    118             sub output_failed_url_as_html {
    119 0     0 0   my($self, $caller, $failures) = @_;
    120 0           my $html = "

    " . _we_page_link($caller) . "

    \n
      ";
    121 0           foreach my $fail_url (sort keys %$failures) {
    122 0           $html .= "
  • " . _we_failed_page($fail_url) . " (Error: @{[ $self->SeenError->{$fail_url}->{Code} ]})\n"; # XXX HTML escape
  •   0            
    123             }
    124 0           $html .= "\n";
    125 0           $html;
    126             }
    127              
    128             sub _we_failed_page {
    129 0     0     my $url = shift;
    130             # XXX lang-dependent strings
    131 0 0         if ($url =~ m|/images/|) {
        0          
        0          
        0          
        0          
    132 0           "internal image ($url)";
    133             } elsif ($url =~ m|/(site_)?photos/|) {
    134 0           "embedded photo ($url)";
    135             } elsif ($url =~ m|/videos/|) {
    136 0           "video link ($url)";
    137             } elsif ($url =~ m|/download/|) {
    138 0           "download link ($url)";
    139             } elsif ($url =~ m|/headlines/|) {
    140 0           "headline image ($url)";
    141             } else {
    142 0           $url;
    143             }
    144             }
    145              
    146             # XXX do not hardcode any code or URLs!!!
    147             sub _we_page_link {
    148             # XXX html escape
    149 0     0     my $url = shift;
    150 0 0         if ($url =~ m|/html/[^/]+/(\d+)\.html$|) {
        0          
    151 0           my $id = $1;
    152 0           q{}.$url.q{ (EDIT)};
    153             ## XXX opener geht nach dem ersten Mal verloren
    154             #q{}.$url.q{};
    155             ## der ursprüngliche Frameaufbau ist nicht mehr da
    156             #q{} . $url . q{};
    157             } elsif ($url eq 'START') {
    158 0           $url;
    159             } else {
    160 0           "$url";
    161             }
    162             }
    163              
    164             sub check {
    165 0     0 1   my $self = shift;
    166 0           my(%args) = @_;
    167              
    168 0           my %fail_urls;
    169 0           foreach my $url ($self->get_all_urls) {
    170 0           push @{ $self->Pending }, {Url => $url,
      0            
    171             Caller => "START"};
    172             }
    173              
    174 0 0         if (!$self->Ua) {
    175 0           $self->Ua(LWP::UserAgent->new);
    176 0           $self->Ua->timeout(10);
    177 0           $self->Ua->env_proxy;
    178             }
    179 0           while(@{ $self->Pending }) {
      0            
    180 0           my $o = shift @{ $self->Pending };
      0            
    181 0           my $new_url = $o->{Url};
    182 0           my $caller = $o->{Caller};
    183              
    184             # Check whether already checked
    185 0 0         if ($self->SeenError->{$new_url}) {
    186 0           $fail_urls{$caller}->{$new_url}++;
    187 0           next;
    188             }
    189 0 0         next if ($self->SeenOk->{$new_url});
    190              
    191 0 0         warn "Check $new_url...\n" if $VERBOSE;
    192 0 0         if ($self->_restricted($new_url)) {
    193 0 0         warn "$new_url is restricted\n" if $VERBOSE;
    194 0           next;
    195             }
    196 0 0         if ($self->_ignored($new_url)) {
    197 0 0         warn "$new_url is ignored\n" if $VERBOSE;
    198 0           next;
    199             }
    200 0           my $failure = $self->_check($new_url);
    201 0 0         if ($failure) {
    202 0           $fail_urls{$caller}->{$new_url}++;
    203 0           $self->SeenError->{$new_url} = $failure;
    204             } else {
    205 0           $self->SeenOk->{$new_url}++;
    206             }
    207             }
    208 0           %fail_urls;
    209             }
    210              
    211             sub _check {
    212 0     0     my($self, $url) = @_;
    213 0           $url = _canonize_url($url);
    214              
    215 0 0         if ($self->_nofollow($url)) {
    216 0           my $res = $self->Ua->request(HTTP::Request->new(HEAD => $url));
    217 0 0         if ($res->is_error) {
    218 0 0         warn "$url returned @{[ $res->code ]}\n" if $VERBOSE;
      0            
    219 0           return { Code => $res->code,
    220             Error => $res->message };
    221             }
    222 0 0         warn "Do not follow $url\n" if $VERBOSE;
    223 0           return;
    224             }
    225              
    226 0           my $p = HTML::LinkExtor->new;
    227 0     0     my $res = $self->Ua->request(HTTP::Request->new(GET => $url),
    228 0           sub {$p->parse($_[0])});
    229 0 0         if ($res->content_type ne 'text/html') {
    230 0 0         warn "$url is not text/html\n" if $VERBOSE;
    231 0           return;
    232             }
    233 0 0         if ($res->is_error) {
    234 0 0         warn "$url returned @{[ $res->code ]}\n" if $VERBOSE;
      0            
    235 0           return { Code => $res->code,
    236             Error => $res->message };
    237             }
    238              
    239 0           my $base = $res->base;
    240              
    241 0           my %links;
    242 0           foreach my $e ($p->links) {
    243 0           for(my $i=2; $i<=$#$e; $i+=2) {
    244 0 0         next if $e->[$i] =~ /^javascript:/;
    245 0           my $checkurl = _canonize_url(URI->new_abs($e->[$i], $base)->as_string);
    246 0           $links{$checkurl}++;
    247             }
    248             }
    249 0           push @{ $self->Pending}, map { +{Url => $_, Caller => $url} }
      0            
      0            
    250             sort keys %links;
    251 0           undef;
    252             }
    253              
    254             sub _canonize_url {
    255 0     0     my $url = shift;
    256 0           $url =~ s/\#.*//; # XXX better way?
    257 0           $url;
    258             }
    259              
    260             sub _restricted {
    261 0     0     my($self, $url) = @_;
    262 0 0         return 0 if !$self->Restrict;
    263 0           foreach my $restr (@{ $self->Restrict }) {
      0            
    264 0 0         return 0 if $url =~ /$restr/;
    265             }
    266 0           1;
    267             }
    268              
    269             sub _ignored {
    270 0     0     my($self, $url) = @_;
    271 0 0         return 0 if !$self->Ignore;
    272 0           foreach my $ignore (@{ $self->Ignore }) {
      0            
    273 0 0         return 1 if $url =~ /$ignore/;
    274             }
    275 0           0;
    276             }
    277              
    278             sub _nofollow {
    279 0     0     my($self, $url) = @_;
    280 0 0         return 0 if !$self->Follow;
    281 0           foreach my $restr (@{ $self->Follow }) {
      0            
    282 0 0         return 0 if $url =~ /$restr/;
    283             }
    284 0           1;
    285             }
    286              
    287             1;
    288              
    289             __END__