RZ

001: # GetoptGlue.pl # euwe gooey glue
002:
003: use strict;
004: use IO::File ();
005: use File::Copy ();
006:
007: package GetoptGlue; 
008:
009: ######## backup glue ########
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: ######## callback glue factory ########
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: # GetoptGlue.pl # euwe gooey glue
128:
129: 1;