emacs/nxhtml/nxhtml/html-chklnk/PerlLib/HTML/LinkWalker.pm

   1 ### File:       LinkWalker.pm\r
   2 ### Author:     Lennart Borgman\r
   3 ###     All rights reserved\r
   4 \r
   5 ##########################################################\r
   6 ### UserAgent module\r
   7 ##########################################################\r
   8 package LWP::WalkerUA;\r
   9 require LWP::UserAgent;\r
  10 @ISA = qw(LWP::UserAgent);\r
  11 \r
  12 ### Mirror to another file (why???)\r
  13 sub mirror\r
  14 {\r
  15     my($self, $url, $file, $mirr_tmp) = @_;\r
  16     die "no mirr_tmp" unless defined $mirr_tmp;\r
  17 \r
  18     LWP::Debug::trace('()');\r
  19     my $request = new HTTP::Request('GET', $url);\r
  20 \r
  21     if (-e $file) {\r
  22         my($mtime) = (stat($file))[9];\r
  23         if($mtime) {\r
  24             $request->header('If-Modified-Since' =>\r
  25                              HTTP::Date::time2str($mtime));\r
  26         }\r
  27     }\r
  28     my $tmpfile = "$file-$$";\r
  29 \r
  30     my $response = $self->request($request, $tmpfile);\r
  31     if ($response->is_success) {\r
  32 \r
  33         my $file_length = (stat($tmpfile))[7];\r
  34         my($content_length) = $response->header('Content-length');\r
  35 \r
  36         if (defined $content_length and $file_length < $content_length) {\r
  37             unlink($tmpfile);\r
  38             die "Transfer truncated: " .\r
  39                 "only $file_length out of $content_length bytes received\n";\r
  40         } elsif (defined $content_length and $file_length > $content_length) {\r
  41             unlink($tmpfile);\r
  42             die "Content-length mismatch: " .\r
  43                 "expected $content_length bytes, got $file_length\n";\r
  44         } else {\r
  45             # OK\r
  46             if (-e $mirr_tmp) {\r
  47                 # Some dosish systems fail to rename if the target exists\r
  48                 chmod 0777, $mirr_tmp;\r
  49                 unlink $mirr_tmp;\r
  50             }\r
  51             rename($tmpfile, $mirr_tmp) or\r
  52                 die "Cannot rename '$tmpfile' to '$mirr_tmp': $!\n";\r
  53 \r
  54             if (my $lm = $response->last_modified) {\r
  55                 # make sure the file has the same last modification time\r
  56                 utime $lm, $lm, $mirr_tmp;\r
  57             }\r
  58         }\r
  59     } else {\r
  60         unlink($tmpfile);\r
  61     }\r
  62     return $response;\r
  63 }\r
  64 \r
  65 \r
  66 ##########################################################\r
  67 ### Parser module\r
  68 ##########################################################\r
  69 package HTML::WalkerParser;\r
  70 require HTML::ParserTagEnd;\r
  71 @ISA = qw(HTML::ParserTagEnd);\r
  72 use strict;\r
  73 use vars qw(%LINK_ELEMENT);\r
  74 \r
  75 # Elements that might contain links and the name of the link attribute\r
  76 %LINK_ELEMENT =\r
  77 (\r
  78  body   => 'background',\r
  79  base   => 'href',\r
  80  a      => 'href',\r
  81  img    => [qw(src lowsrc usemap)],   # 'lowsrc' is a Netscape invention\r
  82  form   => 'action',\r
  83  input  => 'src',\r
  84 'link'  => 'href',          # need quoting since link is a perl builtin\r
  85  frame  => 'src',\r
  86  applet => [qw(codebase code)],\r
  87  area   => 'href',\r
  88  iframe  => 'src',   # Netscape 2.0 extention\r
  89  embed  => 'src',   # used in Netscape 2.0 for Shockwave and things like that\r
  90 );\r
  91 \r
  92 my %LINKATTRIBS = (\r
  93         "href"                  => 1,\r
  94         "src"                   => 1,\r
  95         "action"                => 1,\r
  96         "background"    => 1,\r
  97         "usemap"                => 1,\r
  98         "code"                  => 1,\r
  99         "codebase"              => 1,\r
 100         "lowsrc"                => 1,\r
 101         );\r
 102 my %MAYBECONT = (\r
 103         a => 'href',\r
 104         area   => 'href',\r
 105         form   => 'action',\r
 106         frame  => 'src',\r
 107         iframe  => 'src',\r
 108         );\r
 109 \r
 110 sub maybecont($$) {\r
 111         my $tag = shift;\r
 112         my $att = shift;\r
 113         return unless exists $MAYBECONT{$tag};\r
 114         return ($MAYBECONT{$tag} eq $att);\r
 115 }\r
 116 \r
 117 sub new {\r
 118     my($class, $parsed_fh) = @_;\r
 119     my $self = $class->SUPER::new;\r
 120     $self->{parsed_fh} = $parsed_fh;\r
 121     $self;\r
 122 }\r
 123 \r
 124 \r
 125 \r
 126 \r
 127 \r
 128 \r
 129 \r
 130 ##########################################################\r
 131 ### Walker module\r
 132 ##########################################################\r
 133 package HTML::LinkWalker;\r
 134 use strict;\r
 135 \r
 136 use IO::File;\r
 137 use File::Copy qw();\r
 138 use File::Path qw();\r
 139 use PathSubs qw();\r
 140 use HTML::Entities;\r
 141 use FindBin qw();\r
 142 \r
 143 \r
 144 ##########################################################\r
 145 ### Globals\r
 146 ##########################################################\r
 147 my $ua;\r
 148 my $m_ua_personality = "LinkWalker/0.9";\r
 149 my %m_is_outside;\r
 150 my %m_is_container;\r
 151 my $m_bOnlyCont;\r
 152 my @m_sLinkRoots;\r
 153 my $m_subReport;\r
 154 my $m_subAction;\r
 155 my $m_subMirrorAction;\r
 156 \r
 157 \r
 158 #############################\r
 159 ### Collecting info\r
 160 #############################\r
 161 my %m_CheckedLinks;\r
 162 my %m_MissedLinks;\r
 163 \r
 164 sub tell_bad_link($$$$$) {\r
 165         my $what = shift;\r
 166         my $file = shift;\r
 167         my $lnum = shift;\r
 168         my $link = shift;\r
 169         my $line = shift;\r
 170         $file = "START" unless defined $file;\r
 171         $lnum = "(start)" unless defined $lnum;\r
 172         my $longMsg = "<<$what>>";\r
 173         my $shortMsg = $what;\r
 174         if (defined $link) {\r
 175                 my @lines = split("\\s+", $line);\r
 176                 my $disp_line = join("\n\t\t  ", @lines);\r
 177                 $longMsg .= ",\n\t\tlink=$link\n\t\t$disp_line";\r
 178         }\r
 179         my @msg = ($shortMsg, $longMsg);\r
 180         $m_CheckedLinks{$file}->{ERR}->{$lnum} = \@msg;\r
 181         &$m_subReport("\t* Error * " . $what . "\n");\r
 182 } # tell_bad_link\r
 183 \r
 184 \r
 185 #############################\r
 186 ### Helpers\r
 187 #############################\r
 188 \r
 189 sub get_contenttype($) {\r
 190         my $response = shift;\r
 191         my @rh = $response->header("Content-Type");\r
 192         for my $r (@rh) {\r
 193                 my $c = $r;\r
 194                 if ((my $iPos = index($r, ";")) > -1) {\r
 195                         $c = substr($r, 0, $iPos);\r
 196                 }\r
 197                 return $c;\r
 198         }\r
 199 }\r
 200 sub is_linked_contenttype($) {\r
 201         my $response = shift;\r
 202         return (get_contenttype($response) eq "text/html");\r
 203 }\r
 204 \r
 205 sub ending_is_container($) {\r
 206         my $link_addr = shift;\r
 207         $link_addr =~ s!#.*$!!;\r
 208         $link_addr =~ s!\?.*$!!;\r
 209         return (($link_addr =~ m!\.s?html?$!i) ? 1 : 0);\r
 210 }\r
 211 \r
 212 my $m_sMirrorRoot;\r
 213 my $m_bMirror = 1;\r
 214 \r
 215 sub mk_mirror_name($) {\r
 216         my $orig_name = shift;\r
 217         $orig_name =~ tr!\\!/!;\r
 218         my $mirr_name = $orig_name;\r
 219         my ($orig_host) = ($orig_name =~ m!(^https?://[^/]*)!i);\r
 220         if (defined $orig_host) {\r
 221                 my $host = $orig_host;\r
 222                 $host =~ tr!:!_!;\r
 223                 $host =~ tr!/!_!;\r
 224                 $mirr_name =~ s!^$orig_host!$host!;\r
 225                 if (substr($mirr_name, -1) eq "/") { $mirr_name .= "default.html"; }\r
 226         } else {\r
 227                 die "Can't find host in $orig_name\n";\r
 228         }\r
 229         my $mirr_full = sMirrorRoot() . $mirr_name;\r
 230         if (!$m_bMirror) {\r
 231                 my $sExt = $mirr_name; $sExt =~ s!.*\.([^\.]*$)!$1!;\r
 232                 $mirr_full = sMirrorRoot() . "temp.$sExt";\r
 233         }\r
 234         my $mirr_fold = $mirr_full;\r
 235         $mirr_fold =~ s![^/]*$!!;\r
 236         File::Path::mkpath($mirr_fold, 0, 0777);\r
 237         return $mirr_full;\r
 238 }\r
 239 \r
 240 #############################\r
 241 ### Checks\r
 242 #############################\r
 243 sub is_outside($) {\r
 244         my $uq_link_addr = shift;\r
 245         if (!exists $m_is_outside{$uq_link_addr}) {\r
 246                 $m_is_outside{$uq_link_addr} = test_is_outside($uq_link_addr, \@m_sLinkRoots);\r
 247         }\r
 248         return $m_is_outside{$uq_link_addr};\r
 249 }\r
 250 sub set_is_container($$) {\r
 251         my $uq_link_addr = shift;\r
 252         return if exists $m_is_container{$uq_link_addr};\r
 253         $m_is_container{$uq_link_addr} = shift;\r
 254 }\r
 255 sub is_outside_container($) {\r
 256         my $uq_link_addr = shift;\r
 257         if (exists $m_is_container{$uq_link_addr}) {\r
 258                 if ($m_is_container{$uq_link_addr}) {\r
 259                         return is_outside($uq_link_addr);\r
 260                 }\r
 261         }\r
 262 }\r
 263 sub test_is_outside($$) {\r
 264         my $uq_link_addr = shift;\r
 265         my $link_roots   = shift;\r
 266         if (defined $link_roots) {\r
 267                 my $in_roots;\r
 268                 for my $link_root (@$link_roots) {\r
 269                         if (substr($uq_link_addr, 0, length($link_root)) eq $link_root) {\r
 270                                 return 0;\r
 271                         }\r
 272                 }\r
 273                 return 1;\r
 274         }\r
 275 } # is_outside\r
 276 \r
 277 \r
 278 \r
 279 ##########################################################\r
 280 ### Parsing\r
 281 ##########################################################\r
 282 \r
 283 \r
 284 ### Parser subs\r
 285 sub HTML::WalkerParser::declaration {\r
 286     my($self, $decl) = @_;\r
 287         return unless defined $self->{parsed_fh};\r
 288         my $fh = $self->{parsed_fh};\r
 289         print $fh "<!" . $decl . ">";\r
 290 }\r
 291 my $m_start_cb;\r
 292 sub HTML::WalkerParser::start {\r
 293     my($self, $tag, $attr, $ended) = @_;\r
 294         &$m_start_cb($tag, $attr);\r
 295         return unless defined $self->{parsed_fh};\r
 296         my $t = "<$tag";\r
 297         for my $k (keys %$attr) {\r
 298                 my $encoded = encode_entities($$attr{$k});\r
 299                 $t .= qq( $k="$encoded");\r
 300         }\r
 301         if ($ended) {\r
 302                 $t .= " />";\r
 303         } else {\r
 304                 $t .= ">";\r
 305         }\r
 306         my $fh = $self->{parsed_fh};\r
 307         print $fh $t;\r
 308 }\r
 309 sub HTML::WalkerParser::end {\r
 310         my ($self, $tag) = @_;\r
 311         return unless defined $self->{parsed_fh};\r
 312         my $fh = $self->{parsed_fh};\r
 313         print $fh "</" . $tag . ">";\r
 314 }\r
 315 sub HTML::WalkerParser::text {\r
 316         my ($self, $txt) = @_;\r
 317         return unless defined $self->{parsed_fh};\r
 318         my $fh = $self->{parsed_fh};\r
 319         print $fh $txt;\r
 320 }\r
 321 sub HTML::WalkerParser::comment {\r
 322     my($self, $comment) = @_;\r
 323         return unless defined $self->{parsed_fh};\r
 324         my $fh = $self->{parsed_fh};\r
 325         print $fh "<!--" . $comment . "-->";\r
 326 }\r
 327 \r
 328 \r
 329 \r
 330 \r
 331 ### Main parsing routine\r
 332 \r
 333 sub parse_file($$$$$$$$$) {\r
 334         my ($file_name, $parsed_fh, $uq_link_addr, $link_roots,\r
 335                 $ref_links, $ref_anchs, $ref_lines, $ref_tagname, $ref_attname) = @_;\r
 336         my $fh;\r
 337         if (-d $file_name) {\r
 338                 $file_name = PathSubs::uniq_dir($file_name) . "default.html";\r
 339                 $uq_link_addr .= "/" unless substr($uq_link_addr, -1) eq "/";\r
 340                 $uq_link_addr .= "default.html";\r
 341                 &$m_subReport("dir => $file_name\n");\r
 342         }\r
 343         $fh = new IO::File($file_name);\r
 344         die "Can't read $file_name: $!\n" unless defined $fh;\r
 345         my $base_href;\r
 346         my $n;\r
 347         my $line;\r
 348         my $uq_link_fold = $uq_link_addr; $uq_link_fold =~ s![^/]*$!!;\r
 349 \r
 350         my $start_cb =\r
 351                 sub {\r
 352                         my ($tag, $attr_hash) = @_;\r
 353                         for my $k (keys %$attr_hash) {\r
 354                                 if (($k eq "id") || ($k eq "name")) {\r
 355                                         my $v = $$attr_hash{$k};\r
 356                                         $$ref_anchs{$v} = $n;\r
 357                                         $$ref_lines{$n} = $line;\r
 358                                 } elsif (exists $LINKATTRIBS{$k}) {\r
 359                                         my $v = $$attr_hash{$k};\r
 360                                         next if $v =~ m!^javascript:!;\r
 361                                         next if $v =~ m!^ftp://!;\r
 362                                         next if $v =~ m!^mailto://!;\r
 363                                         if ($tag eq "base") { $base_href = $v if $k eq "href"; next; }\r
 364                                         my $v_abs; my $v_rel;\r
 365                                         my $v_is_abs = PathSubs::is_abs_path($v);\r
 366                                         if ($v_is_abs) {\r
 367                                                 $v_abs = $v;\r
 368                                                 $v_rel = PathSubs::mk_relative_link($uq_link_addr, $v_abs);\r
 369                                         } else {\r
 370                                                 $v_rel = $v;\r
 371                                                 if (defined $base_href) {\r
 372                                                         $v_abs = PathSubs::mk_abs_link($base_href, $v);\r
 373                                                 } else {\r
 374                                                         if (substr($v_rel, 0, 1) ne "#") {\r
 375                                                                 $v_abs = $uq_link_fold . $v_rel;\r
 376                                                         } else {\r
 377                                                                 $v_abs = $uq_link_addr . $v_rel;\r
 378                                                         }\r
 379                                                         $v_abs = PathSubs::resolve_dotdot($v_abs);\r
 380                                                 }\r
 381                                         }\r
 382                                         next if exists $m_CheckedLinks{$v_abs};\r
 383                                         if (is_outside($v_abs)) {\r
 384                                                 if (!$v_is_abs) {\r
 385                                                         if (ending_is_container($v_abs)) {\r
 386                                                                 $m_CheckedLinks{$v_abs} = {};\r
 387                                                                 tell_bad_link("Outside relative link ($v_rel)",\r
 388                                                                         $uq_link_addr, $n, $v, $line);\r
 389                                                         }\r
 390                                                 }\r
 391                                                 ### Skip outside absolute links\r
 392                                                 ### Could be things like banners etc...\r
 393                                                 next;\r
 394                                         }\r
 395                                         $$ref_links{$v_rel} = $n;\r
 396                                         $$ref_lines{$n} = $line;\r
 397                                         if (substr($v_rel, 0, 1) ne "#") {\r
 398                                                 my $v_rel_name = $v_rel;\r
 399                                                 $v_rel_name =~ s!#.*$!!;\r
 400                                                 $v_rel_name =~ s!\?.*$!!;\r
 401                                                 $$ref_tagname{$v_rel_name} = $tag;\r
 402                                                 $$ref_attname{$v_rel_name} = $k;\r
 403                                         }\r
 404                                         if ($v_is_abs && ($v_rel ne $v)) { $$attr_hash{$k} = $v_rel; }\r
 405                                 }\r
 406                         }\r
 407                 }; # $start_cb\r
 408 \r
 409         $m_start_cb = $start_cb;\r
 410         my $p = HTML::WalkerParser->new($parsed_fh);\r
 411         while ($line = <$fh>) {\r
 412                 $n++;\r
 413                 $p->parse($line);\r
 414         }\r
 415         $fh->close();\r
 416 } # parse_file\r
 417 \r
 418 \r
 419 \r
 420 ##########################################################\r
 421 ### Do the walk...\r
 422 ##########################################################\r
 423 sub walk_link($$;$$$$) {\r
 424         die "$#_" unless ($#_ == 1 || $#_ == 5);\r
 425         my $link_fold   = shift;\r
 426         my $link_file   = shift;\r
 427         my $parent_url  = shift;\r
 428         my $parent_lnum = shift;\r
 429         my $parent_link = shift;\r
 430         my $parent_line = shift;\r
 431 \r
 432         my $link_addr   = $link_fold . $link_file;\r
 433         my $uq_link_addr;\r
 434         my $is_file = ($link_addr !~ m!^https?://!i);\r
 435         if ($is_file) {\r
 436                 $uq_link_addr = PathSubs::uniq_file($link_addr);\r
 437         } else {\r
 438                 $uq_link_addr = PathSubs::resolve_dotdot($link_addr);\r
 439         }\r
 440         return if exists $m_CheckedLinks{$uq_link_addr};\r
 441         return if exists  $m_MissedLinks{$uq_link_addr};\r
 442         $m_CheckedLinks{$uq_link_addr} = {};\r
 443         my $link_is_container = ending_is_container($uq_link_addr);\r
 444         if ($link_is_container) {\r
 445                 set_is_container($uq_link_addr, 1);\r
 446                 return if is_outside($uq_link_addr);\r
 447         } else {\r
 448                 return if $m_bOnlyCont;\r
 449         }\r
 450         my $response;\r
 451         my $contenttype;\r
 452         my $bDoRewrite;\r
 453         my $file_name;\r
 454         if ($is_file) {\r
 455                 if (!-r $uq_link_addr) {\r
 456                         tell_bad_link("Can't read file ($uq_link_addr)",\r
 457                                 $parent_url, $parent_lnum, $parent_link, $parent_line);\r
 458                         $m_MissedLinks{$uq_link_addr} = 1;\r
 459                         return;\r
 460                 }\r
 461                 $file_name = $uq_link_addr;\r
 462         } else {\r
 463                 $file_name = mk_mirror_name($uq_link_addr);\r
 464                 if (!defined $ua) {\r
 465                         $ua = new LWP::UserAgent;\r
 466                         $ua->agent($m_ua_personality);\r
 467                         #$ua->delay(0.1);\r
 468                 }\r
 469                 if ($m_bMirror) {\r
 470                         $response = $ua->mirror($uq_link_addr, $file_name);\r
 471                         &$m_subMirrorAction($uq_link_addr, $file_name, $response);\r
 472                 } else {\r
 473                         my $request = new HTTP::Request('GET', $uq_link_addr);\r
 474                         $response = $ua->request($request, $file_name);\r
 475                 }\r
 476                 #dump_response($response); exit;\r
 477                 if ($response->code != 304) {\r
 478                         if (!$response->is_success) {\r
 479                                 tell_bad_link($response->status_line . " ($uq_link_addr)",\r
 480                                         $parent_url, $parent_lnum, $parent_link, $parent_line);\r
 481                                 $m_MissedLinks{$uq_link_addr} = 1;\r
 482                                 return;\r
 483                         }\r
 484                         $bDoRewrite = $m_bMirror;\r
 485                         $contenttype = get_contenttype($response);\r
 486                         $link_is_container = is_linked_contenttype($response);\r
 487                 }\r
 488                 if ($uq_link_addr ne $response->base) {\r
 489                         if ($m_bMirror) {\r
 490                                 my $base_file = mk_mirror_name($response->base);\r
 491                                 if (!File::Copy::copy($file_name, $base_file)) {\r
 492                                         die "Can't copy($file_name, $base_file): $!\n";\r
 493                                 }\r
 494                                 if (my $lm = $response->last_modified) { utime $lm, $lm, $base_file; }\r
 495                                 $file_name = $base_file;\r
 496                         }\r
 497                         $uq_link_addr = $response->base;\r
 498                 }\r
 499         }\r
 500         ### Test again, could be new info from net!\r
 501         if ($link_is_container) {\r
 502                 set_is_container($uq_link_addr, 1);\r
 503                 return if is_outside($uq_link_addr);\r
 504         } else {\r
 505                 return if $m_bOnlyCont;\r
 506                 return;\r
 507         }\r
 508         &$m_subReport("$uq_link_addr ...");\r
 509 \r
 510         my %links;\r
 511         my %anchs;\r
 512         my %lines;\r
 513         my %tagname;\r
 514         my %attname;\r
 515         my $parsed_fh;\r
 516         my $parsed_file;\r
 517         my $file_to_parse = $file_name;\r
 518         if ($bDoRewrite) {\r
 519                 $parsed_file = $file_to_parse . "-p$$";\r
 520                 &$m_subReport(" <<GET");\r
 521                 $parsed_fh = new IO::File("> $parsed_file");\r
 522                 die "Can't create $parsed_file: $!\n" unless defined $parsed_fh;\r
 523                 print $parsed_fh "<!-- parsed version -->\n";\r
 524         }\r
 525         &$m_subReport("\n");\r
 526         parse_file($file_to_parse, $parsed_fh, $uq_link_addr,\r
 527                 \@m_sLinkRoots,\r
 528                 \%links, \%anchs, \%lines, \%tagname, \%attname);\r
 529         if (defined $parsed_fh) {\r
 530                 $parsed_fh->close();\r
 531                 if (-e $file_name) { unlink $file_name or die "Can't unlink $file_name: $!"; }\r
 532                 rename($parsed_file, $file_name) or die "Can't rename($parsed_file, $file_name): $!\n";\r
 533             if (my $lm = $response->last_modified) { utime $lm, $lm, $file_name; }\r
 534         }\r
 535         ### Now we know...\r
 536         if ($link_is_container) { return if is_outside($uq_link_addr); }\r
 537 \r
 538         $m_CheckedLinks{$uq_link_addr}->{ANC} = \%anchs;\r
 539         my $file_dir;\r
 540         if ($is_file) {\r
 541                 $file_dir = $uq_link_addr;\r
 542                 $file_dir =~ s![^/]*$!!;\r
 543                 #chdir $file_dir;\r
 544         }\r
 545         my $container_folder = $uq_link_addr; $container_folder =~ s![^/]*$!!;\r
 546         &$m_subAction($uq_link_addr, $file_name, $contenttype);\r
 547         for my $link (sort keys %links) {\r
 548                 # Next line is for onclick lines in prepared docs\r
 549                 next if ($link eq "#");\r
 550                 my $lnum = $links{$link};\r
 551                 my $line = $lines{$lnum};\r
 552                 if ($link eq "") {\r
 553                         tell_bad_link("Empty link", $uq_link_addr, $lnum, $link, $line);\r
 554                         next;\r
 555                 }\r
 556                 if ($link =~ m!(.*)\?!) { $link = $1; }\r
 557                 my $anchor;\r
 558                 if ($link =~ m!(.*)#(.*)!) { $link = $1; $anchor = $2; }\r
 559                 if ($link eq "") {\r
 560                         if (!exists $anchs{$anchor}) {\r
 561                                 tell_bad_link("Anchor not found ($anchor)", $uq_link_addr, $lnum, $link, $line);\r
 562                         }\r
 563                         next;\r
 564                 }\r
 565                 my $sub_fold;\r
 566                 my $sub_file;\r
 567                 my $uq_sublink; \r
 568                 if ($link =~ m!^https?://!i) {\r
 569                         $sub_fold = "";\r
 570                         $sub_file = $link;\r
 571                         $uq_sublink = $link;\r
 572                 } else {\r
 573                         $sub_file = $link;\r
 574                         if ($is_file) {\r
 575                                 $sub_fold = $file_dir;\r
 576                                 $uq_sublink = PathSubs::uniq_file($sub_fold . $sub_file);\r
 577                         } else {\r
 578                                 $sub_fold = $container_folder;\r
 579                                 $uq_sublink = $sub_fold . $sub_file;\r
 580                         }\r
 581                 }\r
 582                 next if (exists $m_CheckedLinks{$uq_sublink});\r
 583                 if (defined $anchor) {\r
 584                         $m_CheckedLinks{$uq_link_addr}->{EXTANC}->{$uq_sublink} =\r
 585                                         { ANC=> $anchor, LINE=>$line, LNUM=>$lnum};\r
 586                 }\r
 587                 if ($m_bOnlyCont) {\r
 588                         die "link=$link\tattr=$tagname{$link}\n" unless exists $tagname{$link};\r
 589                         next unless maybecont($tagname{$link}, $attname{$link});\r
 590                 }\r
 591                 if (is_outside($uq_link_addr)) {\r
 592                         if (maybecont($tagname{$link}, $attname{$link}) ) {\r
 593                                 next;\r
 594                         }\r
 595                 }\r
 596                 walk_link($sub_fold, $sub_file, $uq_link_addr, $lnum, $link, $line);\r
 597         }\r
 598 } # walk_link\r
 599 \r
 600 \r
 601 \r
 602 \r
 603 ############################################\r
 604 ### Some more checks!\r
 605 ############################################\r
 606 sub check_external_anchors() {\r
 607         &$m_subReport("\nChecking external anchors...\n");\r
 608         for my $f (sort keys %m_CheckedLinks) {\r
 609                 my $fnode = $m_CheckedLinks{$f};\r
 610                 if (exists ${$fnode}{"EXTANC"}) {\r
 611                         my $extanc_hash = ${$fnode}{"EXTANC"};\r
 612                         for my $fx (keys %$extanc_hash) {\r
 613                                 next unless (exists $m_CheckedLinks{$fx});\r
 614                                 my $ea_hash = ${$extanc_hash}{$fx};\r
 615                                 my $ea = ${$ea_hash}{ANC};\r
 616                                 my $fxnode = $m_CheckedLinks{$fx};\r
 617                                 my $fx_anc_hash = ${$fxnode}{"ANC"};\r
 618                                 if (!exists ${$fx_anc_hash}{$ea}) {\r
 619                                         my $line = ${$ea_hash}{LINE};\r
 620                                         my $lnum = ${$ea_hash}{LNUM};\r
 621                                         &$m_subReport("From $f\n");\r
 622                                         tell_bad_link("Ext anchor not found ($fx#$ea)",\r
 623                                                 $f, $lnum, "$fx#$ea", $line);\r
 624                                 }\r
 625                         }\r
 626                 }\r
 627         }\r
 628 } # check_external_anchors\r
 629 \r
 630 \r
 631 \r
 632 #############################\r
 633 ### Reporting\r
 634 #############################\r
 635 sub report_errors($$) {\r
 636         my $bSum = shift;\r
 637         my $bDet = shift;\r
 638         my $errors_reported;\r
 639         my $errors_found;\r
 640         for my $f (sort keys %m_CheckedLinks) {\r
 641                 my $fnode = $m_CheckedLinks{$f};\r
 642                 if (exists ${$fnode}{ERR}) {\r
 643                         $errors_found = 1;\r
 644                         last unless $bSum;\r
 645                         if (!defined $errors_reported) {\r
 646                                 $errors_reported = 1;\r
 647                                 &$m_subReport("\n\n*********** Summary ERRORS and WARNINGS **********\n");\r
 648                         }\r
 649                         &$m_subReport("$f\n");\r
 650                         my $err_hash = ${$fnode}{ERR};\r
 651                         for my $e (sort keys %$err_hash) {\r
 652                                 my $refE = ${$err_hash}{$e};\r
 653                                 &$m_subReport("\t" . ${$refE}[0] . "\n");\r
 654                         }\r
 655                 }\r
 656         }\r
 657         undef $errors_reported;\r
 658         if ($bDet) {\r
 659                 for my $f (sort keys %m_CheckedLinks) {\r
 660                         my $fnode = $m_CheckedLinks{$f};\r
 661                         if (exists ${$fnode}{ERR}) {\r
 662                                 if (!defined $errors_reported) {\r
 663                                         $errors_reported = 1;\r
 664                                         &$m_subReport("\n\n*********** Detailed ERRORS and WARNINGS **********\n");\r
 665                                 }\r
 666                                 &$m_subReport("$f\n");\r
 667                                 my $err_hash = ${$fnode}{ERR};\r
 668                                 for my $e (sort keys %$err_hash) {\r
 669                                         my $refE = ${$err_hash}{$e};\r
 670                                         &$m_subReport("\tat line $e: " .  ${$refE}[1] . "\n");\r
 671                                 }\r
 672                         }\r
 673                 }\r
 674         }\r
 675         if ($errors_found) {\r
 676                 die "\n*** There where errors ***\n";\r
 677         } else {\r
 678                 &$m_subReport("No errors found\n");\r
 679         }\r
 680 } # report_errors\r
 681 \r
 682 sub dump_response($) {\r
 683         my $response = shift;\r
 684                 &$m_subReport( $response->code . " " . $response->message . "\n");\r
 685                 &$m_subReport( "****************************************\n");\r
 686                 #&$m_subReport( $response->request . "\n");\r
 687                 #&$m_subReport( "****************************************\n");\r
 688                 #&$m_subReport( $response->previous . "\n");\r
 689                 #&$m_subReport( "****************************************\n");\r
 690                 &$m_subReport(  "  i=" . $response->is_info .\r
 691                                 ", s=" . $response->is_success .\r
 692                                 ", r=" . $response->is_redirect .\r
 693                                 ", e=" . $response->is_error . "\n");\r
 694                 &$m_subReport( "****************************************\n");\r
 695                 &$m_subReport( "content: " . $response->content . "\n");\r
 696                 &$m_subReport( "****************************************\n");\r
 697                 &$m_subReport( "base: " . $response->base . "\n");\r
 698                 &$m_subReport( "****************************************\n");\r
 699                 &$m_subReport( $response->as_string);\r
 700                 &$m_subReport( "****************************************\n");\r
 701                 &$m_subReport( $response->current_age . "\n");\r
 702                 &$m_subReport( "****************************************\n");\r
 703                 my @rh = $response->header("Content-Type");\r
 704                 for my $r (@rh) { &$m_subReport( "ct: $r\n"); }\r
 705                 &$m_subReport( "****************************************\n");\r
 706 } # dump_response\r
 707 \r
 708 \r
 709 #############################\r
 710 ### Parameters\r
 711 #############################\r
 712 sub sMirrorRoot() {\r
 713         my $val = shift;\r
 714         $m_sMirrorRoot = PathSubs::get_temp_path() . "LinkWalker/" unless defined $m_sMirrorRoot;\r
 715         my $old = $m_sMirrorRoot;\r
 716         $m_sMirrorRoot = PathSubs::uniq_dir($val) if defined $val;\r
 717         return $old;\r
 718 }\r
 719 sub bMirror(;$) {\r
 720         my $val = shift;\r
 721         my $old = $m_bMirror;\r
 722         $m_bMirror = $val if defined $val;\r
 723         $old;\r
 724 }\r
 725 \r
 726 sub subReporter(;$) {\r
 727         my $val = shift;\r
 728         my $old = $m_subReport;\r
 729         $m_subReport = $val if defined $val;\r
 730         $old\r
 731 }\r
 732 sub subAction(;$) {\r
 733         my $val = shift;\r
 734         my $old = $m_subAction;\r
 735         $m_subAction = $val if defined $val;\r
 736         $old\r
 737 }\r
 738 sub bOnlyCont(;$) {\r
 739         my $val = shift;\r
 740         my $old = $m_bOnlyCont;\r
 741         $m_bOnlyCont = $val if defined $val;\r
 742         $old\r
 743 }\r
 744 sub ua_personality(;$) {\r
 745         my $val = shift;\r
 746         my $old = $m_ua_personality;\r
 747         $m_ua_personality = $val if defined $val;\r
 748         $old\r
 749 }\r
 750 \r
 751 sub clear_roots() { @m_sLinkRoots = (); }\r
 752 sub get_roots() { return \@m_sLinkRoots; }\r
 753 sub add_root($) { push @m_sLinkRoots, shift; }\r
 754 sub add_files_root($) {\r
 755         my $file = shift;\r
 756         my $default_root;\r
 757         my ($host) = ($file =~ m!(^https?://[^/]*)!i);\r
 758         if (defined $host) {\r
 759                 $default_root = $file;\r
 760         } else {\r
 761                 die "Can't find $file\n" unless -e $file;\r
 762                 $default_root = PathSubs::uniq_file($file);\r
 763         }\r
 764         $default_root =~ s![^/]*$!!;\r
 765         add_root($default_root);\r
 766 }\r
 767 \r
 768 ### Default actions\r
 769 sub default_sub {}\r
 770 $m_subReport            = \&default_sub;\r
 771 $m_subAction            = \&default_sub;\r
 772 $m_subMirrorAction      = \&default_sub;\r
 773 \r
 774 1;\r