hometar

#!/usr/bin/env perl

use Modern::Perl '2009';    # Enable Perl 5.10 features
use strict;                 # Included so that percritic does not complain
use warnings;               #                 ditto
use 5.010;                  # Only works under Perl 5.10 and later
use autodie qw( :all );     # Make system functions either succeed or die
use strictures 2;           # Turn on strict and make most carpings fatal

use Carp;
use Cwd;
use English;
use Getopt::Euclid;
use POSIX;
use Readonly;

##############################################################################
# Usage      : remove_old_tars( \%options_ref );
# Purpose    : Only keeps the newest archives that match the given pattern
#              if options_ref->{'remove'} is true
# Returns    : Nothing
# Parameters : $options_ref - a reference to a hash table containing:
#                   'pattern':  the glob pattern of preexisting tar files
#                   'keep':     the number of existsing tars to keep
#                   'remove':   whether or not to proceed with the removal of
#                               obsolete tar files
#                   'verbose':  whether or not to output text describing
#                               non-fatal events
sub remove_old_tars {
    my $options_ref = shift
        or croak 'No options hash reference supplied';
    foreach my $key (qw( pattern keep remove verbose )) {
        if ( !defined $options_ref->{$key} ) {
            croak "Required hash key '$key' not given";
        }
    }

    if ( $options_ref->{'remove'} ) {
        my $is_verbose    = $options_ref->{'verbose'};
        my @files         = glob $options_ref->{'pattern'};
        my $num_to_remove = @files - $options_ref->{'keep'};

        foreach my $file ( splice( @files, 0, $num_to_remove ) ) {
            eval {
                unlink $file;
                say "Removed: $file" if $is_verbose;
            };
            if ($EVAL_ERROR) {
                carp "Unable to remove: $file - $EVAL_ERROR";
            }
        }
    }
    return;
}

##############################################################################
# Usage      : tar_src_dir( \%options );
# Purpose    : Archives the source directory to the destination tar
# Returns    : Nothing
# Parameters : $options_ref - a reference to a hash table containing:
#                   'src_dir':  the source directory to be tarred
#                   'dest_tar': the tar file to create
#                   'verbose':  whether or not to output text describing
#                               non-fatal events
sub tar_src_dir {
    my $options_ref = shift
        or croak 'No options hash reference supplied';
    foreach my $key (qw( src_dir dest_tar verbose )) {
        if ( !defined $options_ref->{$key} ) {
            croak "Required hash key '$key' not given";
        }
    }
    my $src_dir    = $options_ref->{ 'src_dir'  };
    my $dest_tar   = $options_ref->{ 'dest_tar' };
    my $is_verbose = $options_ref->{ 'verbose'  };

    Readonly my $TAR_FLAGS => join(
        ' ', qw(
            --create
            --preserve-permissions
            --atime-preserve
            --use-compress-program='pigz'
            )
    );

    # Determine the home directory

    my $index = rindex($src_dir, '/');
    my $base_dir = substr( $src_dir, 0, $index);
    my $home_dir = substr( $src_dir, $index + 1);

    # Using cd instead of tar's -C (i.e., directory) flag because I was
    # getting the unexpected result of only the Desktop directory being
    # archived

    my $original_dir = getcwd;
    eval { Cwd::chdir($base_dir); };
    if ($EVAL_ERROR) {
        croak "Unable to chdir to: $base_dir: $EVAL_ERROR";
        exit 1;
    }

    # Tar the source dir to $dest_tar

    eval {
        if ($is_verbose) {
            my $tar_cmd = "sudo tar $TAR_FLAGS --verbose";
            system( qq{$tar_cmd --file = "$dest_tar" $home_dir} );
        }
        else {
            my $tar_cmd = "sudo tar $TAR_FLAGS";
            system( qq{$tar_cmd --file = "$dest_tar" $home_dir &>/dev/null} );
        }
    };
    if ($EVAL_ERROR) {
        croak "Unable to create: $dest_tar: $EVAL_ERROR";
        exit 2;
    }

    # And return to the original directory

    Cwd::chdir($original_dir);
    return;
}

##############################################################################
# Usage      : change_file_owner_group( \%options );
# Purpose    : Changes the owner and group of the named file
# Returns    : Nothing
# Parameters : $options_ref - a reference to a hash table containing:
#                   'filename': the name of the file whose ownership is to
#                               be changed
#                   'user':     the name of the owner and group to assign to
#                               filename
#                   'verbose':  whether or not to output text describing
#                               non-fatal events
#                   'group':    name of the group to assign to filename;
#                               same as user if not given
sub change_file_owner_group {
    my $options_ref = shift
        or croak 'No options hash reference supplied';
    foreach my $key (qw( filename user verbose )) {
        if ( !defined $options_ref->{$key} ) {
            croak "Required hash key '$key' not given";
        }
    }
    my $filename   = $options_ref->{ 'filename' };
    my $user       = $options_ref->{ 'user'     };
    my $is_verbose = $options_ref->{ 'verbose'  };
    my $group      = $options_ref->{ 'group'    };
    if ( !defined $group ) {
        $group = $user;
    }

    eval {
        # Get the user id (uid) and group id (gid) of $user

        my $uid = getpwnam $user;
        my $gid = getgrnam $group;

        # Change the uid and gid of the given filename

        chown $uid, $gid, $filename;

        if ($is_verbose) {
            say "Changed ownership of '$filename' to $user:$group";
        }
    };
    if ($EVAL_ERROR) {
        croak "Unable to chown $filename to $user:$group - $EVAL_ERROR";
        exit 3;
    }
    return;
}

