[Dehs-devel] SVN devscripts commit: r459 - in trunk: . debian

[Julian Gilbey]

Author: jdg
Date: 2006-11-06 03:36:09 +0100 (Mon, 06 Nov 2006)
New Revision: 459

Modified:
   trunk/debian/changelog
   trunk/uscan.pl
Log:
* uscan: fix handling of ftp directory listings with number-only
  directory names (Closes: #372609)

Modified: trunk/debian/changelog
===================================================================
--- trunk/debian/changelog	2006-11-05 16:42:08 UTC (rev 458)
+++ trunk/debian/changelog	2006-11-06 02:36:09 UTC (rev 459)
@@ -6,9 +6,11 @@
     dpkg-source does (Closes: #366286)
   * dget: introduce --insecure option for allowing downloading from site
     with self-signed certificate (Closes: #393942)
+  * uscan: fix handling of ftp directory listings with number-only
+    directory names (Closes: #372609)
   * uupdate: handle ~ in version numbers (Closes: #397100)
 
- -- Julian Gilbey <jdg at debian.org>  Sun,  5 Nov 2006 16:42:02 +0000
+ -- Julian Gilbey <jdg at debian.org>  Mon,  6 Nov 2006 02:35:55 +0000
 
 devscripts (2.9.22) unstable; urgency=low
 

Modified: trunk/uscan.pl
===================================================================
--- trunk/uscan.pl	2006-11-05 16:42:08 UTC (rev 458)
+++ trunk/uscan.pl	2006-11-06 02:36:09 UTC (rev 459)
@@ -823,17 +823,32 @@
 	# so we may have to look for <a href="filename"> type patterns
 	print STDERR "$progname debug: matching pattern $pattern\n" if $debug;
 	my (@files);
-	$content =~ s/\n/ \n/g; # make every filename have an extra
-	                        # space after it in a normal FTP listing
-	while ($content =~
-	           m&(?:<\s*a\s+[^>]*href\s*=\s*\"| )($pattern)(\"| )&gi) {
-	    my $file = $1;
-	    my $mangled_version = join(".", $file =~ m/^$pattern$/);
-	    foreach my $pat (@{$options{'uversionmangle'}}) {
-		eval "\$mangled_version =~ $pat;";
+
+	# We separate out HTMLised listings from standard listings, so
+	# that we can target our search correctly
+	if (/<\s*a\s+[^>]*href/i) {
+	    while ($content =~ 
+		m/(?:<\s*a\s+[^>]*href\s*=\s*\")($pattern)\"/gi) {
+		my $file = $1;
+		my $mangled_version = join(".", $file =~ m/^$pattern$/);
+		foreach my $pat (@{$options{'uversionmangle'}}) {
+		    eval "\$mangled_version =~ $pat;";
+		}
+		push @files, [$mangled_version, $file];
 	    }
-	    push @files, [$mangled_version, $file];
-	}
+	} else {
+	    # they all look like:
+	    # info info ... info filename [ -> linkname]
+	    while ($content =~ m/($filepattern)(\s+->\s+\S+)?$/mgi) {
+		my $file = $1;
+		my $mangled_version = join(".", $file =~ m/^$filepattern$/);
+		foreach my $pat (@{$options{'uversionmangle'}}) {
+		    eval "\$mangled_version =~ $pat;";
+		}
+		push @files, [$mangled_version, $file];
+	    }
+	}	    
+
 	if (@files) {
 	    if ($verbose) {
 		print "-- Found the following matching files:\n";
@@ -1268,18 +1283,29 @@
 	# so we may have to look for <a href="filename"> type patterns
 	print STDERR "$progname debug: matching pattern $pattern\n" if $debug;
 	my (@dirs);
-	$content =~ s/\n/ \n/g; # make every filename have an extra
-	                        # space after it in a normal FTP listing
-	while ($content =~
-	       m/(?:<\s*a\s+[^>]*href\s*=\s*\"| )($pattern)(\"| )/gi) {
-	    my $dir = $1;
-	    my $mangled_version = join(".", $dir =~ m/^$pattern$/);
-	    push @dirs, [$mangled_version, $dir];
-	}
+
+	# We separate out HTMLised listings from standard listings, so
+	# that we can target our search correctly
+	if (/<\s*a\s+[^>]*href/i) {
+	    while ($content =~ 
+		m/(?:<\s*a\s+[^>]*href\s*=\s*\")($pattern)\"/gi) {
+		my $dir = $1;
+		my $mangled_version = join(".", $dir =~ m/^$pattern$/);
+		push @dirs, [$mangled_version, $dir];
+	    }
+	} else {
+	    # they all look like:
+	    # info info ... info filename [ -> linkname]
+	    while ($content =~ m/($pattern)(\s+->\s+\S+)?$/mgi) {
+		my $dir = $1;
+		my $mangled_version = join(".", $dir =~ m/^$pattern$/);
+		push @dirs, [$mangled_version, $dir];
+	    }
+	}	    
 	if (@dirs) {
 	    if ($debug) {
-		print "-- Found the following matching dirs:\n";
-		foreach my $dir (@dirs) { print "     $$dir[1]\n"; }
+		print STDERR "-- Found the following matching dirs:\n";
+		foreach my $dir (@dirs) { print STDERR "     $$dir[1]\n"; }
 	    }
 	    @dirs = Devscripts::Versort::versort(@dirs);
 	    my ($newversion, $newdir) = @{$dirs[0]};