#!/usr/bin/env perl

# credit goes to toolic on perlmonks, with modifications by goibhniu
# and some local changes

=head1 NAME

B<bak> - Make a backup copy of a file

=head1 SYNOPSIS

bak file ...

=head1 DESCRIPTION

A uniquely-named backup copy of a file is created.  The file is written to a
subdirectory named C<.backup> (or C<_backup> on MSWin), which will be created
if it does not yet exist.  The name of the backup copy is the original filename
with a date and timestamp added right before the file extension.
On Unix a ~ is appended to the end, e.g. C<README.txt>
will become C<README.TIMESTAMP.txt~>

Multiple files may also be specified.

Output: A file to subdirectory named C<.backup> or C<_backup>

Example1: bak file.txt

Example2: bak *.doc

=cut

use warnings;
use strict;
use File::Copy qw();
use POSIX qw(strftime);
use File::Basename;
use Getopt::Long;

my ($bakdir, $sep);
if ($^O =~ /MSWin/)
{
    $bakdir = '_backup';
    $sep = "\\";
}
else
{
    $bakdir = '.backup';
    $sep = "/";
}
my $timestamp = strftime('%y-%m-%d.%H%M',localtime);

my %options = ();
GetOptions(\%options, "noarchive|A", "move|m", "here", "truncate|t") or die "Failed to get options";

die "Error: No files specified\n" unless @ARGV;

if ($options{noarchive})
{
    *copy_or_move = \&File::Copy::copy;
}
elsif ($options{move})
{
    *copy_or_move = \&File::Copy::move;
}
elsif ($options{truncate})
{
    *copy_or_move = sub { ! (system("cp", "-a", $_[0], $_[1]) or system("truncate", "-s", "0", $_[0])) };
}
else
{
    *copy_or_move = sub { ! system("cp", "-a", $_[0], $_[1]) };
}

my @files;

if ($^O =~ /MSWin/)
{
    # shell does not handle globs in windows so do it ourselves

    # backslash whitespace because otherwise glob will expand it into multiple
    # elements.
    @files = map { s{(\s)}{\\$1}g; glob } @ARGV;
}
else
{
    # shell handles globs in unix
    @files = @ARGV;
}

for my $oldfile (@files)
{
    # Trailing slashes cause the basename to be blank and the new name
    # construction to screw up
    $oldfile =~ s{/+$}{};

    # Split up file into basename, leading directories ($dirs), and
    # extension ($ext) (which may be blank).  $ext contains the leading
    # dot.  If $oldfile is in the current directory, $dirs is "./".
    my ($basename, $dirs, $ext) = fileparse($oldfile, qr/\.[^.]*/);

    # If $oldfile is in a different directory, make the backupdir as a
    # subdirectory of the directory $oldfile is in ($dirs) instead of
    # the current directory, UNLESS --here has been specified.
    my $realbakdir = $options{here} ? $bakdir : $dirs.$bakdir;
    mkdir $realbakdir if ! -d $realbakdir;

    my ($newbasename, $newname);
    if (-d $oldfile)
    {
        # Directories usually aren't supposed to have extensions; if they
        # have dots in them, they are usually meant to stick together (e.g.
        # "foo-1.2").  So, stick the timestamp at the end of the new name.
        $newbasename = "${basename}${ext}.${timestamp}";
    }
    else
    {
        # Files usually have extensions, so stick the timestamp between the
        # extension and the last part of the file name; this allows editors
        # to recognize the file type and perform the appropriate syntax
        # highlighting.  Yes, this messes up files like README-3.2, but
        # that's a rare case.
        $newbasename = "${basename}.${timestamp}${ext}";
    }
    # Unix backup files have '~' at the end.  Most editors take that into
    # account when determining file type.
    $newbasename .= "~" unless $^O =~ /MSWin/;

    $newname = ${realbakdir} . ${sep} . ${newbasename};

    copy_or_move($oldfile, $newname) or die "Copy failed on $oldfile: $!";

    print $newname."\n";
}