view release on metacpan or  search on metacpan

lib/Dev/Util/Backup.pm  view on Meta::CPAN

package Dev::Util::Backup;

use Dev::Util::Syntax;
use Exporter qw(import);

use File::Copy;
use File::Spec;
use File::Basename;
use File::Find;
use IO::File;
use Archive::Tar;

our $VERSION = version->declare("v2.19.42");

our @EXPORT_OK = qw(
    backup
);

our %EXPORT_TAGS = ( all => \@EXPORT_OK );

#where to save backup files
our $BACKUPDIR = '';

#should we preserve atime, mtime, and mode of the original
#file in all backups ?
our $PRESERVE_FILE_ATTRS = 1;

# Backup file or directory
sub backup {
    return -f $_[0] ? _backupfile(@_) : _backupdir(@_);
}

# Backup file -- takes file name and returns new file name
# This sub can DIE -- so use eval
sub _backupfile {
    my $filename = shift;

    croak "$filename is not a file\n" unless ( -e $filename );

    #backup file will have _yyyymmdd extention added to it
    my $newfile = _backup($filename);

    #preserve mode, atime, and utime of old file
    if ($PRESERVE_FILE_ATTRS) {
        my @stat = stat $filename;

        utime( $stat[8], $stat[9], $newfile );
        chmod $stat[2], $newfile;

        #preserve ownership if possible
        chown $stat[4], $stat[5], $newfile
            if ( $REAL_USER_ID == 0 || $REAL_USER_ID == $stat[4] );
    }

    return $newfile;
}

# Backup directory -- takes file name, optional compression level (2-9) and
#                     returns new archive file name
# This sub can DIE -- so use eval
sub _backupdir {
    my ( $dir, $level ) = @_;

    $level = 5 if ( !defined($level) || $level < 2 || $level > 9 );

    croak "$dir is not a directory\n" unless ( -d $dir );

    my @files;
    my $tar = Archive::Tar->new();

    # "promote" warnings from File::Find to errors
    local $SIG{ __WARN__ } = sub { croak $_[0] };

    #recursivelly add files to tar
    find(
           {  wanted   => sub { push( @files, $_ ) },
              no_chdir => 1
           },
           $dir
        );

    #save archive

    my $tmpout = IO::File->new_tmpfile() || croak "Failed to create tmpfile\n";
    binmode($tmpout);

    $tar->add_files(@files);
    $tar->write( $tmpout, $level );

    #backup file will have _yyyymmdd extention added to it
    return _backup( $dir, $tmpout );
}

# Perform file backup if necessary
# Arguments: $filename -- file/dir to backup
# Returns backup file name
sub _backup {
    my ( $filename, $fh ) = @_;

    my $input = $fh ? $fh : $filename;

    $filename =~ s/\/$//;    #remove trailing slash from paths

    my $ext   = -d $filename ? ".tar.gz" : "";
    my $mtime = ( stat $filename )[9];
    my ( $mday, $mon, $year ) = ( localtime($mtime) )[ 3 .. 5 ];

    if ( $BACKUPDIR ne '' ) {

        #backup in BUDIR directory relative to dirname
        my ( $name, $path ) = fileparse($filename);