File::Backup - Easy file backup & rotation automation

  use File::Backup;

  backup( from => "/source/path", to => "/destination/path" );
  backup( from => "/kansas/*", to => "/oz" );

  purge_backups(
      to => "/destination/path",
      compress => 0,
      keep => 5,
      timeformat => "YYYYMMDD_hhmmss",
  );

  tar           => archiver
  tarflags      => archive_flags
  torootname    => archive_prefix and prefix
  tarsuffix     => archive_suffix and suffix
  compress      => compressor
  compressflags => compress_flags

package File::Backup;

use vars qw($VERSION);
$VERSION = '0.07';

use strict;
use Carp;
use base qw(Exporter);  # XXX Yuck. Exported is bloated.
use vars qw(@EXPORT_OK @EXPORT);
@EXPORT = @EXPORT_OK = qw(backup);
use Cwd;
use File::Which;
use LockFile::Simple qw(lock unlock);

sub backup {  # {{{
    # Function parameters  {{{
    # Default options
    my %o = (
        debug => 0,  # Debugging: It does a body good.

        # Source and destination directory defaults.
        from => cwd(),
        to   => cwd(),

        keep => 7,  # Number of backup files to keep.  Legacy code of a week.

        timeformat => 'YYYY-MM-DD_hh-mm-ss',  # Format string.
        use_gmtime => 0,  # Use the system localtime not gmtime.

        archive => 1,  # Archive toggle
        archiver => scalar which('tar'),  # The achiving program.
        archive_flags => '-cf',  # Archive switches.
        archive_prefix => '',      # Archive prefix.
        archive_suffix => 'tar',  # Archive suffix.

        compress => 1,  # Compression on or off.
        compressor => scalar which('gzip'),  # The compression program.
        compress_flags => '',  # Compression switches.
        compress_suffix => 'gz',  # Compression suffix.

        lock => 1,  # Turn locking on or off.
        purge_first => 0,  # Purge the backups after the backup.

        # Idiomatic "catch-all" for passing alternate parameters or
        # redefining default ones.
        @_,
    );

    # If the compress arg is not numeric, it is probably the name of
    # the compression program that the caller wants to use.
    if ($o{compress} !~ /^\d$/) {
        $o{compressor} = $o{compress};
        $o{compress} = 1;  # Assume that the user wants compression.
    }

    # NOTE I changed the names of the *fix parameters and need to be
    # backwards compatible with myself now.  Grrrr!
    $o{archive_prefix} = $o{prefix} if $o{prefix};
    $o{archive_suffix} = $o{suffix} if $o{suffix};

    # Now for the legacy API compatibility.
    @o{qw(tar      tarflags      torootname     tarsuffix      compressflags)} = 
    @o{qw(archiver archive_flags archive_prefix archive_suffix compress_flags)};
    # }}}

    croak "Archiver executable not found. Ouch.\n"
        if $o{archive} && !$o{archiver};
    croak "Compressor executable not found. Ouch.\n"
        if $o{compress} && !$o{compressor};

#    _debug("Parameters:\n", map { "$_: $o{$_}\n" } keys %o) if $o{debug};
    _debug('Source ',(-d $o{from}|| glob join' ',$o{from}?'does':'does not').' exist') if $o{debug};
    _debug('Destination path ',(-d $o{to}?'does':'does not').' exist') if $o{debug};

    # The files that have been backed up.
    my %backed = ();

    # Strip any trailing file separator off the destination directory.
    $o{to} =~ s#/$##;

    # Stitch together the name of the archive file.
    my $dest = "$o{to}/";
    $dest .= $o{archive_prefix} if $o{archive_prefix};
    $dest .= _time_to_string(
        format => $o{timeformat},
        use_gmtime => $o{use_gmtime},
    );
    $dest .= '.' . $o{archive_suffix} if $o{archive_suffix};
#    _debug("Archive file to make: $dest") if $o{debug};

    if ($o{archive} && $dest) {  # {{{
        purge_backups(\%o) if $o{purge_first};

        # Lock each file in the from directory.
        if ($o{lock}) {  # {{{
            if (-d $o{from}) {
                opendir FROM, $o{from} or
                    croak "Can't open directory $o{from}: $!\n";
                _debug("Locking files in $o{from}") if $o{debug};

                for my $file (grep { !-d } readdir FROM) {
                    $file = "$o{from}/$file";
                    _debug("Locking $file") if $o{debug};
                    lock($file);
                }

                closedir FROM or
                    croak "Can't close directory $o{from}: $!\n";
            }
            else {
                for my $file (grep { !-d } glob join ' ', $o{from}) {
                    _debug("Locking glob $file") if $o{debug};
                    lock($file);
                }
            }
        }  # }}}

        # Build and execute the archive command.
        my @command = ($o{archiver}, $o{archive_flags}, $dest, $o{from});
        _debug('Archive command: ', join ' ', @command) if $o{debug};
        croak "Error executing archive command: $!"
            unless system(join ' ', @command) == 0 && -e $dest;
        _debug("Made archive file: $dest") if $o{debug};

        # Lock each file in the from directory.
        if ($o{lock}) {  # {{{
            if (-d $o{from}){
                opendir FROM, $o{from} or
                    croak "Can't open directory $o{from}: $!\n";

                # unlock each non-lock file in the from directory.
                for (grep { !-d && !/\.lock$/ } readdir FROM) {
                    my $file = "$o{from}/$_";
                    _debug("Unlocking $file") if $o{debug};
                    unlock($file);
                }

                _debug("Unlocked files in $o{from}.") if $o{debug};
                closedir FROM or croak "Can't close directory $o{from}: $!\n";
            }
            else {
                for my $file (grep { !-d } glob join ' ', $o{from}) {
                    _debug("Unlocking glob $file") if $o{debug};
                    unlock($file);
                }
            }
        }  # }}}

        # Compress the archive
        if ($o{compressor} and $o{compress}) {  # {{{
            @command = ($o{compressor}, $o{compress_flags}, $dest);
            $dest .= '.' . $o{compress_suffix};
            _debug('Compression command: ', join ' ', @command) if $o{debug};
            croak "Error executing compression command: $!"
                unless system(join ' ', @command) == 0 && -e $dest;
            _debug("Made compressed file: $dest") if $o{debug};
        }  # }}}

        # Log the archive name.
        $backed{ $o{from} } = $dest;
#_debug("Backed files:\n",map{"$_: $backed{$_}\n"}keys%backed) if $o{debug}; 

        purge_backups(\%o) unless $o{purge_first};
    }  # }}}

    return \%backed;
}  # }}}

