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:
|
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:
|
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:
|
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__ |