diff options
Diffstat (limited to 'emacs.d/nxhtml/nxhtml/html-chklnk/PerlLib/HTML/LinkWalker.pm')
| -rw-r--r-- | emacs.d/nxhtml/nxhtml/html-chklnk/PerlLib/HTML/LinkWalker.pm | 774 |
1 files changed, 774 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/nxhtml/html-chklnk/PerlLib/HTML/LinkWalker.pm b/emacs.d/nxhtml/nxhtml/html-chklnk/PerlLib/HTML/LinkWalker.pm new file mode 100644 index 0000000..14b0ccb --- /dev/null +++ b/emacs.d/nxhtml/nxhtml/html-chklnk/PerlLib/HTML/LinkWalker.pm @@ -0,0 +1,774 @@ +### File: LinkWalker.pm
+### Author: Lennart Borgman
+### All rights reserved
+
+##########################################################
+### UserAgent module
+##########################################################
+package LWP::WalkerUA;
+require LWP::UserAgent;
+@ISA = qw(LWP::UserAgent);
+
+### Mirror to another file (why???)
+sub mirror
+{
+ my($self, $url, $file, $mirr_tmp) = @_;
+ die "no mirr_tmp" unless defined $mirr_tmp;
+
+ LWP::Debug::trace('()');
+ my $request = new HTTP::Request('GET', $url);
+
+ if (-e $file) {
+ my($mtime) = (stat($file))[9];
+ if($mtime) {
+ $request->header('If-Modified-Since' =>
+ HTTP::Date::time2str($mtime));
+ }
+ }
+ my $tmpfile = "$file-$$";
+
+ my $response = $self->request($request, $tmpfile);
+ if ($response->is_success) {
+
+ my $file_length = (stat($tmpfile))[7];
+ my($content_length) = $response->header('Content-length');
+
+ if (defined $content_length and $file_length < $content_length) {
+ unlink($tmpfile);
+ die "Transfer truncated: " .
+ "only $file_length out of $content_length bytes received\n";
+ } elsif (defined $content_length and $file_length > $content_length) {
+ unlink($tmpfile);
+ die "Content-length mismatch: " .
+ "expected $content_length bytes, got $file_length\n";
+ } else {
+ # OK
+ if (-e $mirr_tmp) {
+ # Some dosish systems fail to rename if the target exists
+ chmod 0777, $mirr_tmp;
+ unlink $mirr_tmp;
+ }
+ rename($tmpfile, $mirr_tmp) or
+ die "Cannot rename '$tmpfile' to '$mirr_tmp': $!\n";
+
+ if (my $lm = $response->last_modified) {
+ # make sure the file has the same last modification time
+ utime $lm, $lm, $mirr_tmp;
+ }
+ }
+ } else {
+ unlink($tmpfile);
+ }
+ return $response;
+}
+
+
+##########################################################
+### Parser module
+##########################################################
+package HTML::WalkerParser;
+require HTML::ParserTagEnd;
+@ISA = qw(HTML::ParserTagEnd);
+use strict;
+use vars qw(%LINK_ELEMENT);
+
+# Elements that might contain links and the name of the link attribute
+%LINK_ELEMENT =
+(
+ body => 'background',
+ base => 'href',
+ a => 'href',
+ img => [qw(src lowsrc usemap)], # 'lowsrc' is a Netscape invention
+ form => 'action',
+ input => 'src',
+'link' => 'href', # need quoting since link is a perl builtin
+ frame => 'src',
+ applet => [qw(codebase code)],
+ area => 'href',
+ iframe => 'src', # Netscape 2.0 extention
+ embed => 'src', # used in Netscape 2.0 for Shockwave and things like that
+);
+
+my %LINKATTRIBS = (
+ "href" => 1,
+ "src" => 1,
+ "action" => 1,
+ "background" => 1,
+ "usemap" => 1,
+ "code" => 1,
+ "codebase" => 1,
+ "lowsrc" => 1,
+ );
+my %MAYBECONT = (
+ a => 'href',
+ area => 'href',
+ form => 'action',
+ frame => 'src',
+ iframe => 'src',
+ );
+
+sub maybecont($$) {
+ my $tag = shift;
+ my $att = shift;
+ return unless exists $MAYBECONT{$tag};
+ return ($MAYBECONT{$tag} eq $att);
+}
+
+sub new {
+ my($class, $parsed_fh) = @_;
+ my $self = $class->SUPER::new;
+ $self->{parsed_fh} = $parsed_fh;
+ $self;
+}
+
+
+
+
+
+
+
+##########################################################
+### Walker module
+##########################################################
+package HTML::LinkWalker;
+use strict;
+
+use IO::File;
+use File::Copy qw();
+use File::Path qw();
+use PathSubs qw();
+use HTML::Entities;
+use FindBin qw();
+
+
+##########################################################
+### Globals
+##########################################################
+my $ua;
+my $m_ua_personality = "LinkWalker/0.9";
+my %m_is_outside;
+my %m_is_container;
+my $m_bOnlyCont;
+my @m_sLinkRoots;
+my $m_subReport;
+my $m_subAction;
+my $m_subMirrorAction;
+
+
+#############################
+### Collecting info
+#############################
+my %m_CheckedLinks;
+my %m_MissedLinks;
+
+sub tell_bad_link($$$$$) {
+ my $what = shift;
+ my $file = shift;
+ my $lnum = shift;
+ my $link = shift;
+ my $line = shift;
+ $file = "START" unless defined $file;
+ $lnum = "(start)" unless defined $lnum;
+ my $longMsg = "<<$what>>";
+ my $shortMsg = $what;
+ if (defined $link) {
+ my @lines = split("\\s+", $line);
+ my $disp_line = join("\n\t\t ", @lines);
+ $longMsg .= ",\n\t\tlink=$link\n\t\t$disp_line";
+ }
+ my @msg = ($shortMsg, $longMsg);
+ $m_CheckedLinks{$file}->{ERR}->{$lnum} = \@msg;
+ &$m_subReport("\t* Error * " . $what . "\n");
+} # tell_bad_link
+
+
+#############################
+### Helpers
+#############################
+
+sub get_contenttype($) {
+ my $response = shift;
+ my @rh = $response->header("Content-Type");
+ for my $r (@rh) {
+ my $c = $r;
+ if ((my $iPos = index($r, ";")) > -1) {
+ $c = substr($r, 0, $iPos);
+ }
+ return $c;
+ }
+}
+sub is_linked_contenttype($) {
+ my $response = shift;
+ return (get_contenttype($response) eq "text/html");
+}
+
+sub ending_is_container($) {
+ my $link_addr = shift;
+ $link_addr =~ s!#.*$!!;
+ $link_addr =~ s!\?.*$!!;
+ return (($link_addr =~ m!\.s?html?$!i) ? 1 : 0);
+}
+
+my $m_sMirrorRoot;
+my $m_bMirror = 1;
+
+sub mk_mirror_name($) {
+ my $orig_name = shift;
+ $orig_name =~ tr!\\!/!;
+ my $mirr_name = $orig_name;
+ my ($orig_host) = ($orig_name =~ m!(^https?://[^/]*)!i);
+ if (defined $orig_host) {
+ my $host = $orig_host;
+ $host =~ tr!:!_!;
+ $host =~ tr!/!_!;
+ $mirr_name =~ s!^$orig_host!$host!;
+ if (substr($mirr_name, -1) eq "/") { $mirr_name .= "default.html"; }
+ } else {
+ die "Can't find host in $orig_name\n";
+ }
+ my $mirr_full = sMirrorRoot() . $mirr_name;
+ if (!$m_bMirror) {
+ my $sExt = $mirr_name; $sExt =~ s!.*\.([^\.]*$)!$1!;
+ $mirr_full = sMirrorRoot() . "temp.$sExt";
+ }
+ my $mirr_fold = $mirr_full;
+ $mirr_fold =~ s![^/]*$!!;
+ File::Path::mkpath($mirr_fold, 0, 0777);
+ return $mirr_full;
+}
+
+#############################
+### Checks
+#############################
+sub is_outside($) {
+ my $uq_link_addr = shift;
+ if (!exists $m_is_outside{$uq_link_addr}) {
+ $m_is_outside{$uq_link_addr} = test_is_outside($uq_link_addr, \@m_sLinkRoots);
+ }
+ return $m_is_outside{$uq_link_addr};
+}
+sub set_is_container($$) {
+ my $uq_link_addr = shift;
+ return if exists $m_is_container{$uq_link_addr};
+ $m_is_container{$uq_link_addr} = shift;
+}
+sub is_outside_container($) {
+ my $uq_link_addr = shift;
+ if (exists $m_is_container{$uq_link_addr}) {
+ if ($m_is_container{$uq_link_addr}) {
+ return is_outside($uq_link_addr);
+ }
+ }
+}
+sub test_is_outside($$) {
+ my $uq_link_addr = shift;
+ my $link_roots = shift;
+ if (defined $link_roots) {
+ my $in_roots;
+ for my $link_root (@$link_roots) {
+ if (substr($uq_link_addr, 0, length($link_root)) eq $link_root) {
+ return 0;
+ }
+ }
+ return 1;
+ }
+} # is_outside
+
+
+
+##########################################################
+### Parsing
+##########################################################
+
+
+### Parser subs
+sub HTML::WalkerParser::declaration {
+ my($self, $decl) = @_;
+ return unless defined $self->{parsed_fh};
+ my $fh = $self->{parsed_fh};
+ print $fh "<!" . $decl . ">";
+}
+my $m_start_cb;
+sub HTML::WalkerParser::start {
+ my($self, $tag, $attr, $ended) = @_;
+ &$m_start_cb($tag, $attr);
+ return unless defined $self->{parsed_fh};
+ my $t = "<$tag";
+ for my $k (keys %$attr) {
+ my $encoded = encode_entities($$attr{$k});
+ $t .= qq( $k="$encoded");
+ }
+ if ($ended) {
+ $t .= " />";
+ } else {
+ $t .= ">";
+ }
+ my $fh = $self->{parsed_fh};
+ print $fh $t;
+}
+sub HTML::WalkerParser::end {
+ my ($self, $tag) = @_;
+ return unless defined $self->{parsed_fh};
+ my $fh = $self->{parsed_fh};
+ print $fh "</" . $tag . ">";
+}
+sub HTML::WalkerParser::text {
+ my ($self, $txt) = @_;
+ return unless defined $self->{parsed_fh};
+ my $fh = $self->{parsed_fh};
+ print $fh $txt;
+}
+sub HTML::WalkerParser::comment {
+ my($self, $comment) = @_;
+ return unless defined $self->{parsed_fh};
+ my $fh = $self->{parsed_fh};
+ print $fh "<!--" . $comment . "-->";
+}
+
+
+
+
+### Main parsing routine
+
+sub parse_file($$$$$$$$$) {
+ my ($file_name, $parsed_fh, $uq_link_addr, $link_roots,
+ $ref_links, $ref_anchs, $ref_lines, $ref_tagname, $ref_attname) = @_;
+ my $fh;
+ if (-d $file_name) {
+ $file_name = PathSubs::uniq_dir($file_name) . "default.html";
+ $uq_link_addr .= "/" unless substr($uq_link_addr, -1) eq "/";
+ $uq_link_addr .= "default.html";
+ &$m_subReport("dir => $file_name\n");
+ }
+ $fh = new IO::File($file_name);
+ die "Can't read $file_name: $!\n" unless defined $fh;
+ my $base_href;
+ my $n;
+ my $line;
+ my $uq_link_fold = $uq_link_addr; $uq_link_fold =~ s![^/]*$!!;
+
+ my $start_cb =
+ sub {
+ my ($tag, $attr_hash) = @_;
+ for my $k (keys %$attr_hash) {
+ if (($k eq "id") || ($k eq "name")) {
+ my $v = $$attr_hash{$k};
+ $$ref_anchs{$v} = $n;
+ $$ref_lines{$n} = $line;
+ } elsif (exists $LINKATTRIBS{$k}) {
+ my $v = $$attr_hash{$k};
+ next if $v =~ m!^javascript:!;
+ next if $v =~ m!^ftp://!;
+ next if $v =~ m!^mailto://!;
+ if ($tag eq "base") { $base_href = $v if $k eq "href"; next; }
+ my $v_abs; my $v_rel;
+ my $v_is_abs = PathSubs::is_abs_path($v);
+ if ($v_is_abs) {
+ $v_abs = $v;
+ $v_rel = PathSubs::mk_relative_link($uq_link_addr, $v_abs);
+ } else {
+ $v_rel = $v;
+ if (defined $base_href) {
+ $v_abs = PathSubs::mk_abs_link($base_href, $v);
+ } else {
+ if (substr($v_rel, 0, 1) ne "#") {
+ $v_abs = $uq_link_fold . $v_rel;
+ } else {
+ $v_abs = $uq_link_addr . $v_rel;
+ }
+ $v_abs = PathSubs::resolve_dotdot($v_abs);
+ }
+ }
+ next if exists $m_CheckedLinks{$v_abs};
+ if (is_outside($v_abs)) {
+ if (!$v_is_abs) {
+ if (ending_is_container($v_abs)) {
+ $m_CheckedLinks{$v_abs} = {};
+ tell_bad_link("Outside relative link ($v_rel)",
+ $uq_link_addr, $n, $v, $line);
+ }
+ }
+ ### Skip outside absolute links
+ ### Could be things like banners etc...
+ next;
+ }
+ $$ref_links{$v_rel} = $n;
+ $$ref_lines{$n} = $line;
+ if (substr($v_rel, 0, 1) ne "#") {
+ my $v_rel_name = $v_rel;
+ $v_rel_name =~ s!#.*$!!;
+ $v_rel_name =~ s!\?.*$!!;
+ $$ref_tagname{$v_rel_name} = $tag;
+ $$ref_attname{$v_rel_name} = $k;
+ }
+ if ($v_is_abs && ($v_rel ne $v)) { $$attr_hash{$k} = $v_rel; }
+ }
+ }
+ }; # $start_cb
+
+ $m_start_cb = $start_cb;
+ my $p = HTML::WalkerParser->new($parsed_fh);
+ while ($line = <$fh>) {
+ $n++;
+ $p->parse($line);
+ }
+ $fh->close();
+} # parse_file
+
+
+
+##########################################################
+### Do the walk...
+##########################################################
+sub walk_link($$;$$$$) {
+ die "$#_" unless ($#_ == 1 || $#_ == 5);
+ my $link_fold = shift;
+ my $link_file = shift;
+ my $parent_url = shift;
+ my $parent_lnum = shift;
+ my $parent_link = shift;
+ my $parent_line = shift;
+
+ my $link_addr = $link_fold . $link_file;
+ my $uq_link_addr;
+ my $is_file = ($link_addr !~ m!^https?://!i);
+ if ($is_file) {
+ $uq_link_addr = PathSubs::uniq_file($link_addr);
+ } else {
+ $uq_link_addr = PathSubs::resolve_dotdot($link_addr);
+ }
+ return if exists $m_CheckedLinks{$uq_link_addr};
+ return if exists $m_MissedLinks{$uq_link_addr};
+ $m_CheckedLinks{$uq_link_addr} = {};
+ my $link_is_container = ending_is_container($uq_link_addr);
+ if ($link_is_container) {
+ set_is_container($uq_link_addr, 1);
+ return if is_outside($uq_link_addr);
+ } else {
+ return if $m_bOnlyCont;
+ }
+ my $response;
+ my $contenttype;
+ my $bDoRewrite;
+ my $file_name;
+ if ($is_file) {
+ if (!-r $uq_link_addr) {
+ tell_bad_link("Can't read file ($uq_link_addr)",
+ $parent_url, $parent_lnum, $parent_link, $parent_line);
+ $m_MissedLinks{$uq_link_addr} = 1;
+ return;
+ }
+ $file_name = $uq_link_addr;
+ } else {
+ $file_name = mk_mirror_name($uq_link_addr);
+ if (!defined $ua) {
+ $ua = new LWP::UserAgent;
+ $ua->agent($m_ua_personality);
+ #$ua->delay(0.1);
+ }
+ if ($m_bMirror) {
+ $response = $ua->mirror($uq_link_addr, $file_name);
+ &$m_subMirrorAction($uq_link_addr, $file_name, $response);
+ } else {
+ my $request = new HTTP::Request('GET', $uq_link_addr);
+ $response = $ua->request($request, $file_name);
+ }
+ #dump_response($response); exit;
+ if ($response->code != 304) {
+ if (!$response->is_success) {
+ tell_bad_link($response->status_line . " ($uq_link_addr)",
+ $parent_url, $parent_lnum, $parent_link, $parent_line);
+ $m_MissedLinks{$uq_link_addr} = 1;
+ return;
+ }
+ $bDoRewrite = $m_bMirror;
+ $contenttype = get_contenttype($response);
+ $link_is_container = is_linked_contenttype($response);
+ }
+ if ($uq_link_addr ne $response->base) {
+ if ($m_bMirror) {
+ my $base_file = mk_mirror_name($response->base);
+ if (!File::Copy::copy($file_name, $base_file)) {
+ die "Can't copy($file_name, $base_file): $!\n";
+ }
+ if (my $lm = $response->last_modified) { utime $lm, $lm, $base_file; }
+ $file_name = $base_file;
+ }
+ $uq_link_addr = $response->base;
+ }
+ }
+ ### Test again, could be new info from net!
+ if ($link_is_container) {
+ set_is_container($uq_link_addr, 1);
+ return if is_outside($uq_link_addr);
+ } else {
+ return if $m_bOnlyCont;
+ return;
+ }
+ &$m_subReport("$uq_link_addr ...");
+
+ my %links;
+ my %anchs;
+ my %lines;
+ my %tagname;
+ my %attname;
+ my $parsed_fh;
+ my $parsed_file;
+ my $file_to_parse = $file_name;
+ if ($bDoRewrite) {
+ $parsed_file = $file_to_parse . "-p$$";
+ &$m_subReport(" <<GET");
+ $parsed_fh = new IO::File("> $parsed_file");
+ die "Can't create $parsed_file: $!\n" unless defined $parsed_fh;
+ print $parsed_fh "<!-- parsed version -->\n";
+ }
+ &$m_subReport("\n");
+ parse_file($file_to_parse, $parsed_fh, $uq_link_addr,
+ \@m_sLinkRoots,
+ \%links, \%anchs, \%lines, \%tagname, \%attname);
+ if (defined $parsed_fh) {
+ $parsed_fh->close();
+ if (-e $file_name) { unlink $file_name or die "Can't unlink $file_name: $!"; }
+ rename($parsed_file, $file_name) or die "Can't rename($parsed_file, $file_name): $!\n";
+ if (my $lm = $response->last_modified) { utime $lm, $lm, $file_name; }
+ }
+ ### Now we know...
+ if ($link_is_container) { return if is_outside($uq_link_addr); }
+
+ $m_CheckedLinks{$uq_link_addr}->{ANC} = \%anchs;
+ my $file_dir;
+ if ($is_file) {
+ $file_dir = $uq_link_addr;
+ $file_dir =~ s![^/]*$!!;
+ #chdir $file_dir;
+ }
+ my $container_folder = $uq_link_addr; $container_folder =~ s![^/]*$!!;
+ &$m_subAction($uq_link_addr, $file_name, $contenttype);
+ for my $link (sort keys %links) {
+ # Next line is for onclick lines in prepared docs
+ next if ($link eq "#");
+ my $lnum = $links{$link};
+ my $line = $lines{$lnum};
+ if ($link eq "") {
+ tell_bad_link("Empty link", $uq_link_addr, $lnum, $link, $line);
+ next;
+ }
+ if ($link =~ m!(.*)\?!) { $link = $1; }
+ my $anchor;
+ if ($link =~ m!(.*)#(.*)!) { $link = $1; $anchor = $2; }
+ if ($link eq "") {
+ if (!exists $anchs{$anchor}) {
+ tell_bad_link("Anchor not found ($anchor)", $uq_link_addr, $lnum, $link, $line);
+ }
+ next;
+ }
+ my $sub_fold;
+ my $sub_file;
+ my $uq_sublink;
+ if ($link =~ m!^https?://!i) {
+ $sub_fold = "";
+ $sub_file = $link;
+ $uq_sublink = $link;
+ } else {
+ $sub_file = $link;
+ if ($is_file) {
+ $sub_fold = $file_dir;
+ $uq_sublink = PathSubs::uniq_file($sub_fold . $sub_file);
+ } else {
+ $sub_fold = $container_folder;
+ $uq_sublink = $sub_fold . $sub_file;
+ }
+ }
+ next if (exists $m_CheckedLinks{$uq_sublink});
+ if (defined $anchor) {
+ $m_CheckedLinks{$uq_link_addr}->{EXTANC}->{$uq_sublink} =
+ { ANC=> $anchor, LINE=>$line, LNUM=>$lnum};
+ }
+ if ($m_bOnlyCont) {
+ die "link=$link\tattr=$tagname{$link}\n" unless exists $tagname{$link};
+ next unless maybecont($tagname{$link}, $attname{$link});
+ }
+ if (is_outside($uq_link_addr)) {
+ if (maybecont($tagname{$link}, $attname{$link}) ) {
+ next;
+ }
+ }
+ walk_link($sub_fold, $sub_file, $uq_link_addr, $lnum, $link, $line);
+ }
+} # walk_link
+
+
+
+
+############################################
+### Some more checks!
+############################################
+sub check_external_anchors() {
+ &$m_subReport("\nChecking external anchors...\n");
+ for my $f (sort keys %m_CheckedLinks) {
+ my $fnode = $m_CheckedLinks{$f};
+ if (exists ${$fnode}{"EXTANC"}) {
+ my $extanc_hash = ${$fnode}{"EXTANC"};
+ for my $fx (keys %$extanc_hash) {
+ next unless (exists $m_CheckedLinks{$fx});
+ my $ea_hash = ${$extanc_hash}{$fx};
+ my $ea = ${$ea_hash}{ANC};
+ my $fxnode = $m_CheckedLinks{$fx};
+ my $fx_anc_hash = ${$fxnode}{"ANC"};
+ if (!exists ${$fx_anc_hash}{$ea}) {
+ my $line = ${$ea_hash}{LINE};
+ my $lnum = ${$ea_hash}{LNUM};
+ &$m_subReport("From $f\n");
+ tell_bad_link("Ext anchor not found ($fx#$ea)",
+ $f, $lnum, "$fx#$ea", $line);
+ }
+ }
+ }
+ }
+} # check_external_anchors
+
+
+
+#############################
+### Reporting
+#############################
+sub report_errors($$) {
+ my $bSum = shift;
+ my $bDet = shift;
+ my $errors_reported;
+ my $errors_found;
+ for my $f (sort keys %m_CheckedLinks) {
+ my $fnode = $m_CheckedLinks{$f};
+ if (exists ${$fnode}{ERR}) {
+ $errors_found = 1;
+ last unless $bSum;
+ if (!defined $errors_reported) {
+ $errors_reported = 1;
+ &$m_subReport("\n\n*********** Summary ERRORS and WARNINGS **********\n");
+ }
+ &$m_subReport("$f\n");
+ my $err_hash = ${$fnode}{ERR};
+ for my $e (sort keys %$err_hash) {
+ my $refE = ${$err_hash}{$e};
+ &$m_subReport("\t" . ${$refE}[0] . "\n");
+ }
+ }
+ }
+ undef $errors_reported;
+ if ($bDet) {
+ for my $f (sort keys %m_CheckedLinks) {
+ my $fnode = $m_CheckedLinks{$f};
+ if (exists ${$fnode}{ERR}) {
+ if (!defined $errors_reported) {
+ $errors_reported = 1;
+ &$m_subReport("\n\n*********** Detailed ERRORS and WARNINGS **********\n");
+ }
+ &$m_subReport("$f\n");
+ my $err_hash = ${$fnode}{ERR};
+ for my $e (sort keys %$err_hash) {
+ my $refE = ${$err_hash}{$e};
+ &$m_subReport("\tat line $e: " . ${$refE}[1] . "\n");
+ }
+ }
+ }
+ }
+ if ($errors_found) {
+ die "\n*** There where errors ***\n";
+ } else {
+ &$m_subReport("No errors found\n");
+ }
+} # report_errors
+
+sub dump_response($) {
+ my $response = shift;
+ &$m_subReport( $response->code . " " . $response->message . "\n");
+ &$m_subReport( "****************************************\n");
+ #&$m_subReport( $response->request . "\n");
+ #&$m_subReport( "****************************************\n");
+ #&$m_subReport( $response->previous . "\n");
+ #&$m_subReport( "****************************************\n");
+ &$m_subReport( " i=" . $response->is_info .
+ ", s=" . $response->is_success .
+ ", r=" . $response->is_redirect .
+ ", e=" . $response->is_error . "\n");
+ &$m_subReport( "****************************************\n");
+ &$m_subReport( "content: " . $response->content . "\n");
+ &$m_subReport( "****************************************\n");
+ &$m_subReport( "base: " . $response->base . "\n");
+ &$m_subReport( "****************************************\n");
+ &$m_subReport( $response->as_string);
+ &$m_subReport( "****************************************\n");
+ &$m_subReport( $response->current_age . "\n");
+ &$m_subReport( "****************************************\n");
+ my @rh = $response->header("Content-Type");
+ for my $r (@rh) { &$m_subReport( "ct: $r\n"); }
+ &$m_subReport( "****************************************\n");
+} # dump_response
+
+
+#############################
+### Parameters
+#############################
+sub sMirrorRoot() {
+ my $val = shift;
+ $m_sMirrorRoot = PathSubs::get_temp_path() . "LinkWalker/" unless defined $m_sMirrorRoot;
+ my $old = $m_sMirrorRoot;
+ $m_sMirrorRoot = PathSubs::uniq_dir($val) if defined $val;
+ return $old;
+}
+sub bMirror(;$) {
+ my $val = shift;
+ my $old = $m_bMirror;
+ $m_bMirror = $val if defined $val;
+ $old;
+}
+
+sub subReporter(;$) {
+ my $val = shift;
+ my $old = $m_subReport;
+ $m_subReport = $val if defined $val;
+ $old
+}
+sub subAction(;$) {
+ my $val = shift;
+ my $old = $m_subAction;
+ $m_subAction = $val if defined $val;
+ $old
+}
+sub bOnlyCont(;$) {
+ my $val = shift;
+ my $old = $m_bOnlyCont;
+ $m_bOnlyCont = $val if defined $val;
+ $old
+}
+sub ua_personality(;$) {
+ my $val = shift;
+ my $old = $m_ua_personality;
+ $m_ua_personality = $val if defined $val;
+ $old
+}
+
+sub clear_roots() { @m_sLinkRoots = (); }
+sub get_roots() { return \@m_sLinkRoots; }
+sub add_root($) { push @m_sLinkRoots, shift; }
+sub add_files_root($) {
+ my $file = shift;
+ my $default_root;
+ my ($host) = ($file =~ m!(^https?://[^/]*)!i);
+ if (defined $host) {
+ $default_root = $file;
+ } else {
+ die "Can't find $file\n" unless -e $file;
+ $default_root = PathSubs::uniq_file($file);
+ }
+ $default_root =~ s![^/]*$!!;
+ add_root($default_root);
+}
+
+### Default actions
+sub default_sub {}
+$m_subReport = \&default_sub;
+$m_subAction = \&default_sub;
+$m_subMirrorAction = \&default_sub;
+
+1;
|