- #!/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);
- }
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#1 | 1802 | Richard Geiger | Quick 'N dirty backup facility for firewalled depot. Not really intended for publ...ic consumption (for now, at least!), but no harm. « |
23 years ago |