p4getback #1

#!/usr/bin/perl
# -*-Fundamental-*-

use Carp;
use strict;
$| = 1;

my $Myname;
($Myname = $0) =~ s%^.*/%%;

#   $Myname <archive-dir> <ftp-user> <ftp-password> <ftp-host>
#                    <ftp-dir> <ftp-prefix> <retain> [<ftp-debug>]

use Net::FTP;

my $Archive_dir = shift;
my $Ftp_user = shift;
my $Ftp_password = shift;
my $Ftp_host = shift;
my $Ftp_dir = shift;
my $Ftp_prefix = shift;
my $Retain = shift;
my $Ftp_debug = shift;

chdir $Archive_dir || die "chdir ($Archive_dir): $!";
open(C, "$Ftp_prefix.counter") || die "open <$Ftp_prefix.counter: $!";
my $c = <C>; chomp $c;

print "$Myname: last counter was <$c>.\n";

my $ftp;

$ftp = Net::FTP->new($Ftp_host, Debug => $Ftp_debug)
   || die "FTP->new($Ftp_host): $@";

$ftp->login($Ftp_user, $Ftp_password)
   || die "FTP->login($Ftp_user): $@";

$ftp->cwd($Ftp_dir)
   || die "FTP->cwd($Ftp_dir): $@";

my $nc = 0;
foreach my $f ($ftp->ls())
  {
    if ($f =~ /^$Ftp_prefix.(\d+)$/)
      {
        if ($1 > $nc) { $nc = $1; }
      }
  }

# -rw-r--r--    1 rmg      users           0 Mar 25 16:06 prefix.10
# -rw-r--r--    1 rmg      users     2638130 Mar 25 16:06 prefix.10.tar.gz
# -r--r--r--    1 root     users         147 Mar 25 16:06 prefix.ckp.10.gz
# -r--r--r--    1 root     users          76 Mar 25 16:06 prefix.jnl.9.gz

if ($nc > $c)
  {
    # We have a new one to grab!

    # Take the checkpoint file:
    #
    $ftp->get("$Ftp_prefix.ckp.$nc.gz")
      || die "FTP->get($Ftp_prefix.ckp.$nc.gz): $@";
    print "$Myname: copied $Ftp_prefix.ckp.$nc.gz.\n";

    # And the journal file:
    #
    my $ncp = $nc - 1;
    $ftp->get("$Ftp_prefix.jnl.$ncp.gz")
      || die "FTP->get($Ftp_prefix.jnl.$ncp.gz): $@";
    print "$Myname: copied $Ftp_prefix.jnl.$ncp.gz.\n";

    # And the file-revision archive:
    #
    $ftp->get("$Ftp_prefix.$nc.tar.gz")
      || die "FTP->get($Ftp_prefix.$nc.tar.gz): $@";
    print "$Myname: copied $Ftp_prefix.$nc.tar.gz.\n";

    open(C, ">$Ftp_prefix.counter") || die "open >$Ftp_prefix.counter: $!";
    print C "$nc\n"; close C;

    # anon users may not be able to do this; for now, rely on the "checkpoint"
    # side to clean up.

    #foreach my $f ($ftp->ls())
    #  {
    #    $ftp->delete($f)
    #      || die "FTP->delete($f): $@";
    #  }
  }

#  Now delete old ones. We retain the $Retain most recent.
#
#  Base it on the prefix.ckp.*.gz files, since these are the oldest of
#  each batch.
#
my @Ckp = <$Ftp_prefix.ckp.*.gz>;

my @Ckpn;

foreach my $Ckp (@Ckp)
  {
    $Ckp =~ s/$Ftp_prefix.ckp.//;
    $Ckp =~ s/.gz//;
    unshift (@Ckpn, $Ckp);
  }

splice(@Ckpn, 0, $Retain); 

foreach my $N (@Ckpn)
  { &s("/bin/rm -f $Ftp_prefix.ckp.$N.gz $Ftp_prefix.jnl.$N.gz $Ftp_prefix.$N.tar.gz"); }

# Notification email TBD (or rely on cron mail at first?)

exit 0;

#  Run a command, returning status and output; terminate
#  on any error.
#  
sub s
{
  my ($cmd) = @_;
  my ($sts, $output);

  print("> $cmd\n");

  if (! open(CMD, "$cmd 2>&1 |"))
    { die "can't open \"$cmd 2>&1 |\": $!"; }
  
  while (<CMD>) { print(": $_"); $output .= $_; }
  close CMD;

  if ($sts = $?)
    {
      my $sig = $sts & 0x0f;
      $sts = $sts >> 8;
      die "\"$cmd\" exited with signal $sig status $sts";
    }
  return ($sts, $output);
}