SVN: toys/rsget.pl/RSGet/FileList.pm
sparky
sparky at pld-linux.org
Fri Sep 11 18:51:20 CEST 2009
Author: sparky
Date: Fri Sep 11 18:51:20 2009
New Revision: 10562
Modified:
toys/rsget.pl/RSGet/FileList.pm
Log:
- mostly rewritten to allow new syntax and use ListManager
Modified: toys/rsget.pl/RSGet/FileList.pm
==============================================================================
--- toys/rsget.pl/RSGet/FileList.pm (original)
+++ toys/rsget.pl/RSGet/FileList.pm Fri Sep 11 18:51:20 2009
@@ -4,222 +4,235 @@
use warnings;
use URI::Escape;
use RSGet::Tools;
-our $file = 'get.list';
-my $file_swp = '.get.list.swp';
-our $reread = 1;
-our %uri_options; # options to be saved
+
+my $file;
+my $file_swp;
+
+my $update = 1;
+# $uri => { cmd => "CMD", globals => {...}, options => {...} }
+
+# commands:
+# GET - download
+# DONE - stop, fully downloaded
+# STOP - stop, partially downloaded
+# ADD - add as clone if possible, new link otherwise
+
+our @actual;
+our @added;
sub set_file
{
- my $file = shift;
+ $file = shift;
die "Can't read '$file'\n" unless -r $file;
p "Using '$file' file list\n";
- my $make_swp = $settings{make_swp} || '.${file}.swp';
+ my $make_swp = $settings{list_lock};
$file_swp = eval "\"$make_swp\"";
p "Using '$file_swp' as file lock\n";
}
-sub need_update
+
+sub update
{
- $reread = 1;
+ $update = 1;
}
-sub words
+our %save; # options to be saved
+sub save
{
- my $pre = shift;
- my $before = shift;
- return () unless @_;
- my $line = "";
- my $lline = $pre . $before . shift;
- foreach ( @_ ) {
- if ( length $lline . $_ > 76 ) {
- $line .= "$lline \\\n";
- $lline = $pre;
+ my $uri = shift;
+ my %data = @_;
+ my $save_uri = $save{ $uri } ||= {};
+ foreach my $key ( keys %data ) {
+ my $val = $data{ $key };
+ if ( $key =~ /^(options|globals|clones)/ ) {
+ my $hash = $save_uri->{ $key } ||= {};
+ hadd $hash, %{ $val };
+ } else {
+ $save_uri->{ $key } = $val;
}
- $lline .= " " . $_;
}
-
- $lline = $line.$lline if $line;
- return $lline."\n";
}
+
sub h2a($)
{
my $h = shift;
- return map { $_ . "=" . uri_escape( $h->{$_} ) } sort keys %$h;
-}
-
-sub getter
-{
- my $uri = shift;
- my @g = grep { $uri =~ m/^http:\/\/(:?www\.)?$_->{uri}/ } values %getters;
- return undef unless @g;
- return $g[0];
+ return map { defined $h->{$_} ? ($_ . "=" . uri_escape( $h->{$_} )) : () } sort keys %$h;
}
-my @added_text;
-sub add_text
-{
- my $type = shift;
- my $text = shift;
-
- return unless $text;
- if ( $type eq "links" ) {
- my @words = split /\s/s, $text;
-
- foreach ( @words ) {
- next unless m{^(http://)?(.*?)$};
- my $proto = $1 || "http://";
- my $uri = $proto . $2;
- push @added_text, $uri . "\n" if getter($uri);
- }
-
- $reread = 2;
- } elsif ( $type eq "text" ) {
- foreach ( split /\n/, $text ) {
- s/\s+$//;
- push @added_text, $_."\n";
- }
- } elsif ( $type eq "comment" ) {
- foreach ( split /\n/, $text ) {
- s/\s+$//;
- push @added_text, "# $_\n";
- }
- }
- return \@added_text;
-}
-
-my $listmtime = 0;
+our $listmtime = 0;
sub readlist
{
return unless -r $file;
my $mtime = (stat _)[9];
- return unless $reread or $mtime != $listmtime;
+ return unless $update or $mtime != $listmtime;
#p "readlist()";
- my @getlist;
- my @newlist;
open my $list, '<', $file;
- while ( my $line = <$list> ) {
+ my @list = <$list>;
+ close $list;
+
+ push @list, @added;
+
+ my @new;
+ my @end;
+
+ my @used_save;
+ my %all_uri;
+ @actual = ();
+ while ( my $line = shift @list ) {
chomp $line;
+ if ( $line =~ /^__END__\s*$/ ) { # end of the list
+ push @end, $line . "\n";
+ push @actual, $line;
+ push @end, @list;
+ push @actual, @list;
+ last;
+ }
if ( $line =~ /^\s*(#.*)?$/ ) { # comments and empty lines
- push @newlist, $line . "\n";
+ push @new, $line . "\n";
+ push @actual, $line;
next;
- } elsif ( $line =~ /^__END__\s*$/ ) { # end of list
- push @newlist, $line . "\n";
- push @newlist, <$list>;
- last;
}
- while ( $line =~ s/\\$/ / ) { # stitch broken lines together
- $line .= <$list>;
+ my $mline = $line;
+ while ( $mline =~ s/\s*\\$/ / or (@list and $list[0] =~ s/^\s*\+\s*/ /) ) { # stitch broken lines together
+ $line = shift @list;
chomp $line;
+ $mline .= $line;
}
- $line =~ s/^\s+//;
- $line =~ s/\s+$//;
+ $mline =~ s/^\s+//s;
+ $mline =~ s/\s+$//s;
+ my @words = split /\s+/s, $mline;
- my %uris;
- my %options;
- my @invalid;
- my @invalid_uri;
+ my $cmd;
+ if ( $words[0] =~ /^(GET|DONE|STOP|ADD):$/ ) {
+ $cmd = $1;
+ shift @words;
+ }
+ my $globals = {};
+ my $options = $globals;
- # split line into words
- foreach ( split /\s+/, $line ) {
- if ( /^([a-z_]+)=(.*)$/ ) {
- $options{$1} = uri_unescape( $2 );
+ my %decoded;
+ my @invalid;
+ foreach ( @words ) {
+ if ( /^([a-z0-9_]+)=(.*)$/ ) {
+ $options->{$1} = uri_unescape( $2 );
+ next;
} elsif ( m{^(http://)?(.*?)$} ) {
my $proto = $1 || "http://";
my $uri = $proto . $2;
- if ( my $getter = getter($uri) ) {
- $uris{ $uri } = $getter;
- } elsif ( $uri =~ m{.+\.[a-z]{2,4}/.+} ) {
- push @invalid_uri, $uri;
- } else {
- push @invalid, $_;
+ if ( my $getter = RSGet::Dispatch::getter($uri) ) {
+ $options = {};
+ $decoded{ $uri } = [ $getter, $options ];
+ next;
}
- } else {
- push @invalid, $_;
}
+
+ push @invalid, $_;
}
- if ( not scalar keys %uris ) {
- push @newlist, words(
- "# ", "invalid line: ",
- @invalid, @invalid_uri, h2a( \%options ),
- );
- next;
- } elsif ( @invalid ) {
- push @newlist, words(
- "# ", "invalid words: ",
- @invalid, @invalid_uri
- );
- } elsif ( @invalid_uri ) {
- push @newlist, words(
- "# ", "invalid uri: ",
- @invalid_uri,
- );
- }
-
- foreach my $uri ( sort keys %uris ) {
- my $error = RSGet::Dispatch::is_error( $uri );
- next unless $error;
- delete $uris{ $uri };
- push @newlist, "# $error:\n# $uri\n";
- }
-
- unless ( keys %uris ) {
- push @newlist, words(
- "#", "", h2a( \%options )
- ) if keys %options;
+ unless ( keys %decoded ) {
+ my $line = '# invalid line: ' . (join " ", ($cmd ? "$cmd:" : ()), @words);
+ push @new, $line . "\n";
+ push @actual, $line;
next;
}
+ if ( @invalid ) {
+ my $line = '# invalid: ' . (join " ", @invalid);
+ push @new, $line . "\n";
+ push @actual, $line;
+ }
- foreach my $uri ( sort keys %uris ) {
- hadd \%options, %{$uri_options{ $uri }} if $uri_options{ $uri };
+ $cmd ||= "GET";
+
+ foreach my $uri ( keys %decoded ) {
+ next unless exists $save{ $uri };
+ push @used_save, $uri;
+ my $save = $save{ $uri };
+ if ( not ref $save or ref $save ne "HASH" ) {
+ warn "Invalid \$save{ $uri } => $save\n";
+ next;
+ }
+
+ my $options = $decoded{ $uri }->[1];
+
+ $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} ) {
+ push @new, map { "ADD: $_\n" } @$links;
+ # don't bother with @actual, list will be reread shortly
+ $update = 2;
+ }
+
+ if ( my $clones = $save->{clones} ) {
+ hadd \%decoded, %{ $clones };
+ $update = 2;
+ }
+ delete $decoded{ $uri } if $save->{delete};
}
- my $status;
- foreach my $uri ( sort keys %uris ) {
- next unless $status = RSGet::Dispatch::done( $uri, $uris{ $uri } );
- $uri = "*" . $uri;
- if ( ref $status and ref $status eq "ARRAY" ) {
- push @newlist, words(
- "#", " Link: ",
- (sort keys %uris), h2a( \%options )
- );
- push @newlist, words( '', '', @$status );
+ foreach my $uri ( keys %decoded ) {
+ if ( $all_uri{ $uri } ) {
+ warn "URI: $uri repeated, removing second one\n";
+ #hadd $options, %{ $all_uri{ $uri }->[1] };
+ #$all_uri{ $uri }->[1] = $options;
+ delete $decoded{ $uri };
} else {
- push @newlist, words(
- "# ", "$status:\n# ",
- (sort keys %uris), h2a( \%options )
- );
+ $all_uri{ $uri } = $decoded{ $uri };
}
- $reread = 2;
- last;
}
- next if $status;
- push @newlist, words( '', '', (sort keys %uris), h2a( \%options ) );
+ next unless keys %decoded;
- push @getlist, [ \%uris, \%options ];
+ my $all_error = 1;
+ foreach my $uri ( keys %decoded ) {
+ my $options = $decoded{ $uri }->[1];
+ unless ( $options->{error} ) {
+ $all_error = 0;
+ last;
+ }
+ }
+ $cmd = "STOP" if $all_error and $cmd ne "DONE";
+
+ push @actual, {
+ cmd => $cmd,
+ globals => $globals,
+ uris => \%decoded
+ };
+
+ {
+ my @out = ( "$cmd:", h2a( $globals ) );
+ push @new, (join " ", @out) . "\n";
+ }
+ foreach my $uri ( sort keys %decoded ) {
+ my @out = ( $uri, h2a( $decoded{ $uri }->[1] ) );
+ push @new, (join " ", '+', @out) . "\n";
+ }
}
- close $list;
+
+ # we are forced to regenerate the list if there was something added
+ unlink $file_swp if @added or $update == 2;
unless ( -e $file_swp ) {
open my $newlist, '>', $file . ".tmp";
- print $newlist @newlist;
- print $newlist @added_text;
- @added_text = ();
+ print $newlist @new;
close $newlist || die "\nCannot update $file file: $!\n";
unlink $file;
rename $file . ".tmp", $file;
+ @added = ();
+ foreach my $uri ( @used_save ) {
+ delete $save{ $uri };
+ }
}
- $reread = $reread == 2 ? 1 : 0;
+ $update = $update == 2 ? 1 : 0;
$listmtime = (stat $file)[9];
- return \@getlist;
+ return \@actual;
}
1;
More information about the pld-cvs-commit
mailing list