#!/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] [=]
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] [=]
Specify the home directory to be archived
=item -[-]d[estdir] [=]
Specify the directory into which the archive file is to be saved
=back
=head1 OPTIONS
=over
=item -[-]p[refix] [=]
Specify the prefix to use for the created archive file. The default is
=for Euclid:
prefix.default: 'home_'
=cut
=item -x [=] | --suffix [=]
Specify the suffix of the created archive file. The default is
'suffix.default'
=for Euclid:
suffix.default: <.tar.gz>
=cut
=item -[-]k[eep] [=]
Specify the number of archives to keep, including the newly created archive.
The default is
=for Euclid:
keep.type: +int
keep.default: 5
=cut
=item -[-]r[emove] [=] []
Specify this to enable removal of obsolete archives
=for Euclid:
remove.type: int
remove.default: 0
remove.opt_default: 1
=cut
=item -[-]v[erbose] [=] []
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
