001:
002:
003: use strict;
004: use IO::File ();
005: use File::Copy ();
006:
007: package GetoptGlue;
008:
009:
010:
011: sub new_backup_name {
012: my ( $filename, $suffix ) = @_;
013: my $date;
014: date: {
015: my ( $y, $m, $d ) = ( localtime( time ) )[ 5, 4, 3 ];
016: my $yyyy = sprintf( "%04d", $y + 1900 );
017: my $mm = sprintf( "%02d", $m + 1 );
018: my $dd = sprintf( "%02d", $d );
019: $date = "~$yyyy~$mm~$dd";
020: }
021: my $backfile;
022: {
023: my $added = "";
024: my $n = 0;
025: backfile: {
026: $backfile = "$filename$date$added$suffix";
027: last backfile unless -e $backfile;
028: }
029: continue {
030: ++$n;
031: $added = "~" x length( $n ) . "$n";
032: redo backfile;
033: }
034: }
035: return $backfile;
036: }
037:
038:
039:
040: sub differ {
041: my $destination = $_[0];
042: return sub {
043: my @src_stat = stat $_[0];
044: unless( -e $destination ) {
045: print STDERR " OK: destination free\n" if $::debug;
046: return;
047: }
048: my @dest_stat = stat $destination;
049: for ( 0, 1, 9 ) {
050: if ( $src_stat[ $_ ] != $dest_stat[ $_ ] ) {
051: print STDERR
052: " OK: source and destination differ\n" if $::debug;
053: return;
054: }
055: }
056: die "Source and destination are the same file\n";
057: };
058: }
059:
060: sub backer {
061: my ( $strategy, $filename, $suffix ) = @_;
062: $strategy == 0 and return sub{};
063: $strategy == 1 and return sub{
064: -e $filename or return;
065: -f $filename or die "Can't remove non-file $filename\n";
066: unlink( $filename ) or die "Can't remove $filename\n";
067: print STDERR " remove $filename\n" if $::debug;
068: };
069: $strategy == 2 and return sub{
070: -e $filename or return;
071: -f $filename or die "Can't copy non-file $filename\n";
072: my $backfile = new_backup_name( $filename, $suffix );
073: File::Copy::copy( $filename, $backfile ) or die
074: "Can't copy $filename\n";
075: print STDERR " copy $filename to $backfile\n" if $::debug;
076: };
077: $strategy == 3 and return sub{
078: -e $filename or return;
079: -f $filename or die "Can't move non-file $filename\n";
080: my $backfile = new_backup_name( $filename, $suffix );
081: rename( $filename, $backfile ) or die "Can't move $filename\n";
082: print STDERR " move $filename to $backfile\n" if $::debug;
083: };
084: die;
085: }
086:
087: sub opener {
088: my ( $mode, $file ) = @_;
089: return sub {
090: $_[0] = new IO::File;
091: open( $_[0], $mode, $file ) or die "Can't open $file\n";
092: print STDERR " open $mode $file\n" if $::debug;
093: };
094: }
095:
096: sub converter {
097: my ( $departure, $destination ) = @_;
098: if ( defined $destination ) {
099: return sub {
100: rename( $departure, $destination );
101: print STDERR " move $departure to $destination\n"if $::debug;
102: $_[1] = $_[0];
103: seek( $_[1], 0, 0 );
104: truncate( $_[1], 0 );
105: print STDERR " reopen +> $destination\n" if $::debug;
106: 1;
107: }
108: }
109: else {
110: return sub {
111: $_[1] = $_[0];
112: seek( $_[1], 0, 0 );
113: truncate( $_[1], 0 );
114: print STDERR " reopen +> $departure\n" if $::debug;
115: 1;
116: }
117: }
118: }
119:
120: sub closer {
121: return sub {
122: close( $_[0] );
123: print STDERR " close\n" if $::debug;
124: };
125: }
126:
127:
128:
129: 1;