forked from fastai/fastai
-
Notifications
You must be signed in to change notification settings - Fork 0
/
fastai-checklink
executable file
·3318 lines (2829 loc) · 106 KB
/
fastai-checklink
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#!/usr/bin/perl -wT
#
# W3C Link Checker
# by Hugo Haas <hugo@w3.org>
# (c) 1999-2011 World Wide Web Consortium
# based on Renaud Bruyeron's checklink.pl
#
# This program is licensed under the W3C(r) Software License:
# http://www.w3.org/Consortium/Legal/copyright-software
#
# The documentation is at:
# http://validator.w3.org/docs/checklink.html
#
# See the Mercurial interface at:
# http://dvcs.w3.org/hg/link-checker/
#
# An online version is available at:
# http://validator.w3.org/checklink
#
# Comments and suggestions should be sent to the www-validator mailing list:
# www-validator@w3.org (with 'checklink' in the subject)
# http://lists.w3.org/Archives/Public/www-validator/ (archives)
use strict;
use 5.008;
# debug
# use Devel::Confess;
# Get rid of potentially unsafe and unneeded environment variables.
delete(@ENV{qw(IFS CDPATH ENV BASH_ENV)});
$ENV{PATH} = undef;
# ...but we want PERL5?LIB honored even in taint mode, see perlsec, perl5lib,
# http://www.mail-archive.com/cpan-testers-discuss%40perl.org/msg01064.html
use Config qw(%Config);
use lib map { /(.*)/ }
defined($ENV{PERL5LIB}) ? split(/$Config{path_sep}/, $ENV{PERL5LIB}) :
defined($ENV{PERLLIB}) ? split(/$Config{path_sep}/, $ENV{PERLLIB}) :
();
# -----------------------------------------------------------------------------
package W3C::UserAgent;
use LWP::RobotUA 1.19 qw();
use LWP::UserAgent qw();
use Net::HTTP::Methods 5.833 qw(); # >= 5.833 for 4kB cookies (#6678)
# if 0, ignore robots exclusion (useful for testing)
use constant USE_ROBOT_UA => 1;
if (USE_ROBOT_UA) {
@W3C::UserAgent::ISA = qw(LWP::RobotUA);
}
else {
@W3C::UserAgent::ISA = qw(LWP::UserAgent);
}
sub new
{
my $proto = shift;
my $class = ref($proto) || $proto;
my ($name, $from, $rules) = @_;
# For security/privacy reasons, if $from was not given, do not send it.
# Cheat by defining something for the constructor, and resetting it later.
my $from_ok = $from;
$from ||= 'www-validator@w3.org';
my $self;
if (USE_ROBOT_UA) {
$self = $class->SUPER::new($name, $from, $rules);
}
else {
my %cnf;
@cnf{qw(agent from)} = ($name, $from);
$self = LWP::UserAgent->new(%cnf);
$self = bless $self, $class;
}
$self->from(undef) unless $from_ok;
$self->env_proxy();
$self->allow_private_ips(1);
$self->protocols_forbidden([qw(mailto javascript)]);
return $self;
}
sub allow_private_ips
{
my $self = shift;
if (@_) {
$self->{Checklink_allow_private_ips} = shift;
if (!$self->{Checklink_allow_private_ips}) {
# Pull in dependencies
require Net::IP;
require Socket;
require Net::hostent;
}
}
return $self->{Checklink_allow_private_ips};
}
sub redirect_progress_callback
{
my $self = shift;
$self->{Checklink_redirect_callback} = shift if @_;
return $self->{Checklink_redirect_callback};
}
sub simple_request
{
my $self = shift;
my $response = $self->ip_disallowed($_[0]->uri());
# RFC 2616, section 15.1.3
$_[0]->remove_header("Referer")
if ($_[0]->referer() &&
(!$_[0]->uri()->secure() && URI->new($_[0]->referer())->secure()));
$response ||= do {
local $SIG{__WARN__} =
sub { # Suppress some warnings, rt.cpan.org #18902
#warn($_[0]) if ($_[0] && $_[0] !~ /^RobotRules/);
};
# @@@ Why not just $self->SUPER::simple_request?
$self->W3C::UserAgent::SUPER::simple_request(@_);
};
if (!defined($self->{FirstResponse})) {
$self->{FirstResponse} = $response->code();
$self->{FirstMessage} = $response->message() || '(no message)';
}
return $response;
}
sub redirect_ok
{
my ($self, $request, $response) = @_;
if (my $callback = $self->redirect_progress_callback()) {
# @@@ TODO: when an LWP internal robots.txt request gets redirected,
# this will a bit confusingly fire for it too. Would need a robust
# way to determine whether the request is such a LWP "internal
# robots.txt" one.
&$callback($request->method(), $request->uri());
}
return 0 unless $self->SUPER::redirect_ok($request, $response);
if (my $res = $self->ip_disallowed($request->uri())) {
$response->previous($response->clone());
$response->request($request);
$response->code($res->code());
$response->message($res->message());
return 0;
}
return 1;
}
#
# Checks whether we're allowed to retrieve the document based on its IP
# address. Takes an URI object and returns a HTTP::Response containing the
# appropriate status and error message if the IP was disallowed, 0
# otherwise. URIs without hostname or IP address are always allowed,
# including schemes where those make no sense (eg. data:, often javascript:).
#
sub ip_disallowed
{
my ($self, $uri) = @_;
return 0 if $self->allow_private_ips(); # Short-circuit
my $hostname = undef;
eval { $hostname = $uri->host() }; # Not all URIs implement host()...
return 0 unless $hostname;
my $addr = my $iptype = my $resp = undef;
if (my $host = Net::hostent::gethostbyname($hostname)) {
$addr = Socket::inet_ntoa($host->addr()) if $host->addr();
if ($addr && (my $ip = Net::IP->new($addr))) {
$iptype = $ip->iptype();
}
}
if ($iptype && $iptype ne 'PUBLIC') {
$resp = HTTP::Response->new(403,
'Checking non-public IP address disallowed by link checker configuration'
);
$resp->header('Client-Warning', 'Internal response');
}
return $resp;
}
# -----------------------------------------------------------------------------
package W3C::LinkChecker;
use vars qw($AGENT $PACKAGE $PROGRAM $VERSION $REVISION
$DocType $Head $Accept $ContentTypes %Cfg $CssUrl);
use CSS::DOM 0.09 qw(); # >= 0.09 for many bugfixes
use CSS::DOM::Constants qw(:rule);
use CSS::DOM::Style qw();
use CSS::DOM::Util qw();
use Encode qw();
use HTML::Entities qw();
use HTML::Parser 3.40 qw(); # >= 3.40 for utf8_mode()
use HTTP::Headers::Util qw();
use HTTP::Message 5.827 qw(); # >= 5.827 for content_charset()
use HTTP::Request 5.814 qw(); # >= 5.814 for accept_decodable()
use HTTP::Response 1.50 qw(); # >= 1.50 for decoded_content()
use Time::HiRes qw();
use URI 1.53 qw(); # >= 1.53 for secure()
use URI::Escape qw();
use URI::Heuristic qw();
# fastai needs: don't report failed links we have no control over
my %skip_codes = map { $_ => 1 } qw(405);
# @@@ Needs also W3C::UserAgent but can't use() it here.
use constant RC_ROBOTS_TXT => -1;
use constant RC_DNS_ERROR => -2;
use constant RC_IP_DISALLOWED => -3;
use constant RC_PROTOCOL_DISALLOWED => -4;
use constant LINE_UNKNOWN => -1;
use constant MP2 =>
(exists($ENV{MOD_PERL_API_VERSION}) && $ENV{MOD_PERL_API_VERSION} >= 2);
# Tag=>attribute mapping of things we treat as links.
# Note: meta/@http-equiv gets special treatment, see start() for details.
use constant LINK_ATTRS => {
a => ['href'],
# base/@href intentionally not checked
# http://www.w3.org/mid/200802091439.27764.ville.skytta%40iki.fi
area => ['href'],
audio => ['src'],
blockquote => ['cite'],
body => ['background'],
command => ['icon'],
# button/@formaction not checked (side effects)
del => ['cite'],
# @pluginspage, @pluginurl, @href: pre-HTML5 proprietary
embed => ['href', 'pluginspage', 'pluginurl', 'src'],
# form/@action not checked (side effects)
frame => ['longdesc', 'src'],
html => ['manifest'],
iframe => ['longdesc', 'src'],
img => ['longdesc', 'src'],
# input/@action, input/@formaction not checked (side effects)
input => ['src'],
ins => ['cite'],
link => ['href'],
object => ['data'],
q => ['cite'],
script => ['src'],
source => ['src'],
track => ['src'],
video => ['src', 'poster'],
};
# Tag=>[separator, attributes] mapping of things we treat as lists of links.
use constant LINK_LIST_ATTRS => {
a => [qr/\s+/, ['ping']],
applet => [qr/[\s,]+/, ['archive']],
area => [qr/\s+/, ['ping']],
head => [qr/\s+/, ['profile']],
object => [qr/\s+/, ['archive']],
};
# TBD/TODO:
# - applet/@code?
# - bgsound/@src?
# - object/@classid?
# - isindex/@action?
# - layer/@background,@src?
# - ilayer/@background?
# - table,tr,td,th/@background?
# - xmp/@href?
@W3C::LinkChecker::ISA = qw(HTML::Parser);
BEGIN {
# Version info
$PACKAGE = 'W3C Link Checker';
$PROGRAM = 'W3C-checklink';
$VERSION = '4.81';
$REVISION = sprintf('version %s (c) 1999-2011 W3C', $VERSION);
$AGENT = sprintf(
'%s/%s %s',
$PROGRAM, $VERSION,
( W3C::UserAgent::USE_ROBOT_UA ? LWP::RobotUA->_agent() :
LWP::UserAgent->_agent()
)
);
# Pull in mod_perl modules if applicable.
eval {
local $SIG{__DIE__} = undef;
require Apache2::RequestUtil;
} if MP2();
my @content_types = qw(
text/html
application/xhtml+xml;q=0.9
application/vnd.wap.xhtml+xml;q=0.6
);
$Accept = join(', ', @content_types, '*/*;q=0.5');
push(@content_types, 'text/css', 'text/html-sandboxed');
my $re = join('|', map { s/;.*//; quotemeta } @content_types);
$ContentTypes = qr{\b(?:$re)\b}io;
# Regexp for matching URL values in CSS.
$CssUrl = qr/(?:\s|^)url\(\s*(['"]?)(.*?)\1\s*\)(?=\s|$)/;
#
# Read configuration. If the W3C_CHECKLINK_CFG environment variable has
# been set or the default contains a non-empty file, read it. Otherwise,
# skip silently.
#
my $defaultconfig = '/etc/w3c/checklink.conf';
if ($ENV{W3C_CHECKLINK_CFG} || -s $defaultconfig) {
require Config::General;
Config::General->require_version(2.06); # Need 2.06 for -SplitPolicy
my $conffile = $ENV{W3C_CHECKLINK_CFG} || $defaultconfig;
eval {
my %config_opts = (
-ConfigFile => $conffile,
-SplitPolicy => 'equalsign',
-AllowMultiOptions => 'no',
);
%Cfg = Config::General->new(%config_opts)->getall();
};
if ($@) {
die <<"EOF";
Failed to read configuration from '$conffile':
$@
EOF
}
}
$Cfg{Markup_Validator_URI} ||= 'http://validator.w3.org/check?uri=%s';
$Cfg{CSS_Validator_URI} ||=
'http://jigsaw.w3.org/css-validator/validator?uri=%s';
$Cfg{Doc_URI} ||= 'http://validator.w3.org/docs/checklink.html';
# Untaint config params that are used as the format argument to (s)printf(),
# Perl 5.10 does not want to see that in taint mode.
($Cfg{Markup_Validator_URI}) = ($Cfg{Markup_Validator_URI} =~ /^(.*)$/);
($Cfg{CSS_Validator_URI}) = ($Cfg{CSS_Validator_URI} =~ /^(.*)$/);
$DocType =
'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">';
my $css_url = URI->new_abs('linkchecker.css', $Cfg{Doc_URI});
my $js_url = URI->new_abs('linkchecker.js', $Cfg{Doc_URI});
$Head =
sprintf(<<'EOF', HTML::Entities::encode($AGENT), $css_url, $js_url);
<meta http-equiv="Content-Script-Type" content="text/javascript" />
<meta name="generator" content="%s" />
<link rel="stylesheet" type="text/css" href="%s" />
<script type="text/javascript" src="%s"></script>
EOF
# Trusted environment variables that need laundering in taint mode.
for (qw(NNTPSERVER NEWSHOST)) {
($ENV{$_}) = ($ENV{$_} =~ /^(.*)$/) if $ENV{$_};
}
# Use passive FTP by default, see Net::FTP(3).
$ENV{FTP_PASSIVE} = 1 unless exists($ENV{FTP_PASSIVE});
}
# Autoflush
$| = 1;
# Different options specified by the user
my $cmdline = !($ENV{GATEWAY_INTERFACE} && $ENV{GATEWAY_INTERFACE} =~ /^CGI/);
my %Opts = (
Command_Line => $cmdline,
Quiet => 0,
Summary_Only => 0,
Verbose => 0,
Progress => 0,
HTML => 0,
Timeout => 30,
Redirects => 1,
Dir_Redirects => 1,
Accept_Language => $cmdline ? undef : $ENV{HTTP_ACCEPT_LANGUAGE},
Cookies => undef,
No_Referer => 0,
Hide_Same_Realm => 0,
Depth => 0, # < 0 means unlimited recursion.
Sleep_Time => 1,
Connection_Cache_Size => 2,
Max_Documents => 150, # For the online version.
User => undef,
Password => undef,
Base_Locations => [],
Exclude => undef,
Exclude_Docs => undef,
Suppress_Redirect => [],
Suppress_Redirect_Prefix => [],
Suppress_Redirect_Regexp => [],
Suppress_Temp_Redirects => 1,
Suppress_Broken => [],
Suppress_Fragment => [],
Masquerade => 0,
Masquerade_From => '',
Masquerade_To => '',
Trusted => $Cfg{Trusted},
Allow_Private_IPs => defined($Cfg{Allow_Private_IPs}) ?
$Cfg{Allow_Private_IPs} :
$cmdline,
);
undef $cmdline;
# Global variables
# What URI's did we process? (used for recursive mode)
my %processed;
# Result of the HTTP query
my %results;
# List of redirects
my %redirects;
# Count of the number of documents checked
my $doc_count = 0;
# Time stamp
my $timestamp = &get_timestamp();
# Per-document header; undefined if already printed. See print_doc_header().
my $doc_header;
&parse_arguments() if $Opts{Command_Line};
my $ua = W3C::UserAgent->new($AGENT); # @@@ TODO: admin address
$ua->conn_cache({total_capacity => $Opts{Connection_Cache_Size}});
if ($ua->can('delay')) {
# fastai: local filesystem - no need to throttle
if ($Opts{Masquerade_From} && $Opts{Masquerade_From} =~ /^file/) {
#print "Local fs detected - Hammering at full speed";
$ua->delay(0);
}
else {
$ua->delay($Opts{Sleep_Time} / 60);
}
}
$ua->timeout($Opts{Timeout});
# Set up cookie stash if requested
if (defined($Opts{Cookies})) {
require HTTP::Cookies;
my $cookie_file = $Opts{Cookies};
if ($cookie_file eq 'tmp') {
$cookie_file = undef;
}
elsif ($cookie_file =~ /^(.*)$/) {
$cookie_file = $1; # untaint
}
$ua->cookie_jar(HTTP::Cookies->new(file => $cookie_file, autosave => 1));
}
eval { $ua->allow_private_ips($Opts{Allow_Private_IPs}); };
if ($@) {
die <<"EOF";
Allow_Private_IPs is false; this feature requires the Net::IP, Socket, and
Net::hostent modules:
$@
EOF
}
# Add configured forbidden protocols
if ($Cfg{Forbidden_Protocols}) {
my $forbidden = $ua->protocols_forbidden();
push(@$forbidden, split(/[,\s]+/, lc($Cfg{Forbidden_Protocols})));
$ua->protocols_forbidden($forbidden);
}
if ($Opts{Command_Line}) {
require Text::Wrap;
Text::Wrap->import('wrap');
require URI::file;
&usage(1) unless scalar(@ARGV);
$Opts{_Self_URI} = 'http://validator.w3.org/checklink'; # For HTML output
&ask_password() if ($Opts{User} && !$Opts{Password});
if (!$Opts{Summary_Only}) {
printf("%s %s\n", $PACKAGE, $REVISION) unless $Opts{HTML};
}
else {
$Opts{Verbose} = 0;
$Opts{Progress} = 0;
}
# Populate data for print_form()
my %params = (
summary => $Opts{Summary_Only},
hide_redirects => !$Opts{Redirects},
hide_type => $Opts{Dir_Redirects} ? 'dir' : 'all',
no_accept_language => !(
defined($Opts{Accept_Language}) && $Opts{Accept_Language} eq 'auto'
),
no_referer => $Opts{No_Referer},
recursive => ($Opts{Depth} != 0),
depth => $Opts{Depth},
);
my $check_num = 1;
my @bases = @{$Opts{Base_Locations}};
for my $uri (@ARGV) {
# Reset base locations so that previous URI's given on the command line
# won't affect the recursion scope for this URI (see check_uri())
@{$Opts{Base_Locations}} = @bases;
# Transform the parameter into a URI
$uri = &urize($uri);
$params{uri} = $uri;
&check_uri(\%params, $uri, $check_num, $Opts{Depth}, undef, undef, 1);
$check_num++;
}
undef $check_num;
if ($Opts{HTML}) {
&html_footer();
}
elsif ($doc_count > 0 && !$Opts{Summary_Only}) {
printf("\n%s\n", &global_stats());
}
}
else {
require CGI;
require CGI::Carp;
CGI::Carp->import(qw(fatalsToBrowser));
require CGI::Cookie;
# file: URIs are not allowed in CGI mode
my $forbidden = $ua->protocols_forbidden();
push(@$forbidden, 'file');
$ua->protocols_forbidden($forbidden);
my $query = CGI->new();
for my $param ($query->param()) {
my @values = map { Encode::decode_utf8($_) } $query->param($param);
$query->param($param, @values);
}
# Set a few parameters in CGI mode
$Opts{Verbose} = 0;
$Opts{Progress} = 0;
$Opts{HTML} = 1;
$Opts{_Self_URI} = $query->url(-relative => 1);
# Backwards compatibility
my $uri = undef;
if ($uri = $query->param('url')) {
$query->param('uri', $uri) unless $query->param('uri');
$query->delete('url');
}
$uri = $query->param('uri');
if (!$uri) {
&html_header('', undef); # Set cookie only from results page.
my %cookies = CGI::Cookie->fetch();
&print_form(scalar($query->Vars()), $cookies{$PROGRAM}, 1);
&html_footer();
exit;
}
# Backwards compatibility
if ($query->param('hide_dir_redirects')) {
$query->param('hide_redirects', 'on');
$query->param('hide_type', 'dir');
$query->delete('hide_dir_redirects');
}
$Opts{Summary_Only} = 1 if $query->param('summary');
if ($query->param('hide_redirects')) {
$Opts{Dir_Redirects} = 0;
if (my $type = $query->param('hide_type')) {
$Opts{Redirects} = 0 if ($type ne 'dir');
}
else {
$Opts{Redirects} = 0;
}
}
$Opts{Accept_Language} = undef if $query->param('no_accept_language');
$Opts{No_Referer} = $query->param('no_referer');
$Opts{Depth} = -1 if ($query->param('recursive') && $Opts{Depth} == 0);
if (my $depth = $query->param('depth')) {
# @@@ Ignore invalid depth silently for now.
$Opts{Depth} = $1 if ($depth =~ /(-?\d+)/);
}
# Save, clear or leave cookie as is.
my $cookie = undef;
if (my $action = $query->param('cookie')) {
if ($action eq 'clear') {
# Clear the cookie.
$cookie = CGI::Cookie->new(-name => $PROGRAM);
$cookie->value({clear => 1});
$cookie->expires('-1M');
}
elsif ($action eq 'set') {
# Set the options.
$cookie = CGI::Cookie->new(-name => $PROGRAM);
my %options = $query->Vars();
delete($options{$_})
for qw(url uri check cookie); # Non-persistent.
$cookie->value(\%options);
}
}
if (!$cookie) {
my %cookies = CGI::Cookie->fetch();
$cookie = $cookies{$PROGRAM};
}
# Always refresh cookie expiration time.
$cookie->expires('+1M') if ($cookie && !$cookie->expires());
# All Apache configurations don't set HTTP_AUTHORIZATION for CGI scripts.
# If we're under mod_perl, there is a way around it...
eval {
local $SIG{__DIE__} = undef;
my $auth =
Apache2::RequestUtil->request()->headers_in()->{Authorization};
$ENV{HTTP_AUTHORIZATION} = $auth if $auth;
} if (MP2() && !$ENV{HTTP_AUTHORIZATION});
$uri =~ s/^\s+//g;
if ($uri =~ /:/) {
$uri = URI->new($uri);
}
else {
if ($uri =~ m|^//|) {
$uri = URI->new("http:$uri");
}
else {
local $ENV{URL_GUESS_PATTERN} = '';
my $guess = URI::Heuristic::uf_uri($uri);
if ($guess->scheme() && $ua->is_protocol_supported($guess)) {
$uri = $guess;
}
else {
$uri = URI->new("http://$uri");
}
}
}
$uri = $uri->canonical();
$query->param("uri", $uri);
&check_uri(scalar($query->Vars()), $uri, 1, $Opts{Depth}, $cookie);
undef $query; # Not needed any more.
&html_footer();
}
###############################################################################
################################
# Command line and usage stuff #
################################
sub parse_arguments ()
{
require Encode::Locale;
Encode::Locale::decode_argv();
require Getopt::Long;
Getopt::Long->require_version(2.17);
Getopt::Long->import('GetOptions');
Getopt::Long::Configure('bundling', 'no_ignore_case');
my $masq = '';
my @locs = ();
GetOptions(
'help|h|?' => sub { usage(0) },
'q|quiet' => sub {
$Opts{Quiet} = 1;
$Opts{Summary_Only} = 1;
},
's|summary' => \$Opts{Summary_Only},
'b|broken' => sub {
$Opts{Redirects} = 0;
$Opts{Dir_Redirects} = 0;
},
'e|dir-redirects' => sub { $Opts{Dir_Redirects} = 0; },
'v|verbose' => \$Opts{Verbose},
'i|indicator' => \$Opts{Progress},
'H|html' => \$Opts{HTML},
'r|recursive' => sub {
$Opts{Depth} = -1
if $Opts{Depth} == 0;
},
'l|location=s' => \@locs,
'X|exclude=s' => \$Opts{Exclude},
'exclude-docs=s@' => \@{$Opts{Exclude_Docs}},
'suppress-redirect=s@' => \@{$Opts{Suppress_Redirect}},
'suppress-redirect-prefix=s@' => \@{$Opts{Suppress_Redirect_Prefix}},
'suppress-temp-redirects' => \$Opts{Suppress_Temp_Redirects},
'suppress-broken=s@' => \@{$Opts{Suppress_Broken}},
'suppress-fragment=s@' => \@{$Opts{Suppress_Fragment}},
'u|user=s' => \$Opts{User},
'p|password=s' => \$Opts{Password},
't|timeout=i' => \$Opts{Timeout},
'C|connection-cache=i' => \$Opts{Connection_Cache_Size},
'S|sleep=i' => \$Opts{Sleep_Time},
'L|languages=s' => \$Opts{Accept_Language},
'c|cookies=s' => \$Opts{Cookies},
'R|no-referer' => \$Opts{No_Referer},
'D|depth=i' => sub {
$Opts{Depth} = $_[1]
unless $_[1] == 0;
},
'd|domain=s' => \$Opts{Trusted},
'masquerade=s' => \$masq,
'hide-same-realm' => \$Opts{Hide_Same_Realm},
'V|version' => \&version,
) ||
usage(1);
if ($masq) {
$Opts{Masquerade} = 1;
my @masq = split(/\s+/, $masq);
if (scalar(@masq) != 2 ||
!defined($masq[0]) ||
$masq[0] !~ /\S/ ||
!defined($masq[1]) ||
$masq[1] !~ /\S/)
{
usage(1,
"Error: --masquerade takes two whitespace separated URIs.");
}
else {
require URI::file;
$Opts{Masquerade_From} = $masq[0];
my $u = URI->new($masq[1]);
$Opts{Masquerade_To} =
$u->scheme() ? $u : URI::file->new_abs($masq[1]);
}
}
if ($Opts{Accept_Language} && $Opts{Accept_Language} eq 'auto') {
$Opts{Accept_Language} = &guess_language();
}
if (($Opts{Sleep_Time} || 0) < 1) {
warn(
"*** Warning: minimum allowed sleep time is 1 second, resetting.\n"
);
$Opts{Sleep_Time} = 1;
}
push(@{$Opts{Base_Locations}}, map { URI->new($_)->canonical() } @locs);
$Opts{Depth} = -1 if ($Opts{Depth} == 0 && @locs);
# Precompile/error-check regular expressions.
if (defined($Opts{Exclude})) {
eval { $Opts{Exclude} = qr/$Opts{Exclude}/o; };
&usage(1, "Error in exclude regexp: $@") if $@;
}
for my $i (0 .. $#{$Opts{Exclude_Docs}}) {
eval { $Opts{Exclude_Docs}->[$i] = qr/$Opts{Exclude_Docs}->[$i]/; };
&usage(1, "Error in exclude-docs regexp: $@") if $@;
}
if (defined($Opts{Trusted})) {
eval { $Opts{Trusted} = qr/$Opts{Trusted}/io; };
&usage(1, "Error in trusted domains regexp: $@") if $@;
}
# Sanity-check error-suppression arguments
for my $i (0 .. $#{$Opts{Suppress_Redirect}}) {
${$Opts{Suppress_Redirect}}[$i] =~ s/ /->/;
my $sr_arg = ${$Opts{Suppress_Redirect}}[$i];
if ($sr_arg !~ /.->./) {
&usage(1,
"Bad suppress-redirect argument, should contain \"->\": $sr_arg"
);
}
}
for my $i (0 .. $#{$Opts{Suppress_Redirect_Prefix}}) {
my $srp_arg = ${$Opts{Suppress_Redirect_Prefix}}[$i];
$srp_arg =~ s/ /->/;
if ($srp_arg !~ /^(.*)->(.*)$/) {
&usage(1,
"Bad suppress-redirect-prefix argument, should contain \"->\": $srp_arg"
);
}
# Turn prefixes into a regexp.
${$Opts{Suppress_Redirect_Prefix}}[$i] = qr/^\Q$1\E(.*)->\Q$2\E\1$/ism;
}
for my $i (0 .. $#{$Opts{Suppress_Broken}}) {
${$Opts{Suppress_Broken}}[$i] =~ s/ /:/;
my $sb_arg = ${$Opts{Suppress_Broken}}[$i];
if ($sb_arg !~ /^(-1|[0-9]+):./) {
&usage(1,
"Bad suppress-broken argument, should be prefixed by a numeric response code: $sb_arg"
);
}
}
for my $sf_arg (@{$Opts{Suppress_Fragment}}) {
if ($sf_arg !~ /.#./) {
&usage(1,
"Bad suppress-fragment argument, should contain \"#\": $sf_arg"
);
}
}
return;
}
sub version ()
{
print "$PACKAGE $REVISION\n";
exit 0;
}
sub usage ()
{
my ($exitval, $msg) = @_;
$exitval = 0 unless defined($exitval);
$msg ||= '';
$msg =~ s/[\r\n]*$/\n\n/ if $msg;
die($msg) unless $Opts{Command_Line};
my $trust = defined($Cfg{Trusted}) ? $Cfg{Trusted} : 'same host only';
select(STDERR) if $exitval;
print "$msg$PACKAGE $REVISION
Usage: checklink <options> <uris>
Options:
-s, --summary Result summary only.
-b, --broken Show only the broken links, not the redirects.
-e, --directory Hide directory redirects, for example
http://www.w3.org/TR -> http://www.w3.org/TR/
-r, --recursive Check the documents linked from the first one.
-D, --depth N Check the documents linked from the first one to
depth N (implies --recursive).
-l, --location URI Scope of the documents checked in recursive mode
(implies --recursive). Can be specified multiple
times. If not specified, the default eg. for
http://www.w3.org/TR/html4/Overview.html
would be http://www.w3.org/TR/html4/
-X, --exclude REGEXP Do not check links whose full, canonical URIs
match REGEXP; also limits recursion the same way
as --exclude-docs with the same regexp would.
--exclude-docs REGEXP In recursive mode, do not check links in documents
whose full, canonical URIs match REGEXP. This
option may be specified multiple times.
--suppress-redirect URI->URI Do not report a redirect from the first to the
second URI. This option may be specified multiple
times.
--suppress-redirect-prefix URI->URI Do not report a redirect from a child of
the first URI to the same child of the second URI.
This option may be specified multiple times.
--suppress-temp-redirects Suppress warnings about temporary redirects.
--suppress-broken CODE:URI Do not report a broken link with the given CODE.
CODE is HTTP response, or -1 for robots exclusion.
This option may be specified multiple times.
--suppress-fragment URI Do not report the given broken fragment URI.
A fragment URI contains \"#\". This option may be
specified multiple times.
-L, --languages LANGS Accept-Language header to send. The special value
'auto' causes autodetection from the environment.
-c, --cookies FILE Use cookies, load/save them in FILE. The special
value 'tmp' causes non-persistent use of cookies.
-R, --no-referer Do not send the Referer HTTP header.
-q, --quiet No output if no errors are found (implies -s).
-v, --verbose Verbose mode.
-i, --indicator Show percentage of lines processed while parsing.
-u, --user USERNAME Specify a username for authentication.
-p, --password PASSWORD Specify a password.
--hide-same-realm Hide 401's that are in the same realm as the
document checked.
-S, --sleep SECS Sleep SECS seconds between requests to each server
(default and minimum: 1 second).
-t, --timeout SECS Timeout for requests in seconds (default: 30).
-d, --domain DOMAIN Regular expression describing the domain to which
authentication information will be sent
(default: $trust).
--masquerade \"BASE1 BASE2\" Masquerade base URI BASE1 as BASE2. See the
manual page for more information.
-H, --html HTML output.
-?, -h, --help Show this message and exit.
-V, --version Output version information and exit.
See \"perldoc LWP\" for information about proxy server support,
\"perldoc Net::FTP\" for information about various environment variables
affecting FTP connections and \"perldoc Net::NNTP\" for setting a default
NNTP server for news: URIs.
The W3C_CHECKLINK_CFG environment variable can be used to set the
configuration file to use. See details in the full manual page, it can
be displayed with: perldoc checklink
More documentation at: $Cfg{Doc_URI}
Please send bug reports and comments to the www-validator mailing list:
www-validator\@w3.org (with 'checklink' in the subject)
Archives are at: http://lists.w3.org/Archives/Public/www-validator/
";
exit $exitval;
}
sub ask_password ()
{
eval {
local $SIG{__DIE__} = undef;
require Term::ReadKey;
Term::ReadKey->require_version(2.00);
Term::ReadKey->import(qw(ReadMode));
};
if ($@) {
warn('Warning: Term::ReadKey 2.00 or newer not available, ' .
"password input disabled.\n");
return;
}
printf(STDERR 'Enter the password for user %s: ', $Opts{User});
ReadMode('noecho', *STDIN);
chomp($Opts{Password} = <STDIN>);
ReadMode('restore', *STDIN);
print(STDERR "ok.\n");
return;
}
###############################################################################
###########################################################################
# Guess an Accept-Language header based on the $LANG environment variable #
###########################################################################
sub guess_language ()
{
my $lang = $ENV{LANG} or return;
$lang =~ s/[\.@].*$//; # en_US.UTF-8, fi_FI@euro...
return 'en' if ($lang eq 'C' || $lang eq 'POSIX');
my $res = undef;
eval {
require Locale::Language;
if (my $tmp = Locale::Language::language2code($lang)) {
$lang = $tmp;
}
if (my ($l, $c) = (lc($lang) =~ /^([a-z]+)(?:[-_]([a-z]+))?/)) {
if (Locale::Language::code2language($l)) {
$res = $l;
if ($c) {
require Locale::Country;
$res .= "-$c" if Locale::Country::code2country($c);
}
}
}
};
return $res;
}
############################
# Transform foo into a URI #
############################
sub urize ($)