SVN: toys/rsget.pl/RSGet: Dispatch.pm Get.pm ListManager.pm
sparky
sparky at pld-linux.org
Fri Sep 11 18:49:51 CEST 2009
Author: sparky
Date: Fri Sep 11 18:49:51 2009
New Revision: 10561
Added:
toys/rsget.pl/RSGet/ListManager.pm
Modified:
toys/rsget.pl/RSGet/Dispatch.pm
toys/rsget.pl/RSGet/Get.pm
Log:
- added ListManager to manage entries on the list, Dispatch only starts downloads
Modified: toys/rsget.pl/RSGet/Dispatch.pm
==============================================================================
--- toys/rsget.pl/RSGet/Dispatch.pm (original)
+++ toys/rsget.pl/RSGet/Dispatch.pm Fri Sep 11 18:49:51 2009
@@ -5,22 +5,14 @@
use RSGet::Tools;
our %downloading;
-our %downloaded;
our %checking;
-our %checked; # HASH for valid, SCALAR if error
our %resolving;
-our %resolved;
my %working = (
get => \%downloading,
check => \%checking,
link => \%resolving,
);
-my %finished = (
- get => \%downloaded,
- check => \%checked,
- link => \%resolved,
-);
my @interfaces;
sub add_interface
@@ -99,27 +91,6 @@
$lu->{$if} = time;
}
-sub is_error
-{
- my $uri = shift;
- my $c = $checked{ $uri };
- return undef unless defined $c;
- if ( $c and not ref $c ) {
- return $c;
- }
- return 0;
-}
-sub is_ok
-{
- my $uri = shift;
- my $c = $checked{ $uri };
- return undef unless defined $c;
- if ( $c and ref $c and ref $c eq "HASH" ) {
- return $c;
- }
- return 0;
-}
-
sub finished
{
my $obj = shift;
@@ -129,12 +100,8 @@
my $working = $working{ $cmd };
delete $working->{ $uri };
- if ( $status ) {
- my $finished = $finished{ $cmd };
- $finished->{ $uri } = $status;
- }
- $RSGet::FileList::reread = 1;
+ RSGet::FileList::update();
}
sub run
@@ -142,82 +109,119 @@
my ( $cmd, $uri, $getter, $options ) = @_;
my $class = $getter->{class};
$cmd = "link" if $class eq "Link";
- #p "run( $cmd, $uri, ... )";
- my $finished = $finished{ $cmd };
- my $f = $finished->{ $uri };
- return $f if defined $f;
- #p "-> not finished";
+ return if $options->{error};
my $working = $working{ $cmd };
my $w = $working->{ $uri };
return $w if defined $w;
- #p "-> not working";
my $pkg = $getter->{pkg};
my $outif = find_free_if( $pkg, $working, ($cmd eq "get" ? ($getter->{slots} || 1) : 5) );
return unless defined $outif;
- #p "-> got if";
my $obj = RSGet::Get::new( $pkg, $cmd, $uri, $options, $outif );
$working->{ $uri } = $obj if $obj;
- #p "run( $cmd, $uri, ... ) -> $obj" if $obj;
- $RSGet::FileList::reread = 1;
-
return $obj;
}
+sub check
+{
+ my $uri = shift;
+ my $getter = shift;
+ my $options = shift;
+
+ return $options if $options->{error};
+ if ( $getter->{class} eq "Link" ) {
+ return $options if $options->{link1};
+ } else {
+ return $options if $options->{size} or $options->{asize};
+ }
+
+ run( "check", $uri, $getter, $options );
+ return undef;
+}
+
sub process
{
my $getlist = shift;
my %num_by_pkg;
my %all_uris;
+ my $to_dl = 0;
foreach my $line ( @$getlist ) {
- my ( $uris, $options ) = @$line;
+ next unless ref $line;
+ my $uris = $line->{uris};
+ my $cmd = $line->{cmd};
+
+ if ( $cmd eq "STOP" ) {
+ foreach my $uri ( keys %$uris ) {
+ if ( my $obj = $downloading{$uri} ) {
+ $obj->{_abort} = "Stopped";
+ }
+ }
+ next;
+ }
+ next unless $cmd eq "GET";
+
+ $to_dl++;
foreach my $uri ( keys %$uris ) {
- my $getter = $uris->{ $uri };
+ my ( $getter, $opts ) = @{ $uris->{ $uri } };
+ if ( $opts->{error} ) {
+ if ( my $obj = $downloading{$uri} ) {
+ $obj->{_abort} = "Stopped";
+ }
+ next;
+ }
$all_uris{ $uri } = 1;
my $pkg = $getter->{pkg};
$num_by_pkg{ $pkg } ||= 0;
$num_by_pkg{ $pkg }++;
}
}
- abort_missing( \%all_uris, $_ ) foreach values %working;
+
+ abort_missing( \%all_uris, \%downloading );
RSGet::Line::status(
- 'to download' => scalar @$getlist,
+ 'to download' => $to_dl,
'downloading' => scalar keys %downloading,
'resolving links' => scalar keys %resolving,
'checking URIs' => scalar keys %checking,
);
- my $all_valid = 1;
- foreach my $line ( @$getlist ) {
- my ( $uris, $options ) = @$line;
+ my $all_checked = 1;
+ EACH_LINE: foreach my $line ( @$getlist ) {
+ next unless ref $line;
+
+ my ( $cmd, $globals, $uris ) = @$line{ qw(cmd globals uris) };
+ next if $cmd eq "DONE";
+
+ my %pkg_by_uri;
+
foreach my $uri ( keys %$uris ) {
- my $getter = $uris->{ $uri };
- my $ok = is_ok( $uri );
- #p "$uri - $ok";
- if ( not defined $ok ) {
- run( "check", $uri, $getter, $options );
- $all_valid = 0;
- } elsif ( not $ok ) {
- $all_valid = 0;
- }
+ my ( $getter, $options ) = @{ $uris->{ $uri } };
+ $pkg_by_uri{ $uri } = $getter->{pkg};
+ my $chk = check( $uri, $getter, { %$options, %$globals } );
+ $all_checked = 0 unless $chk;
}
- next unless $all_valid;
+ next unless $all_checked;
+ next unless $cmd eq "GET";
+
+ # is it running already ?
+ foreach my $uri ( keys %$uris ) {
+ next EACH_LINE if $working{get}->{ $uri };
+ }
foreach my $uri ( sort {
- my $a_pkg = $uris->{ $a }->{pkg};
- my $b_pkg = $uris->{ $b }->{pkg};
- $num_by_pkg{ $a_pkg } <=> $num_by_pkg{ $b_pkg }
+ $num_by_pkg{ $pkg_by_uri{ $a} } <=> $num_by_pkg{ $pkg_by_uri{ $b } }
} keys %$uris ) {
- my $getter = $uris->{ $uri };
- last if run( "get", $uri, $getter, $options );
+ my ( $getter, $options ) = @{ $uris->{ $uri } };
+ next EACH_LINE if run( "get", $uri, $getter, { %$options, %$globals } );
}
}
+
+ return $all_checked;
}
sub abort_missing
@@ -225,24 +229,21 @@
my $all = shift;
my $running = shift;
foreach ( keys %$running ) {
- next if exists $all->{$_};
+ next if $all->{$_};
my $obj = $running->{$_};
- $obj->{_abort} = "Removed from the list!";
+ $obj->{_abort} = "Stopped or removed from the list!";
}
}
-sub done
+sub getter
{
my $uri = shift;
- my $getter = shift;
+ my @g = grep { $uri =~ m/^http:\/\/(:?www\.)?$_->{uri}/ } values %getters;
+ return undef unless @g;
+ return $g[0];
+}
- my $class = $getter->{class};
- my $cmd = $class eq "Link" ? "link" : "get";
- my $f = $finished{ $cmd }->{ $uri };
- return $f if defined $f;
- return undef;
-}
1;
Modified: toys/rsget.pl/RSGet/Get.pm
==============================================================================
--- toys/rsget.pl/RSGet/Get.pm (original)
+++ toys/rsget.pl/RSGet/Get.pm Fri Sep 11 18:49:51 2009
@@ -9,7 +9,11 @@
sub make_cookie
{
my $c = shift;
+ my $cmd = shift;
return () unless $c;
+ unless ( $c =~ s/^!// ) {
+ return if $cmd eq "check";
+ }
$cookies{ $c } = 1 unless $cookies{ $c };
my $n = $cookies{ $c }++;
@@ -31,16 +35,18 @@
_cmd => $cmd,
_pkg => $pkg,
_outif => $outif,
- make_cookie( $getter->{cookie} ),
+ make_cookie( $getter->{cookie}, $cmd ),
};
bless $self, $pkg;
+ $self->bestinfo();
- if ( $cmd eq "get" ) {
+ if ( $settings{logging} > 1 or $cmd eq "get" ) {
my $outifstr = $outif ? "[$outif]" : "";
+
hadd $self,
- _line => new RSGet::Line( "[$getter->{short}]$outifstr " ),
- _name => $options->{fname} || ($uri =~ m{([^/]+)/*$})[0];
+ _line => new RSGet::Line( "[$getter->{short}]$outifstr " );
$self->print( "start" );
+ $self->linedata();
}
$self->start();
@@ -67,6 +73,22 @@
new RSGet::Line( "[$getter->{short}]$outifstr ", $self->{_name} . ": " . $text );
}
+sub search
+{
+ my $self = shift;
+ my %search = @_;
+
+ foreach my $name ( keys %search ) {
+ my $search = $search{$name};
+ if ( m/$search/ ) {
+ $self->{$name} = $1;
+ } else {
+ $self->problem( "Can't find '$name': $search" );
+ return 1;
+ }
+ }
+ return 0;
+}
sub print
{
@@ -77,6 +99,36 @@
$line->print( $self->{_name} . ": " . $text );
}
+sub linedata
+{
+ my $self = shift;
+ my @data = @_;
+ my $line = $self->{_line};
+ return unless $line;
+
+ my %data = (
+ name => $self->{bestname},
+ size => $self->{bestsize},
+ uri => $self->{_uri},
+ @data,
+ );
+
+ $line->linedata( \%data );
+}
+
+sub start
+{
+ my $self = shift;
+
+ foreach ( keys %$self ) {
+ delete $self->{$_} unless /^_/;
+ }
+ delete $self->{_referer};
+ $self->bestinfo();
+
+ return $self->stage0();
+}
+
sub get
{
my $self = shift;
@@ -113,13 +165,13 @@
my $time = shift || 1;
my $msg = shift || "restarting";
- return $self->wait( \&start, $time, $msg );
+ return $self->wait( \&start, $time, $msg, "restart" );
}
sub multi
{
my $self = shift;
- return $self->wait( 60 + 240 * rand, \&start, "multi-download not allowed, waiting" );
+ return $self->wait( \&start, -60 - 240 * rand, "multi-download not allowed", "multi" );
}
sub finish
@@ -133,7 +185,8 @@
}
RSGet::Dispatch::mark_used( $self );
- RSGet::Dispatch::finished( $self, $self->{dlinfo} );
+ RSGet::FileList::save( $self->{_uri}, cmd => "DONE" );
+ RSGet::Dispatch::finished( $self );
}
sub abort
@@ -147,7 +200,7 @@
{
my $self = shift;
my $msg = shift;
- if ( $self->{body} ) {
+ if ( $self->{body} and $settings{errorlog} ) {
my $n = 0;
my $name;
do {
@@ -160,15 +213,9 @@
$msg .= "; saved $name";
}
- $self->print( $msg );
- RSGet::Dispatch::finished( $self, $msg );
-}
-
-sub start
-{
- my $self = shift;
- $self->clean();
- return $self->stage0();
+ $self->print( $msg ) || $self->log( $msg );
+ RSGet::FileList::save( $self->{_uri}, options => { error => $msg } );
+ RSGet::Dispatch::finished( $self );
}
sub problem
@@ -176,72 +223,85 @@
my $self = shift;
my $line = shift;
my $msg = $line ? "problem at line: $line" : "unknown problem";
- if ( ++$self->{_try} < 8 ) {
- return $self->wait( \&start, 2 ** $self->{_try}, $msg . ", waiting" );
+ my $retry = 8;
+ $retry = 3 if $self->{_cmd} eq "check";
+ if ( ++$self->{_try} < $retry ) {
+ return $self->wait( \&start, -2 ** $self->{_try}, $msg, "problem" );
} else {
return $self->error( $msg . ", aborting" );
}
}
-sub clean
+sub bestinfo
{
my $self = shift;
- foreach ( keys %$self ) {
- delete $self->{$_} unless /^_/;
+ my $o = $self->{_opts};
+ my $i = $self->{info};
+
+ my $bestname = $o->{fname}
+ || $i->{name} || $i->{iname}
+ || $i->{aname} || $i->{ainame}
+ || $o->{name} || $o->{iname}
+ || $o->{aname} || $o->{ainame};
+ unless ( $bestname ) {
+ my $uri = $self->{_uri};
+ $bestname = ($uri =~ m{([^/]+)/*$})[0] || $uri;
}
- delete $self->{_referer};
+ $self->{bestname} = $bestname;
+ $bestname =~ s/\0/(?)/;
+ $self->{_name} = $bestname;
+
+ my $bestsize = $o->{fsize}
+ || $i->{size} || $i->{asize}
+ || $o->{size} || $o->{asize}
+ || "?";
+ $self->{bestsize} = $bestsize;
}
sub info
{
my $self = shift;
my %info = @_;
- $info{name} = de_ml( $info{name} );
- $info{kilo} ||= 1024;
+ $info{asize} =~ s/ //g if $info{asize};
+ RSGet::FileList::save( $self->{_uri}, options => \%info );
+
+ $self->{info} = \%info;
+ $self->bestinfo();
- $self->{_name} = $self->{_opts}->{fname} || $info{name};
return 0 unless $self->{_cmd} eq "check";
- #p "info( $self->{_uri} ): $info{name}, $info{size}\n";
- RSGet::Dispatch::finished( $self, \%info );
+ p "info( $self->{_uri} ): $self->{bestname} ($self->{bestsize})\n"
+ if $settings{logging} > 0;
+ RSGet::Dispatch::finished( $self );
return 1;
}
-sub search
-{
- my $self = shift;
- my %search = @_;
-
- foreach my $name ( keys %search ) {
- my $search = $search{$name};
- if ( m/$search/ ) {
- $self->{$name} = $1;
- } else {
- $self->problem( "Can't find '$name': $search" );
- return 1;
- }
- }
- return 0;
-}
-
sub link
{
my $self = shift;
- my $links = [ @_ ];
- RSGet::Dispatch::finished( $self, $links );
+ my %links;
+ my $i = 0;
+ foreach ( @_ ) {
+ $links{ "link" . ++$i } = $_;
+ }
+ RSGet::FileList::save( $self->{_uri}, cmd => "DONE",
+ links => [ @_ ], options => \%links );
+ RSGet::Dispatch::finished( $self );
return 1;
}
-sub set_fname
+sub set_finfo
{
my $self = shift;
my $fname = shift;
- $self->{_name} = $fname;
-
- my $opts = $RSGet::FileList::uri_options{ $self->{_uri} } ||= {};
- hadd $opts,
- fname => $fname;
-
- $RSGet::FileList::reread = 1;
+ my $fsize = shift;
+ my $o = $self->{_opts};
+ $o->{fname} = $fname;
+ $o->{fsize} = $fsize;
+ $self->bestinfo();
+
+ RSGet::FileList::save( $self->{_uri},
+ globals => { fname => $fname, fsize => $fsize } );
+ RSGet::FileList::update();
}
my %waiting;
@@ -249,8 +309,11 @@
{
my $self = shift;
my $next_stage = shift;
- my $wait = shift() + int rand 10;
+ my $wait = shift;
my $msg = shift || "???";
+ my $reason = shift || "wait";
+
+ $self->linedata( wait => $reason );
my $time = time;
delete $self->{wait_until_should};
@@ -260,6 +323,8 @@
$self->{wait_until_should} = $time + $wait;
$wait = $rnd_wait;
}
+ $wait = - $wait if $wait < 0;
+ $wait += int rand 10;
$self->{wait_next} = $next_stage;
$self->{wait_msg} = $msg;
@@ -277,6 +342,7 @@
delete $self->{body};
$_ = undef;
+ $self->linedata();
my $func = $self->{wait_next};
&$func( $self );
}
Added: toys/rsget.pl/RSGet/ListManager.pm
==============================================================================
--- (empty file)
+++ toys/rsget.pl/RSGet/ListManager.pm Fri Sep 11 18:49:51 2009
@@ -0,0 +1,599 @@
+package RSGet::ListManager;
+
+use strict;
+use warnings;
+#use diagnostics;
+use RSGet::Tools;
+use RSGet::FileList;
+use RSGet::Dispatch;
+use URI::Escape;
+use POSIX qw(ceil floor);
+
+# {{{ Comparators
+
+# Compare two ranges in form:
+# $r1 = [ $min1, $max1 ]
+# Returns 0 if ranges intersect, -1 if first is smaller, 1 if first is larger
+sub cmp_range
+{
+ my ($a, $b) = @_;
+ @$a = reverse @$a if $a->[0] > $a->[1];
+ @$b = reverse @$b if $b->[0] > $b->[1];
+ return -1 if $a->[1] < $b->[0];
+ return 1 if $b->[1] < $a->[0];
+ return 0;
+}
+
+# Express aproximate file size as range of possible file sizes in bytes
+# 1 kb = [512, 2048]
+# 1.0 kb = [972, 1127]
+sub size_to_range
+{
+ local $_ = lc shift;
+ my $kilo = shift || 1024;
+
+ s/\s*b(ytes?)?$//;
+ return [+$1, +$1 + 1] if /^\s*(\d+)\s*$/;
+
+ return undef unless /^(\d+)([\.,](\d+))?\s*([kmg])$/;
+ my ($int, $frac, $mult) = ($1, $3, $4);
+ my $one = 1;
+ my $num = + $int;
+ if ( defined $frac ) {
+ $one = 10 ** (- length $frac);
+ $num = + "$int.$frac";
+ }
+ my $mult_by = 1;
+ if ( $mult eq "k" ) {
+ $mult_by = $kilo;
+ } elsif ( $mult eq "m" ) {
+ $mult_by = $kilo * $kilo;
+ } elsif ( $mult eq "g" ) {
+ $mult_by = $kilo * $kilo * $kilo;
+ }
+
+ my $min = floor( ($num - $one / 2) * $mult_by );
+ my $max = ceil( ($num + $one) * $mult_by );
+
+ return [$min, $max];
+}
+
+
+# compare two strings where both may contain wildcards
+my $wildcard = ord "\0";
+sub eq_name
+{
+ my $a_string = shift;
+ my $b_string = shift;
+
+ my @a = map ord, split //, $a_string;
+ my @b = map ord, split //, $b_string;
+
+ my $shorter = scalar @a;
+ $shorter = scalar @b if $shorter > scalar @b;
+
+ my $found = 0;
+ for ( my $i = 0; $i < $shorter; $i++ ) {
+ my ( $a, $b ) = ( $a[ $i ], $b[ $i ] );
+ if ( $a == $wildcard or $b == $wildcard ) {
+ $found = 1;
+ last;
+ }
+ return 0 unless $a == $b;
+ }
+
+ @a = reverse @a;
+ @b = reverse @b;
+
+ for ( my $i = 0; $i < $shorter; $i++ ) {
+ my ( $a, $b ) = ( $a[ $i ], $b[ $i ] );
+ if ( $a == $wildcard or $b == $wildcard ) {
+ $found = 1;
+ last;
+ }
+ return 0 unless $a == $b;
+ }
+
+ return 0 if not $found and scalar @a != scalar @b;
+ return 1;
+}
+
+sub simplify_name
+{
+ local $_ = lc shift;
+ s/(&[a-z0-9]*;|[^a-z0-9\0])//g;
+ return $_;
+}
+
+# }}}
+
+sub uri_obj
+{
+ my $line = shift;
+ my %resp;
+ foreach ( qw(uri get name size clone error links) ) {
+ $resp{ $_ } = $line->{ $_ } if exists $line->{ $_ };
+ }
+ return \%resp;
+}
+
+sub arr_exists
+{
+ my $arr = shift;
+ my $scalar = shift;
+ foreach my $v ( @$arr ) {
+ return 1 if $v eq $scalar;
+ }
+ return 0;
+}
+
+sub clone_data
+{
+ my $o = shift;
+
+ my $n = $o->{fname} || $o->{name} || $o->{aname} || $o->{iname} || $o->{ainame};
+ return () unless $n;
+ my $sn = simplify_name( $n );
+
+ my $s = $o->{fsize} || $o->{size} || $o->{asize};
+ return () unless $s;
+ my $sr = size_to_range( $s, $o->{kilo} );
+
+ return ( $n, $sn, $s, $sr );
+}
+
+
+
+sub add_clone_info
+{
+ my $clist = shift;
+ my $uris = shift;
+ my $globals = shift;
+
+ my @mcd;
+ foreach my $uri ( keys %$uris ) {
+ my ( $getter, $options ) = @{ $uris->{ $uri } };
+ my $o = { %$options, %$globals };
+
+ my @cd = clone_data( $o );
+ next unless @cd;
+ push @mcd, [ $uri, @cd ];
+ }
+
+ push @$clist, \@mcd if @mcd;
+}
+
+sub find_clones
+{
+ my $clist = shift;
+ my $cd = shift;
+
+ my $sn = $cd->[1];
+ my $sr = $cd->[3];
+
+ my @cl_all;
+ my @cl_part;
+ foreach my $mcd ( @$clist ) {
+ my $clones = 0;
+ foreach my $ucd ( @$mcd ) {
+ my $cmp = cmp_range( $sr, $ucd->[4] );
+ next if not defined $cmp or $cmp != 0;
+
+ my $eq_name = eq_name( $sn, $ucd->[2] );
+ next unless $eq_name;
+
+ $clones++;
+ }
+ if ( $clones == @$mcd ) {
+ push @cl_all, $mcd;
+ } elsif ( $clones ) {
+ warn "Partial clone for $cd->[0]\n";
+ push @cl_part, $mcd;
+ }
+ }
+
+ return @cl_all, @cl_part;
+}
+
+sub check_bad_clones
+{
+ my $globals = shift;
+ my $uris = shift;
+
+ return 0 unless $globals->{fname};
+ my $sname = simplify_name( $globals->{fname} );
+ my $sizer = size_to_range( $globals->{fsize} );
+
+ my $got_bad = 0;
+ foreach my $uri ( keys %$uris ) {
+ my ( $getter, $o ) = @{ $uris->{ $uri } };
+
+ my @cd = clone_data( $o );
+ next unless @cd;
+
+ my $eq_name = eq_name( $sname, $cd[1] );
+ my $cmp = cmp_range( $sizer, $cd[3] );
+ if ( not $eq_name or $cmp != 0 ) {
+ warn "$uri is not a clone of $globals->{fname}\n";
+ my $u = join " ", $uri, RSGet::FileList::h2a( $o );
+ RSGet::FileList::save( $uri,
+ delete => 1, links => [ $uri ] );
+ RSGet::FileList::update();
+ $got_bad = 1;
+ }
+ }
+ return $got_bad;
+}
+
+my $act_clist;
+sub autoadd
+{
+ my $getlist = shift;
+ $act_clist = [];
+
+ my $changed = 0;
+ my @adds;
+
+ foreach my $line ( @$getlist ) {
+ next unless ref $line;
+
+ my ( $cmd, $globals, $uris ) = @$line{ qw(cmd globals uris) };
+ if ( $cmd eq "GET" ) {
+ last if check_bad_clones( $globals, $uris );
+ }
+
+ if ( $cmd eq "ADD" ) {
+ push @adds, $line;
+ next;
+ }
+
+ add_clone_info( $act_clist, $uris, $globals );
+ }
+
+ foreach my $line ( @adds ) {
+ my ( $cmd, $globals, $uris ) = @$line{ qw(cmd globals uris) };
+ my $last = 0;
+ foreach my $uri ( keys %$uris ) {
+ my ( $getter, $options ) = @{ $uris->{ $uri } };
+ my @cd = clone_data( { %$options, %$globals } );
+ next unless @cd;
+ $last = 1;
+ my @clones = find_clones( $act_clist, \@cd );
+ if ( @clones ) {
+ my $curi = $clones[0]->[0]->[0];
+ p "$uri is a clone of $curi";
+ RSGet::FileList::save( $curi, clones => { $uri => [ $getter, $options ] } );
+ RSGet::FileList::save( $uri, delete => 1 );
+ } else {
+ #p "Clone for $uri not found";
+ RSGet::FileList::save( $uri, cmd => "GET" );
+ }
+ RSGet::FileList::update();
+ }
+ last if $last;
+ }
+}
+
+
+my %all_lists;
+sub add_list
+{
+ my $text = shift;
+ my $id = shift;
+
+ unless ( $id ) {
+ do {
+ $id = sprintf "%.6x", int rand ( 1 << 24 );
+ } while ( exists $all_lists{$id} );
+ }
+ my $list = $all_lists{$id} ||= {};
+
+ $list->{comment} ||= [];
+ my $lines = $list->{lines} ||= [];
+
+ my %list_uris;
+ foreach my $mcd ( @$act_clist ) {
+ foreach my $ucd ( @$mcd ) {
+ my $uri = $ucd->[0];
+ $list_uris{ $uri } = 1;
+ }
+ }
+
+ my %all_uris;
+ foreach my $line ( @$lines ) {
+ next unless ref $line;
+ my $uris = $line->{uris};
+ foreach my $uri ( keys %$uris ) {
+ if ( $all_uris{ $uri } ) {
+ warn "$uri repeated!";
+ delete $uris->{ $uri };
+ } else {
+ $all_uris{ $uri } = 1;
+ }
+ }
+ }
+
+ foreach ( split /\s+/s, $text ) {
+ next unless m{^(?:.*?([|#<>"'\(\)\{\}\[\]]))?(http://)?(.*?)$};
+ my $lim = $1;
+ my $proto = $2 || "http://";
+ my $uri = $proto . $3;
+ if ( $lim ) {
+ $lim =~ tr/[](){}/][)(}{/;
+ $uri =~ s/\Q$lim\E.*//;
+ }
+ my $getter = RSGet::Dispatch::getter( $uri );
+ next unless $getter;
+ next if exists $all_uris{ $uri };
+ $all_uris{ $uri } = 1;
+ my $options = {};
+ $options->{error} = "Already on the list" if $list_uris{ $uri };
+ my $line = { cmd => "ADD", globals => {}, uris => { $uri => [ $getter, $options ] } };
+ push @$lines, $line;
+ }
+ $list->{id} = $id;
+
+ return $list;
+}
+
+sub add_list_find
+{
+ my $id = shift;
+
+ my $list = $all_lists{ $id };
+ return () unless $list;
+}
+
+sub add_list_comment
+{
+ my $text = shift;
+ my $id = shift;
+
+ my $list = add_list_find( $id ) || return;
+ return $list unless ref $list;
+
+ my $c = $list->{comment};
+
+ foreach ( split /[\r\n]+/s, $text ) {
+ s/^\s*#\s*//;
+ push @$c, "# " . $_;
+ }
+
+ return $list;
+}
+
+
+sub add_list_update
+{
+ my $id = shift;
+
+ my $list = add_list_find( $id ) || return;
+ return $list unless ref $list;
+
+ my $lines = $list->{lines};
+ $list->{select_clone} = 1;
+ my @used_save;
+ foreach my $line ( @$lines ) {
+ next unless ref $line;
+ my $globals = $line->{globals};
+ my $uris = $line->{uris};
+ unless ( keys %$uris ) {
+ $line = "";
+ next;
+ }
+
+ foreach my $uri ( keys %$uris ) {
+ my ( $getter, $options ) = @{ $uris->{ $uri } };
+
+ if ( my $save = $RSGet::FileList::save{ $uri } ) {
+ push @used_save, $uri;
+ $list->{select_clone} = 0;
+
+ $line->{cmd} = $save->{cmd} if $save->{cmd};
+ hadd $globals, %{$save->{globals}} if $save->{globals};
+ hadd $options, %{$save->{options}} if $save->{options};
+
+ if ( my $links = $save->{links} ) {
+ foreach my $uri ( @$links ) {
+ my $getter = RSGet::Dispatch::getter( $uri );
+ if ( $getter ) {
+ push @$lines, { cmd => "ADD", globals => {}, uris => { $uri => [ $getter, {} ] } };
+ } else {
+ push @$lines, "# unsupported uri: $uri";
+ }
+ }
+ }
+ if ( my $clones = $save->{clones} ) {
+ hadd $uris, %$clones;
+ # will check new ones next time
+ }
+ if ( $save->{delete} ) {
+ delete $uris->{ $uri };
+ next;
+ }
+ }
+
+ my $chk = RSGet::Dispatch::check( $uri, $getter, $options );
+ $list->{select_clone} = 0 unless $chk;
+ }
+ }
+
+ foreach my $uri ( @used_save ) {
+ delete $RSGet::FileList::save{ $uri };
+ }
+
+ return $list;
+}
+
+sub add_list_clones
+{
+ my $id = shift;
+
+ my $list = add_list_find( $id ) || return;
+ return $list unless ref $list;
+
+ $list->{select_clone} = 1;
+ my $lines = $list->{lines};
+ my $own_clist = [ @$act_clist ];
+ my $active = 0;
+
+ my $clone_select;
+
+ foreach my $line ( @$lines ) {
+ next unless ref $line;
+ my ( $cmd, $globals, $uris ) = @$line{ qw(cmd globals uris) };
+
+ foreach my $uri ( keys %$uris ) {
+ my ( $getter, $options ) = @{ $uris->{ $uri } };
+
+ my @cd = clone_data( { %$options, %$globals } );
+ unless ( @cd ) {
+ $line->{cmd} = "STOP" if $options->{error};
+ next;
+ }
+
+ if ( $line->{cmd} ne "ADD" ) {
+ $active++;
+ push @$own_clist, [ [ $uri, @cd ] ];
+ next;
+ }
+
+ my @clones = find_clones( $own_clist, \@cd );
+ if ( @clones ) {
+ $clone_select = [ $uri, $options, \@clones ];
+ } else {
+ $line->{cmd} = "GET";
+ push @$own_clist, [ [ $uri, @cd ] ];
+ }
+ }
+ last if $clone_select;
+ }
+ $list->{active} = $active;
+
+ return ( $list, $clone_select );
+}
+
+sub add_list_find_uri
+{
+ my $list = shift;
+ my $furi = shift;
+
+ my $lines = $list->{lines};
+ foreach my $line ( @$lines ) {
+ next unless ref $line;
+ my ( $cmd, $globals, $uris ) = @$line{ qw(cmd globals uris) };
+
+ foreach my $uri ( keys %$uris ) {
+ if ( $uri eq $furi ) {
+ return $line;
+ }
+ }
+ }
+ return;
+}
+
+sub add_list_add
+{
+ my $id = shift;
+ my $list = add_list_find( $id );
+
<<diff output has been trimmed to 500 lines, 100 line(s) remained.>>
More information about the pld-cvs-commit
mailing list