SVN: toys/rsget.pl: README RSGet/Dispatch.pm RSGet/FileList.pm RSGet/ListManager.pm RSGet/Processor....

[sparky]

Author: sparky
Date: Wed Oct  7 23:24:52 2009
New Revision: 10719

Modified:
   toys/rsget.pl/README
   toys/rsget.pl/RSGet/Dispatch.pm
   toys/rsget.pl/RSGet/FileList.pm
   toys/rsget.pl/RSGet/ListManager.pm
   toys/rsget.pl/RSGet/Processor.pm
Log:
- unify links


Modified: toys/rsget.pl/README
==============================================================================
--- toys/rsget.pl/README	(original)
+++ toys/rsget.pl/README	Wed Oct  7 23:24:52 2009
@@ -1,7 +1,6 @@
 
 TODO:
 - Write more documentation
-- Add hooks to allow unifying URIs before adding them to the list
 
 
 Features:

Modified: toys/rsget.pl/RSGet/Dispatch.pm
==============================================================================
--- toys/rsget.pl/RSGet/Dispatch.pm	(original)
+++ toys/rsget.pl/RSGet/Dispatch.pm	Wed Oct  7 23:24:52 2009
@@ -252,6 +252,17 @@
 	return undef;
 }
 
+sub unigetter
+{
+	my $uri = shift;
+	my $getter = getter( $uri );
+	if ( $getter ) {
+		my $unify = $getter->{unify};
+		$uri = &$unify( $uri );
+		return $getter, $uri;
+	}
+	return undef, $uri;
+}
 
 
 1;

Modified: toys/rsget.pl/RSGet/FileList.pm
==============================================================================
--- toys/rsget.pl/RSGet/FileList.pm	(original)
+++ toys/rsget.pl/RSGet/FileList.pm	Wed Oct  7 23:24:52 2009
@@ -151,8 +151,8 @@
 				next;
 			} elsif ( m{^(http://)?(.*?)$} ) {
 				my $proto = $1 || "http://";
-				my $uri = $proto . $2;
-				if ( my $getter = RSGet::Dispatch::getter($uri) ) {
+				my ( $getter, $uri ) = RSGet::Dispatch::unigetter( $proto . $2 );
+				if ( $getter ) {
 					$options = {};
 					$decoded{ $uri } = [ $getter, $options ];
 					next;

Modified: toys/rsget.pl/RSGet/ListManager.pm
==============================================================================
--- toys/rsget.pl/RSGet/ListManager.pm	(original)
+++ toys/rsget.pl/RSGet/ListManager.pm	Wed Oct  7 23:24:52 2009
@@ -328,7 +328,8 @@
 				$uri =~ s/\Q$l\E.*//;
 			}
 		}
-		my $getter = RSGet::Dispatch::getter( $uri );
+
+		(my $getter, $uri) = RSGet::Dispatch::unigetter( $uri );
 		next unless $getter;
 		next if exists $all_uris{ $uri };
 		$all_uris{ $uri } = 1;
@@ -402,8 +403,8 @@
 
 				if ( my $links = $save->{links} ) {
 					my @new;
-					foreach my $uri ( @$links ) {
-						my $getter = RSGet::Dispatch::getter( $uri );
+					foreach my $luri ( @$links ) {
+						my ($getter, $uri) = RSGet::Dispatch::unigetter( $luri );
 						if ( $getter ) {
 							push @new, { cmd => "ADD", globals => {}, uris => { $uri => [ $getter, {} ] } };
 						} else {

Modified: toys/rsget.pl/RSGet/Processor.pm
==============================================================================
--- toys/rsget.pl/RSGet/Processor.pm	(original)
+++ toys/rsget.pl/RSGet/Processor.pm	Wed Oct  7 23:24:52 2009
@@ -6,7 +6,6 @@
 set_rev qq$Id$;
 
 my $options = "name|short|slots|cookie|status|min_ver";
-my $parts = "pre|start|perl";
 
 my $processed = "";
 sub pr(@)
@@ -74,10 +73,13 @@
 		uri => [],
 	);
 	my %parts = (
+		unify => [],
 		pre => [],
 		start => [],
 		perl => [],
 	);
+	my $parts = join "|", keys %parts;
+
 	my $part = undef;
 	while ( <F_IN> ) {
 		chomp;
@@ -141,6 +143,8 @@
 	$opts{uri} = [ map { eval $_ } @{$opts{uri}} ];
 	$opts{class} = ${class};
 	$opts{pkg} = "${class}::$opts{name}";
+	$opts{unify} = join "\n", @{ $parts{unify} };
+	$opts{unify} ||= 's/#.*//; s{/$}{};';
 
 	pr "package $opts{pkg};\n\n";
 	pr <<'EOF';
@@ -225,17 +229,20 @@
 	p_subend();
 
 	pr @{$parts{perl}};
-	pr "1;";
 
-	my $ret;
+	pr "\npackage $opts{pkg};\n";
+	pr "sub unify { local \$_ = shift; $opts{unify};\nreturn \$_;\n};\n";
+	pr '\&unify;';
+
+	my $unify;
 	{
 		local $SIG{__DIE__};
 		delete $SIG{__DIE__};
-		$ret = eval $processed;
+		$unify = eval $processed;
 	}
 
 	if ( $@ ) {
-		p "Error(s): $@\n";
+		p "Error(s): $@";
 		return undef unless verbose( 1 );
 		my $err = $@;
 		return undef unless $err =~ /line \d+/;
@@ -249,8 +256,14 @@
 		}
 		return undef;
 	}
+	if ( not $unify or not ref $unify or ref $unify ne "CODE" ) {
+		my $ru = ref $unify || "undef";
+		p "Error: invalid, unify returned '$ru'";
+		return undef;
+	}
+	$opts{unify} = $unify;
 
-	return $opts{pkg} => \%opts if $ret and $ret == 1;
+	return $opts{pkg} => \%opts;
 	return ();
 }