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 ();
}
_______________________________________________
pld-cvs-commit mailing list
[email protected]
http://lists.pld-linux.org/mailman/listinfo/pld-cvs-commit