##############################################################################
# Usage      : my $fn = generate_tar_name( $dest_dir, $prefix, $suffix);
# Purpose    : Generates a unique fully qualified tar filename
# Returns    : Returns the generated tar name
# Parameters : $dest_dir - directory name to store tar file
#              $prefix   - prefix of the tar file name
#              $suffix   - suffix of the tar file name
sub generate_tar_name {
    my ( $dest_dir, $prefix, $suffix ) = @_;
    my $timestamp = POSIX::strftime( '%Y%m%d%H%M%S', localtime );
    return $dest_dir . '/' . $prefix . $timestamp . $suffix;
}

##############################################################################
# Usage      : chomp_dir $directory;
# Purpose    : Removes any trailing slashes from the given directory
# Returns    :
# Parameters : $dir - directory from which to chomp terminating slashes
sub chomp_dir {
    my $dir = shift;
    $dir =~ s{              # substitute
                 /+         # any number of slashes
                 $          # that occur at the end of the string
             }
             {}xms;         # replacing them with nothing
    return $dir;
}

# Retrieve the command-line arguments from %ARGV
# (Getopt::Euclid has already parsed the command-line and placed the results
# in %ARGV).

my $user       = $ARGV{ '--user'    };
my $src_dir    = chomp_dir( $ARGV{'--srcdir'} );
my $dest_dir   = chomp_dir( $ARGV{'--destdir'} );
my $prefix     = $ARGV{ '--prefix'  };
my $suffix     = $ARGV{ '--suffix'  };
my $keep       = $ARGV{ '--keep'    };
my $is_remove  = $ARGV{ '--remove'  };
my $is_verbose = $ARGV{ '--verbose' };

# Keep only the last $option_of{'keep'}-1 archives if $is_remove is true

remove_old_tars(
    {   'pattern' => "$dest_dir/$prefix*$suffix",
        'keep'    => $keep - 1,     # subtract 1: we will create a new one
        'remove'  => $is_remove,
        'verbose' => $is_verbose,
    }
);

# Archive the source directory to a tar in the destination dir

my $dest_tar = generate_tar_name( $dest_dir, $prefix, $suffix );
tar_src_dir(
    {   'src_dir'  => $src_dir,
        'dest_tar' => $dest_tar,
        'verbose'  => $is_verbose,
    }
);

# Change the owner and group of the generated archive file

change_file_owner_group(
    {   'filename' => $dest_tar,
        'user'     => $user,
        'verbose'  => $is_verbose,
    }
);

__END__

=head1 NAME

hometar - Archives (tars) the contents of a user's home directory

=head1 VERSION

This documentation refers to hometar version 1.0.0

=head1 USAGE

hometar [options]...

=head1 REQUIRED ARGUMENTS

=over

=item -[-]u[ser] [=] <user>

Specify the name of the owner of the archive file. The archive files user and
group will be set to this value

=item -[-]s[rcdir] [=] <srcdir>

Specify the home directory to be archived

=item -[-]d[estdir] [=] <destdir>

Specify the directory into which the archive file is to be saved

=back

=head1 OPTIONS

=over

=item -[-]p[refix]  [=] <prefix>

Specify the prefix to use for the created archive file. The default is
<prefix.default>

=for Euclid:
    prefix.default: 'home_'

=cut

=item -x [=] <suffix> | --suffix [=] <suffix>

Specify the suffix of the created archive file. The default is
'suffix.default'

=for Euclid:
 suffix.default: <.tar.gz>

=cut

=item -[-]k[eep]  [=] <keep>

Specify the number of archives to keep, including the newly created archive.
The default is <keep.default>

=for Euclid:
    keep.type: +int
    keep.default: 5

=cut

=item -[-]r[emove]  [=] [<remove>]

Specify this to enable removal of obsolete archives

=for Euclid:
    remove.type: int
    remove.default: 0
    remove.opt_default: 1

=cut

=item -[-]v[erbose]  [=] [<verbose>]

Specify this to get output of the archival process

=for Euclid:
    verbose.type: int
    verbose.default: 0
    verbose.opt_default: 1

=cut

=back

=head1 COPYRIGHT

Copyright (c) 2019 Justin Hanekom <justin_hanekom@yahoo.com>