lib/File/Rsync/Mirror/Recent.pm

   1 package File::Rsync::Mirror::Recent;
   2
   3 # use warnings;
   4 use strict;
   5 use File::Rsync::Mirror::Recentfile;
   6
   7 =encoding utf-8
   8
   9 =head1 NAME
  10
  11 File::Rsync::Mirror::Recent - mirroring via rsync made efficient
  12
  13 =head1 VERSION
  14
  15 Version 0.0.1
  16
  17 =cut
  18
  19 package File::Rsync::Mirror::Recent;
  20
  21 use File::Basename qw(dirname fileparse);
  22 use File::Copy qw(cp);
  23 use File::Path qw(mkpath);
  24 use File::Rsync;
  25 use File::Temp;
  26 use List::Util qw(first max);
  27 use Scalar::Util qw(reftype);
  28 use Storable;
  29 use Time::HiRes qw();
  30 use YAML::Syck;
  31
  32 use version; our $VERSION = qv('0.0.1');
  33
  34 =head1 SYNOPSIS
  35
  36 B<!!!! PRE-ALPHA ALERT !!!!>
  37
  38 Nothing in here is believed to be stable, nothing yet intended for
  39 public consumption. The plan is to provide a script in one of the next
  40 releases that acts as a frontend for all the backend functionality.
  41 Option and method names will very likely change.
  42
  43 File::Rsync::Mirror::Recent is acting at a higher level than
  44 File::Rsync::Mirror::Recentfile. File::Rsync::Mirror::Recent
  45 establishes a view on a collection of recentfile objects and provides
  46 abstractions spanning multiple intervals associated with those.
  47
  48 B<Mostly unimplemented as of yet>. Will need to shift some accessors
  49 from recentfile to recent.
  50
  51 Reader/mirrorer:
  52
  53     my $rr = File::Rsync::Mirror::Recent->new
  54       (
  55        ignore_link_stat_errors => 1,
  56        localroot => "/home/ftp/pub/PAUSE/authors",
  57        remote => "pause.perl.org::authors/RECENT.recent",
  58        rsync_options => {
  59                          compress => 1,
  60                          links => 1,
  61                          times => 1,
  62                          checksum => 1,
  63                         },
  64        verbose => 1,
  65       );
  66     $rr->rmirror;
  67
  68 =head1 EXPORT
  69
  70 No exports.
  71
  72 =head1 CONSTRUCTORS
  73
  74 =head2 my $obj = CLASS->new(%hash)
  75
  76 Constructor. On every argument pair the key is a method name and the
  77 value is an argument to that method name.
  78
  79 =cut
  80
  81 sub new {
  82     my($class, @args) = @_;
  83     my $self = bless {}, $class;
  84     while (@args) {
  85         my($method,$arg) = splice @args, 0, 2;
  86         $self->$method($arg);
  87     }
  88     return $self;
  89 }
  90
  91 =head1 ACCESSORS
  92
  93 =cut
  94
  95 my @accessors;
  96
  97 BEGIN {
  98     @accessors = (
  99                   "__pathdb",
 100                   "_principal_recentfile",
 101                   "_recentfiles",
 102                   "_rsync",
 103                  );
 104
 105     my @pod_lines =
 106         split /\n/, <<'=cut'; push @accessors, grep {s/^=item\s+//} @pod_lines; }
 107
 108 =over 4
 109
 110 =item ignore_link_stat_errors
 111
 112 as in F:R:M:Recentfile
 113
 114 =item local
 115
 116 Option to specify the local principal file for operations with a local
 117 collection of recentfiles.
 118
 119 =item localroot
 120
 121 as in F:R:M:Recentfile
 122
 123 =item max_files_per_connection
 124
 125 as in F:R:M:Recentfile
 126
 127 =item remote
 128
 129 TBD
 130
 131 =item remoteroot
 132
 133 XXX: this is (ATM) different from Recentfile!!!
 134
 135 =item remote_recentfile
 136
 137 Rsync address of the remote C<RECENT.recent> symlink or whichever name
 138 the principal remote recentfile has.
 139
 140 =item rsync_options
 141
 142 Things like compress, links, times or checksums. Passed in to the
 143 File::Rsync object used to run the mirror.
 144
 145 =item verbose
 146
 147 Boolean to turn on a bit verbosity.
 148
 149 =back
 150
 151 =cut
 152
 153 use accessors @accessors;
 154
 155 =head1 METHODS
 156
 157 =head2 $arrayref = $obj->news ( %options )
 158
 159 XXX WORK IN PROGRESS XXX
 160
 161 Testing this ATM with:
 162
 163   perl -Ilib bin/rrr-news \
 164        -after 1217200539 \
 165        -max 12 \
 166        -local /home/ftp/pub/PAUSE/authors/RECENT.recent
 167
 168   perl -Ilib bin/rrr-news \
 169        -after 1217200539 \
 170        -rsync=compress=1 \
 171        -rsync=links=1 \
 172        -localroot /home/ftp/pub/PAUSE/authors/ \
 173        -remote pause.perl.org::authors/RECENT.recent
 174        -verbose
 175
 176 Note: all parameters that can be passed to recent_events can also be specified here.
 177
 178 Note: all data are kept in memory
 179
 180 =cut
 181
 182 sub news {
 183     my($self, %opt) = @_;
 184     my $local = $self->local;
 185     unless ($local) {
 186         if (my $remote = $self->remote) {
 187             my $localroot;
 188             if ($localroot = $self->localroot) {
 189                 # nice, they know what they are doing
 190             } else {
 191                 die "FIXME: remote called without localroot should trigger File::Temp.... TBD, sorry";
 192             }
 193         } else {
 194             die "Alert: neither local nor remote specified, cannot continue";
 195         }
 196     }
 197     my $rfs = $self->recentfiles;
 198     my $ret = [];
 199     my $before;
 200     for my $rf (@$rfs) {
 201         my %locopt = %opt;
 202         $locopt{before} = $before;
 203         if ($opt{max}) {
 204             $locopt{max} -= scalar @$ret;
 205             last if $locopt{max} <= 0;
 206         }
 207         $locopt{info} = {};
 208         my $res = $rf->recent_events(%locopt);
 209         if (@$res){
 210             push @$ret, @$res;
 211         }
 212         if ($opt{max} && scalar @$ret > $opt{max}) {
 213             last;
 214         }
 215         if ($opt{after}){
 216             if ( $locopt{info}{last} && $locopt{info}{last}{epoch} < $opt{after} ) {
 217                 last;
 218             }
 219             if ( $opt{after} > $locopt{info}{first}{epoch} ) {
 220                 last;
 221             }
 222         }
 223         if (!@$res){
 224             next;
 225         }
 226         $before = $res->[-1]{epoch};
 227         $before = $opt{before} if $opt{before} && $opt{before} < $before;
 228     }
 229     $ret;
 230 }
 231
 232 =head2 overview
 233
 234 returns a string that summarizes the state of all recentfiles
 235 collected in this Recent object.
 236
 237 =cut
 238 sub overview {
 239     my($self) = @_;
 240     my $rfs = $self->recentfiles;
 241     my(@s,%rank);
 242   RECENTFILE: for my $rf (@$rfs) {
 243         my $re=$rf->recent_events;
 244         my $rfsummary;
 245         if (@$re) {
 246             my $span = $re->[0]{epoch}-$re->[-1]{epoch};
 247             $rfsummary =
 248                 [
 249                  $rf->interval,
 250                  scalar @$re,
 251                  sprintf ("%.3f", $re->[0]{epoch}),
 252                  sprintf ("%.3f", $re->[-1]{epoch}),
 253                  sprintf ("%.3f", $span),
 254                  ($rf->interval eq "Z"
 255                   ?
 256                   "-"
 257                   :
 258                   sprintf ("%5.1f%%", 100 * $span / $rf->interval_secs)
 259                  ),
 260                 ];
 261             @rank{@{$rfsummary}[2,3]} = ();
 262         } else {
 263             next RECENTFILE;
 264         }
 265         push @s, $rfsummary;
 266     }
 267     @rank{sort {$b <=> $a} keys %rank} = 1..keys %rank;
 268     my $maxrank = max values %rank;
 269     for my $s (@s) {
 270         my $string = " " x $maxrank;
 271         my @borders;
 272         for (2,3) {
 273             push @borders, $rank{$s->[$_]}-1;
 274         }
 275         for ($borders[0],$borders[1]) {
 276             substr($string,$_,1) = "^";
 277         }
 278         push @$s, $string;
 279     }
 280     my @sprintf;
 281     for my $i (0..$#{$s[0]}) {
 282         my $maxlength = max map { length $_->[$i] } @s;
 283         push @sprintf, "%" . $maxlength . "s";
 284     }
 285     my $sprintf = join " ", @sprintf;
 286     $sprintf .= "\n";
 287     my $headline = sprintf $sprintf,
 288         (
 289          "",
 290          "Cnt",
 291          "Max",
 292          "Min",
 293          "Span",
 294          "Util", # u9n:)
 295          "Cloud",
 296         );
 297     join "", $headline, map { sprintf $sprintf, @$_ } @s;
 298 }
 299
 300 =head2 _pathdb
 301
 302 (Private method, not for public use) Keeping track of already handled
 303 files. Currently it is a hash, will probably become a database with
 304 its own accessors.
 305
 306 =cut
 307
 308 sub _pathdb {
 309     my($self) = @_;
 310     my $db = $self->_pathdb;
 311     unless (defined $db) {
 312         $self->_pathdb(+{});
 313     }
 314     return $db;
 315 }
 316
 317 =head2 $recentfile = $obj->principal_recentfile ()
 318
 319 returns the principal recentfile of this tree.
 320
 321 =cut
 322
 323 sub principal_recentfile {
 324     my($self) = @_;
 325     my $prince = $self->_principal_recentfile;
 326     return $prince if defined $prince;
 327     my $local = $self->local;
 328     if ($local) {
 329         $prince = File::Rsync::Mirror::Recentfile->new_from_file ($local);
 330     } else {
 331         if (my $remote = $self->remote) {
 332             my $localroot;
 333             if ($localroot = $self->localroot) {
 334                 # nice, they know what they are doing
 335             } else {
 336                 die "FIXME: remote called without localroot should trigger File::Temp.... TBD, sorry";
 337             }
 338             my $rf0 = $self->_recentfile_object_for_remote;
 339             $prince = $rf0;
 340         } else {
 341             die "Alert: neither local nor remote specified, cannot continue";
 342         }
 343     }
 344     $self->_principal_recentfile($prince);
 345     return $prince;
 346 }
 347
 348 =head2 $recentfiles_arrayref = $obj->recentfiles ()
 349
 350 returns a reference to the complete list of recentfile objects that
 351 describe this tree. No guarantee is given that the represented
 352 recentfiles exist or have been read. They are just bare objects.
 353
 354 =cut
 355
 356 sub recentfiles {
 357     my($self) = @_;
 358     my $rfs = $self->_recentfiles;
 359     return $rfs if defined $rfs;
 360     my $rf0 = $self->principal_recentfile;
 361     my $db = +{};
 362     $rf0->_pathdb ( $db );
 363     my $aggregator = $rf0->aggregator;
 364     my @rf = $rf0;
 365     for my $agg (@$aggregator) {
 366         my $nrf = $rf0->_sparse_clone;
 367         $nrf->interval      ( $agg );
 368         $nrf->have_mirrored ( 0    );
 369         $nrf->_pathdb       ( $db  );
 370         push @rf, $nrf;
 371     }
 372     $self->_recentfiles(\@rf);
 373     return \@rf;
 374 }
 375
 376 =head2 $success = $obj->rmirror ( %options )
 377
 378 XXX WORK IN PROGRESS XXX
 379
 380 Mirrors all recentfiles of the I<remote> address. Afterwards it should
 381 work through all of them.
 382
 383 Testing this ATM with:
 384
 385   use File::Rsync::Mirror::Recent;
 386   my $rrr = File::Rsync::Mirror::Recent->new(
 387          ignore_link_stat_errors => 1,
 388          localroot => "/home/ftp/pub/PAUSE/authors",
 389          remote => "pause.perl.org::authors/RECENT.recent",
 390          max_files_per_connection => 5,
 391          rsync_options => {
 392                            compress => 1,
 393                            links => 1,
 394                            times => 1,
 395                            checksum => 1,
 396                           },
 397          verbose => 1,
 398
 399   );
 400   $rrr->rmirror ( "skip-deletes" => 1 );
 401
 402
 403 =cut
 404
 405 sub rmirror {
 406     my($self, %options) = @_;
 407
 408     # my $rf0 = $self->_recentfile_object_for_remote;
 409     my $rfs = $self->recentfiles;
 410
 411     my $_once_per_20s = sub {
 412         my $p = $self->principal_recentfile;
 413         require YAML::Syck; YAML::Syck::DumpFile("recent-rmirror-state-$$.yml",$self); # XXX
 414
 415         for my $i (1) {
 416             print STDERR ("TODO: refetch prince and let it reset what needs to be resetted\n");
 417             sleep 1;
 418         }
 419     };
 420     my $_sigint = sub {
 421         # XXX exit gracefully (reminder)
 422     };
 423     my $minimum_time_per_loop = 20; # XXX needs accessor: warning, if
 424                                     # set too low, we do nothing but
 425                                     # mirror the principal!
 426   LOOP: while () {
 427         my $ttleave = time + $minimum_time_per_loop;
 428         $_once_per_20s->();
 429       RECENTFILE: for my $i (0..$#$rfs) {
 430             my $rf = $rfs->[$i];
 431             last RECENTFILE if time > $ttleave;
 432             if ($rf->uptodate){
 433                 $rfs->[$i+1]->done->merge($rf->done) if $i < $#$rfs;
 434                 next RECENTFILE;
 435             } else {
 436               WORKUNIT: while (time < $ttleave) {
 437                     if ($rf->uptodate) {
 438                         my $sleep = $rf->sleep_per_connection;
 439                         $sleep = 0.42 unless defined $sleep; # XXX double accessor!
 440                         for (($sleep)x5) { # want a bit more
 441                             if ($rf->verbose) {
 442                                 printf STDERR
 443                                     (
 444                                      "Napping (%s/%s) ...\n",
 445                                      $_,
 446                                      $rf->interval,
 447                                     );
 448                             }
 449                             Time::HiRes::sleep $_ if $_;
 450                         }
 451                         $rfs->[$i+1]->done->merge($rf->done) if $i < $#$rfs;
 452                         next RECENTFILE;
 453                     } else {
 454                         $rf->mirror (
 455                                      piecemeal => 1,
 456                                      %options,
 457                                     );
 458                     }
 459                 }
 460             }
 461         }
 462         my $sleep = $ttleave - time;
 463         if ($sleep > 0.01) {
 464             printf STDERR
 465                 (
 466                  "Retreat to the Dormitory (%s) ...",
 467                  $sleep,
 468                 );
 469             sleep $sleep;
 470         } else {
 471             # negative time not invented yet:)
 472         }
 473     }
 474 }
 475
 476 # mirrors the recentfile and instantiates the recentfile object
 477 sub _recentfile_object_for_remote {
 478     my($self) = @_;
 479     # get the remote recentfile
 480     my $rrfile = $self->remote or die "Alert: cannot construct a recentfile object without the 'remote' attribute";
 481     my($remoteroot,$rfilename) = $rrfile =~ m{(.+)/([^/]+)};
 482     $self->remoteroot($remoteroot);
 483     my @need_args =
 484         (
 485          "ignore_link_stat_errors",
 486          "localroot",
 487          "max_files_per_connection",
 488          "remoteroot",
 489          "rsync_options",
 490          "verbose",
 491         );
 492     my $rf0 = File::Rsync::Mirror::Recentfile->new (map {($_ => $self->$_)} @need_args);
 493     my $lfile = $rf0->get_remote_recentfile_as_tempfile ($rfilename);
 494     # while it is a symlink, resolve it
 495     while (-l $lfile) {
 496         my $symlink = readlink $lfile;
 497         if ($symlink =~ m|/|) {
 498             die "FIXME: filenames containing '/' not supported, got '$symlink'";
 499         }
 500         $lfile = $rf0->get_remote_recentfile_as_tempfile ($symlink);
 501     }
 502     my $rfpeek;
 503     if (-s $lfile) {
 504         $rfpeek = File::Rsync::Mirror::Recentfile->new_from_file ( $lfile );
 505     } else {
 506         die "Alert: recentfile '$lfile' is empty, cannot continue";
 507     }
 508     for my $peek (qw(_interval aggregator filenameroot protocol serializer_suffix)) {
 509         $rf0->$peek($rfpeek->$peek);
 510     }
 511     for my $need_arg (@need_args) {
 512         $rf0->$need_arg ( $self->$need_arg );
 513     }
 514     $rf0->is_slave (1);
 515     return $rf0;
 516 }
 517
 518 =head2 (void) $obj->rmirror_loop
 519
 520 (TBD) Run rmirror in an endless loop.
 521
 522 =cut
 523
 524 sub rmirror_loop {
 525     my($self) = @_;
 526     die "FIXME";
 527 }
 528
 529 =head2 $hash = $obj->verify
 530
 531 (TBD) Runs find on the local tree, collects all existing files from
 532 recentfiles, compares their names. The returned hash contains the keys
 533 C<todelete> and C<toadd>.
 534
 535 =cut
 536
 537 sub verify {
 538     my($self) = @_;
 539     die "FIXME";
 540 }
 541
 542 =head1 AUTHOR
 543
 544 Andreas König
 545
 546 =head1 BUGS
 547
 548 Please report any bugs or feature requests through the web interface
 549 at
 550 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Rsync-Mirror-Recent>.
 551 I will be notified, and then you'll automatically be notified of
 552 progress on your bug as I make changes.
 553
 554 =head1 SUPPORT
 555
 556 You can find documentation for this module with the perldoc command.
 557
 558     perldoc File::Rsync::Mirror::Recent
 559
 560 You can also look for information at:
 561
 562 =over 4
 563
 564 =item * RT: CPAN's request tracker
 565
 566 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Rsync-Mirror-Recent>
 567
 568 =item * AnnoCPAN: Annotated CPAN documentation
 569
 570 L<http://annocpan.org/dist/File-Rsync-Mirror-Recent>
 571
 572 =item * CPAN Ratings
 573
 574 L<http://cpanratings.perl.org/d/File-Rsync-Mirror-Recent>
 575
 576 =item * Search CPAN
 577
 578 L<http://search.cpan.org/dist/File-Rsync-Mirror-Recent>
 579
 580 =back
 581
 582
 583 =head1 ACKNOWLEDGEMENTS
 584
 585 Thanks to RJBS for module-starter.
 586
 587 =head1 COPYRIGHT & LICENSE
 588
 589 Copyright 2008 Andreas König.
 590
 591 This program is free software; you can redistribute it and/or modify it
 592 under the same terms as Perl itself.
 593
 594
 595 =cut
 596
 597 1; # End of File::Rsync::Mirror::Recent