# Rotate ("only keep the latest") backups if keep is not negative.
sub purge_backups {  # {{{
    my $args = shift;

    # Okay, zero backup keeping is allowed too.
    if ($args->{keep} >= 0) {
        _debug("Rotate with $args->{keep} max in '$args->{timeformat}' format.") if $args->{debug};

        # Open the backup directory.
        opendir (DIR, $args->{to}) or
            croak "Can't open $args->{to}: $!\n";

        # Convert the YMDhms format string to a \d regular expression.
        my $regexp = _format_to_re($args->{timeformat});

        # Create the archive filename.
        my $stamp = '';
        $stamp .= $args->{archive_prefix}
            if $args->{archive} && $args->{archive_prefix};
        $stamp .= $regexp;
        $stamp .= '\\.' . $args->{archive_suffix}
            if $args->{archive}  && $args->{archive_suffix};
        $stamp .= '\\.' . $args->{compress_suffix}
            if $args->{compress} && $args->{compress_suffix};
        _debug("Looking for: $stamp") if $args->{debug};

        # Grab the names of all the files in the backup directory.
        my @files;
        while (my $file = readdir DIR) {
            _debug("Saw $file") if $args->{debug};
            if ($file =~ m/^$stamp$/) {
                _debug("Existing backup file: $file") if $args->{debug};
                push @files, $file;
            }
        }

        # Close the backup directory.
        closedir DIR or croak "Can't close $args->{to}: $!\n";

        # Keep a finite number of backup files unless the keep flag
        # is set to a negative number.
        if ((@files > $args->{keep}) and ($args->{keep} >= 0)) {
            _debug(scalar @files . " > $args->{keep} and $args->{keep} >= 0") if $args->{debug};
            @files = (reverse sort @files)[$args->{keep} .. $#files];
            for my $file (@files) {
                _debug("Unlinking $args->{to}/$file") if $args->{debug};
                unlink("$args->{to}/$file") or
                    carp "Couldn't unlink $file: $!";
            }
        }
    }
}  # }}}

sub _time_to_string {  # {{{
    my %args = @_;
    my $stamp = '';

    # No format provided.  Return an empty string.
    if (!$args{format}) {
        $stamp = '';
    }
    # Use epoch time if format is given as the word 'epoch'.
    elsif ($args{format} eq 'epoch') {
        $stamp = time;
    }
    # Convert a YMDhms format string to %0d sprintf style.
    elsif (my $printf_format = _format_to_printf($args{format})) {
        croak "Unrecognized format: $args{format}.\n"
            unless $printf_format;

        my ($sec, $min, $hr, $dy, $mo, $yr) =
            $args{use_gmtime} ? gmtime : localtime;

        $stamp = sprintf $printf_format,
            1900 + $yr, ++$mo, $dy, $hr, $min, $sec;
    }

    return $stamp;
}

# Convert YMDhms to \d.
sub _format_to_re {
    my $format = shift;
    $format =~ s/[dhmsy]/\\d/ig;
    return $format;
}

# Convert YMDhms to printf format.
sub _format_to_printf {
    my $format = shift;

    my $n = 0;

    for my $char (qw(Y M D h m s)) {
        $n++ while $format =~ /$char/g;
        $n = '%0'. $n .'d';
        $format =~ s/$char+/$n/;
        $n = 0;
    }

    return $format;
}  # }}}

sub _debug { print @_, "\n"; }

1;
__END__