DZone Snippets is a public source code repository. Easily build up your personal collection of code snippets, categorize them with tags / keywords, and share them with the world

Snippets has posted 5883 posts at DZone. View Full User Profile

Backup

10.26.2009
| 2765 views |
  • submit to reddit
        This is a newer version of the program that is available here on CPAN:

<a href="http://ftp.perl.org/pub/CPAN/authors/id/J/JO/JOHNGH/">http://ftp.perl.org/pub/CPAN/authors/id/J/JO/JOHNGH/</a>


#!/usr/bin/perl -w
#
#  This script was developed by John Harrison (johngh@cpan),
#  using 'rename' as an example.
#
#  This script is free software; you can redistribute it
#  and/or modify it under the same terms as Perl itself.
#
# $Log: backup,v $
# Revision 1.7  2009/10/26  19:00:00 jgh
# Added -e and -t options,
# Removed dependence on Time::localtime
# Replaced use warnings with -w so it will work with Perl 5.6
# Added tests to prevent attempts to copy directories.
# Added warnings if 'move' and 'copy' flags used together.
# Updated documentation and error messages.
# Re-ordered first 'my' list.
#
# Revision 1.6  2009/09/08  00:00:00 jgh
# Fixed a bug where a directory with a trailing slash would create
# an empty file in the directory called directory/.<timestamp>,
# updated contact details & cleaned up some formatting.
#
# Revision 1.5  2006/01/26  02:45:48 jgh
# Set atime and mtime of target file to be the same as source file.
#
# Revision 1.4  2005/02/13  18:12:53  jgh
# Catch filename already with timestamp, added getopt & podified.
#
# Revision 1.3  2004/09/23  14:55:14  jgh
# First perl version (ported from shell script)
#
# Revision 1.2  2002/04/10  00:00:00  jgh
# Standardise to strings (use variables instead of $(...) in action)
#
# Revision 1.1  2002/01/05  19:50:20  jgh
# Thu Feb 21 19:50:20 GMT 2002
# Add -mv option (@a-z)
#
# Revision 1.0  2001/04/11  17:24:18  jgh
# Original shell script version for revisioning kickstart work
# (@fnc apt Brentford)

use strict;

use File::Copy;

use Getopt::Long;
Getopt::Long::Configure('bundling');

my ($do_cp, $no_ext, $force, $do_mv, $no_act, $tilde, $usage, $verbose);

die "Usage: $0 [-cefmntuv] [filenames]\n"
    unless GetOptions(
        'c|cp|copy'    => \$do_cp,
        'e|ext'        => \$no_ext,
        'f|force'      => \$force,
        'm|mv|move'    => \$do_mv,
        'n|no-act'     => \$no_act,
        't|tilde'      => \$tilde,
        'u|help|usage' => \$usage,
        'v|verbose'    => \$verbose,
    );

die <<EOT if ($usage);
Usage: $0 [-cefmntuv] [filenames]
 -c --cp --copy (default - for safety)
 -e --ext (remove 
 -f --force (overwrite existing files)
 -m --mv --move (most useful) :o)
 -n --no-act
 -t --tilde
 -u --usage (--help) (print this message)
 -v --verbose
EOT

$verbose++ if $no_act;

if (!@ARGV) {
    print "reading filenames from STDIN\n" if $verbose;
    @ARGV = <STDIN>;
    chop(@ARGV);
}

if ( $do_cp ) {

    if ( $do_mv ) {

        warn "$0: 'move' flag overiding 'copy' flag.\n";

    }
    else {

        warn "$0: Ignoring 'copy' flag (default behavior)\n";

    }

}

