perl/modules/W3C/LinkChecker/bin checklink,4.161,4.162

Update of /sources/public/perl/modules/W3C/LinkChecker/bin
In directory hutz:/tmp/cvs-serv15790

Modified Files:
	checklink 
Log Message:
User bug report (hash key was Suppress..., shourd have been Suppress...)
led me to rewrites, shorten, & optimize redirect checking.


Index: checklink
===================================================================
RCS file: /sources/public/perl/modules/W3C/LinkChecker/bin/checklink,v
retrieving revision 4.161
retrieving revision 4.162
diff -u -d -r4.161 -r4.162
--- checklink	29 Jun 2009 20:14:38 -0000	4.161
+++ checklink	4 Jul 2009 03:45:57 -0000	4.162
@@ -395,6 +395,7 @@
     Exclude_Docs      => undef,
     Suppress_Redirect => [],
     Suppress_Redirect_Prefix => [],
+    Suppress_Redirect_Regexp => [],
     Suppress_Broken   => [],
     Suppress_Fragment => [],
     Masquerade        => 0,
@@ -701,9 +702,11 @@
     }
   }
   for my $srp_arg (@{$Opts{Suppress_Redirect_Prefix}}) {
-    if ($srp_arg !~ /.->./) {
+    if ($srp_arg !~ /^(.*)->(.*)$/) {
       &usage(1, "Bad suppress-redirect-prefix argument, should contain \"->\": $srp_arg");
     }
+    # Turn prefixes into a regexp.
+    push @{$Opts{Suppress_Redirect_Regexp}}, qr/^\Q$1\E(.*)->\Q$2\E\1$/ism;
   }
   for my $sb_arg (@{$Opts{Suppress_Broken}}) {
     if ($sb_arg !~ /^(-1|[0-9]+):./) {
@@ -1932,37 +1935,12 @@
     my $to = $response->request()->url(); # same on every loop iteration
     my $from_to = $from . '->' . $to;
     my $match = grep { $_ eq $from_to } @{$Opts{Suppress_Redirect}};
-    # print STDERR "Result $match of checking $from_to\n";
+    # print STDERR "Result $match of redirect checking $from_to\n";
     if ($match) { next; }
 
-    # Check for redirect_prefix match
-    my $prefix_match = 0;
-    my $from_len = length($from);
-    my $to_len = length($to);
-    for my $redir_prefix (@{$Opts{Suppresss_Redirect_Prefix}}) {
-      if ($redir_prefix !~ /^(.*)->(.*)$/) {
-        die "Bad suppress-redirect-prefix: $redir_prefix";
-      }
-      my $from_prefix = $1;
-      my $to_prefix = $2;
-      my $from_prefix_len = length($from_prefix);
-      my $to_prefix_len = length($to_prefix);
-      if (($from eq $from_prefix) && ($to eq $to_prefix)) {
-        $prefix_match = 1;
-        last;
-      } elsif (($from_prefix_len < $from_len)
-                 && ($to_prefix_len < $to_len)
-                 && ($from_prefix eq substr($from, 0, $from_prefix_len))
-                 && ($to_prefix eq substr($to, 0, $to_prefix_len))
-                 && (substr($from, $from_prefix_len) eq substr($to, $to_prefix_len))) {
-        $prefix_match = 1;
-        last;
-      }
-    }
-    if ($prefix_match) {
-      # print STDERR "A SUPPRESSED REDIRECT:\n  $from\n  $to\n";
-      next;
-    }
+    $match = grep { $from_to =~ /$_/ } @{$Opts{Suppress_Redirect_Regexp}};
+    # print STDERR "Result $match of regexp checking $from_to\n";
+    if ($match) { next; }
 
     $redirects->{$prev->request()->url()} = $response->request()->url();
   }

Received on Saturday, 4 July 2009 03:46:11 UTC