FILE: for (@ARGV) {

    my $file = $_;

    die "$0: File `$file' does not exist.\n" unless(-e "$file");

    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
        $atime,$mtime,$ctime,$blksize,$blocks) = stat($file);

    #
    # C's tm structure from time.h;
    # namely with sec, min, hour, mday, mon, year, wday, yday, and isdst..
    #
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
        localtime($mtime);

    my $time = sprintf "%4i%02i%02i%02i%02i%02i",
        1900 + $year, 1 + $mon, $mday, $hour, $min, $sec;

    my ($new_name, $new_ext);

    die $@ if $@;

    #
    # Remove trailing slashes in case file is (directory)/
    # (like bash gives with tab completion). That caused a bug.
    #
    $file =~ s{/+$}{}g;

    if ( $file =~ /$time/ ) {

        print "`$file' matches [$time]\n";
        next;

    }
    elsif ( $no_ext ) {

        $new_ext = "";
        $new_name = $file;

    }
    elsif ( $file =~ /\.tar\.gz$/ ) {

        ($new_name = $file) =~ s/\.tar\.gz$//g;
        $new_ext = ".tar.gz";

    }
    elsif ( $file =~ /.*\.([^\.]+)$/ ) {

        $new_ext = ".$1";
        ($new_name = $file) =~ s/$new_ext$//g;

    }
    else {

        $new_ext = "";
        $new_name = $file;

    }

    if ( $tilde ) {

        $new_name =~ s/~$//g;

    }

    my $target = "$new_name.$time$new_ext";

    if ( -e $target and !$force ) {

        warn  "$0: `$file' not renamed: `$target' already exists\n";

    }
    elsif ( $no_act ) {

        if ( $do_mv ) {

            print "`$file' -> `$target'\n" if $verbose;

        }
        elsif ( -d $file ) {

            warn "$0: Directory `$file' not renamed: do manual 'cp -rp $file $target'\n"
                if $verbose;
            next FILE;

        }
        else {

            print "`$file' -> `$file' + `$target'\n" if $verbose;

        }

    }
    else {

        if ( $do_mv and move("$file", "$target") ) {

            print "`$file' -> `$target'\n" if $verbose;

        }
        elsif ( -d $file ) {

            warn "$0: Directory `$file' not renamed: do manual 'cp -rp $file $target'\n"
                if $verbose;
            next FILE;

        }
        elsif ( copy("$file", "$target") ) {

            my $atime=(stat($file))[8];

            if ( utime($atime,$mtime,$target) ) {

                print "`$file' -> `$file' + `$target'\n" if $verbose;

            }
            else {

                die "$0: Can't set atime & mtime of '$target': $!\n";

            }

        }
        else {

            warn  "Can't backup `$file' to `$target': $!\n";

        }

    }

}

__END__

=head1 NAME

backup - renames multiple files to have their timestamp in the filename

=head1 SYNOPSIS

B<backup> S<[ B<-c> ]> S<[ B<-e> ]> S<[ B<-f> ]> S<[ B<-m> ]> S<[ B<-n> ]> S<[ B<-t> ]> S<[ B<-u> ]> S<[ B<-v> ]> S<[ I<files> ]>

=head1 DESCRIPTION

C<backup>
backs up the filenames supplied to copies which include the
original file's timestamp in their name.

e.g.

    backup FILE

would create FILE.<timestamp>

If no filenames are given on the command line, filenames
will be read via standard input (as 'rename' command does).

If the argument --move (or one of its forms) is given the
file will be renamed (the default is to create a copy).

    backup --mv FILE

=head1 OPTIONS

=over 8

=item B<-c>, B<--cp>, B<--copy>

Copy: (default action so ignored)
This is the default because it may be safer to copy a file than rename
it if it is in use (e.g. a log file) but it will use more disk space!

=item B<-e>, B<--ext>

Extension: Make the timestamp the extension instead of moving it
inside the existing one.

=item B<-f>, B<--force>

Force: overwrite existing files.

=item B<-m>, B<--mv>, B<--move>

Move: move the file instead of copying it.

=item B<-n>, B<--no-act>

No Action: show what files would have been backed up.

=item B<-t>, B<--tilde>

Tilde: Remove trailing '~' from filename before adding timestamp.

=item B<-u>, B<--usage>, B<--help>

Usage: show usage

=item B<-v>, B<--verbose>

Verbose: print names of files successfully backed up.

=back

=head1 VERSION

This documentation was last updated at Revision 1.7

=head1 ENVIRONMENT

No environment variables are used.

=head1 AUTHOR

John G. Harrison L<http://www.aotea.org/john/>

=head1 COPYRIGHT

Copyright (C) 2005, 2009 John G. Harrison, all rights reserved.

This is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

mv(1), perl(1), rename(1)

=head1 DIAGNOSTICS

If the new filename already exists or the file already has the
timestamp in its name you'll get an error.

=head1 TODO

Perhaps timestamp formatting could be specified on the command line (ala date).

The shell script version has two options, --mvtn and --cptn

=head1 BUGS

The --copy option doesn't work on directories
because File::Copy doesn't support cp -r

=head1 FEEDBACK

If you find any bugs or have suggestions...
please direct them to the serf at the monstery ( perlmonks.org )
who may be glad to hear from you...
You will find him here: http://www.perlmonks.org/?node_id=96858

=cut