#!perl 
package NameRotator;

use strict;
use warnings;
use Time::Local;

use constant SECONDS_PER_MINUTE => 60;
use constant SECONDS_PER_HOUR   => 60*SECONDS_PER_MINUTE;
use constant SECONDS_PER_DAY    => 24*SECONDS_PER_HOUR;
use constant SECONDS_PER_WEEK   => 7*SECONDS_PER_DAY;
use constant SECONDS_PER_MONTH  => 30*SECONDS_PER_DAY; #we define month=30days
use constant PERL_YEAR_OFFSET	=> 1900;

our $VERSION = '1.00';

# ToDo?: 
#  could expose this to simplify rule tweaks - say, add hourly rule at startup
my @rotconfig = (
		{PREFIX => 'daily', # misnomer. Only true when run once/day  
		 RETAINCOUNT => 6, 
		 ENUMBASE => 100, 
		 ROLLTHRESHOLD => SECONDS_PER_WEEK},
		 
		{PREFIX => 'weekly', 
		 RETAINCOUNT => 4, 
		 ENUMBASE => 200, 
		 ROLLTHRESHOLD => SECONDS_PER_MONTH},
		 
		{PREFIX => 'monthly',
		 RETAINCOUNT => 6, 
		 ENUMBASE => 300, 
		 ROLLTHRESHOLD => undef}
	);


# my $namer = NameRotator->new($cmdhelper, $logname);
sub new 
{
	my $class = shift;
	my ($cmdhelper, $logname) = @_;
	my $self = { 
		ROTINFO 	=> \@rotconfig,
		CMDHELPER	=> $cmdhelper,
		LOGNAME		=> $logname,
		};
	return bless $self, $class;
}
 

#
# gets string for current time (of form: YYYYMMDDhhmmss)
#
sub timestamp() {
	my ($sec,$min,$hr, $mday, $mon, $yr, $wday, $yrday, $isdst) 
			= localtime(time);
	return sprintf "".($yr+PERL_YEAR_OFFSET)."%02d%02d%02d%02d%02d",
			$mon+1,$mday, $hr,$min,$sec;
}

#
# converts a timestamp to number of seconds since 1970 epoch
#
sub stamptime {
	shift; # ignore self
	my ($stmp) = @_;
	my ($sec,$min,$hr, $mday, $mon, $yr);
	chomp $stmp;
	($yr,$mon,$mday,$hr,$min,$sec) = 
		($stmp =~ /.*(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/);
	return timelocal( $sec, $min, $hr, $mday, $mon-1, $yr - PERL_YEAR_OFFSET );
}


sub byfwddate {
	($a =~ /.*?\.(.*?)\.(.*)/);
	my $aslot  = $1;
	my $adate  = $2;
	($b =~ /.*?\.(.*?)\.(.*)/);
	my $bslot  = $1;
	my $bdate  = $2;
	$adate <=> $bdate
		or
	$aslot <=> $bslot;
		
}

sub byrevdate {
	$a =~ /.*?\.(.*?)\.(.*)/;
	my $aslot  = $1;
	my $adate  = $2;
	$b =~ /.*?\.(.*?)\.(.*)/;
	my $bslot  = $1;
	my $bdate  = $2;
	$bdate <=> $adate
		or
	$bslot <=> $aslot;
}
 
sub nextName { 
	# e.g.,  daily.1nn.YYYYMMDDhhmmss
	my ($self, $rotlevel, $stamp) = @_;
	$rotlevel = 0 unless $rotlevel;
	if ( $rotlevel >= scalar(@{$self->{ROTINFO}} ) ){
		return undef;
	}
	$stamp	= $self->timestamp() unless $stamp;	
	my $prefix 	= $self->{ROTINFO}->[$rotlevel]{PREFIX};
	my $retaincount = $self->{ROTINFO}->[$rotlevel]{RETAINCOUNT};
	my $enumbase 	= $self->{ROTINFO}->[$rotlevel]{ENUMBASE};
	my $myCmdHelper = $self->{CMDHELPER};
	my $spec 	= $myCmdHelper->qName( "$prefix*" );
	my @dirs	= $myCmdHelper->dLst( $spec );
	my $ct		= scalar(@dirs);
	my $name;
	if ($ct==0) {
		$name = "$prefix.$enumbase.";
	}
	elsif ($ct < $retaincount) {
		#find next after newest
		# get num for latest name
		my @newest = sort byrevdate @dirs;
		
		$newest[0] =~ /$prefix.(...).(\d+)/;
		my $newestTS = $2; # extra step to find newest slot for TS dups
		$spec = $myCmdHelper->qName( "$prefix.*.$newestTS" );
		my @dirsTS = reverse( $myCmdHelper->dLst( $spec ) );
		$dirsTS[0] =~ /$prefix.(...).(\d+)/;
		my $nextnum = ((($1-$enumbase) + 1) % $retaincount)+$enumbase;
		$name = "$prefix.$nextnum."; 
	}
	else {
		#find oldest (to replace)
		my @oldest = sort byfwddate @dirs;
		$oldest[0] =~ /$prefix.(...).(\d+)/; #match on oldest slotnum
		my $oldestTS = $2; # extra step to find oldest slot for TS dups
		$spec = $myCmdHelper->qName( "$prefix.*.$oldestTS" );
		my @dirsTS = $myCmdHelper->dLst( $spec );
		$dirsTS[0] =~ /$prefix.(...).(\d+)/;
		$name = "$prefix.$1.";
	}
	return $name.$stamp;
}

#
# $name argument is fully qualified current pending directory, from which 
# 	slotspec & dailyolddir can be extracted
# $rotlevel indexes current level info
# --------
#bumpedNextLvl = nextname(nextPrefix, oldstamp) # just in case
#oldestthislevel = getfirst( slotspec(name) )
#if target4current slot is open
#	return
#if no nextLevel
#	move oldestThisLevel to bumpedNextLvl
#else 
#	if isdue
#		rollName(bumpedNextLvl) #(frees next slot)
#		move oldestThisLevel to bumpedNextLevel
#	else
#		delete oldestThisLevel
#
sub rollName { #
	my $self = shift;
	my ($name, $rotlevel) = @_;
	$rotlevel = 0 unless $rotlevel;
	
	chomp $name;
	$name =~ /(.*\.\d\d\d\.)\d+$/;
	my $slotspec = "$1*"; # aka, slotmask
	
	my ($logfile, $myCmdHelper);
	$logfile	= $self->{LOGNAME};
	$myCmdHelper	= $self->{CMDHELPER};
	
	my @olddir = $myCmdHelper->dLst($slotspec); 
	if (scalar(@olddir)==0) {
		return; # nothing to remove
		}
	# all current slots are full, so dispatch oldest level entry...
	my $oldestThisLevel = $olddir[0];
	chomp $oldestThisLevel;
	$oldestThisLevel =~ /.*\.\d\d\d\.(\d{14})$/;
	
	my $oldstamp = $1; # (extracted stamp)
	my $bumpedNextLevel = $self->nextName($rotlevel+1, $oldstamp);
	if (!defined($bumpedNextLevel)) {
		$myCmdHelper->dDel( $oldestThisLevel );
	}
	else {
		my $nextprefix = $self->{ROTINFO}->[$rotlevel+1]{PREFIX};
		my $logfile = $self->{LOGNAME};
		my @nextlist = $myCmdHelper->dLst( $myCmdHelper->qName("$nextprefix*"), $logfile ); 
		if ( scalar(@nextlist)==0 ) {
			# no weekly, so move oldest daily to first weekly
			$myCmdHelper->dMov( $myCmdHelper->qName($oldestThisLevel), $myCmdHelper->qName($bumpedNextLevel), $logfile );
		}
		else {
			my ($newestnext) = sort byrevdate @nextlist;
			my $elapsedtime = $self->stamptime($oldestThisLevel) - $self->stamptime($newestnext);
			if ( $elapsedtime> $self->{ROTINFO}->[$rotlevel]{ROLLTHRESHOLD} ) {
				$self->rollName($myCmdHelper->qName($bumpedNextLevel), $rotlevel+1);

				$myCmdHelper->dMov( $myCmdHelper->qName($oldestThisLevel), $myCmdHelper->qName($bumpedNextLevel), $logfile );
			}
			else {
				$myCmdHelper->dDel( $oldestThisLevel, $logfile );
			}
		}
	}
}

sub setNextName {
	my $self = shift;
	my $logfile;
	$logfile	= $self->{LOGNAME};
	my $dname = $self->nextName();
	my $myCmdHelper	= $self->{CMDHELPER};
	$self->rollName( $myCmdHelper->qName($dname) ); #removes any existing dname slot content
	$myCmdHelper->dNew( $myCmdHelper->qName($dname), $logfile );
	return $myCmdHelper->qName($dname);
}


package NamerCmds; # mostly abstract placeholder...

	sub namerCmds { #precondition: basedir and id are defined & nonblank
		my $class = shift;
		my ($basedir, $id, $dirsep, $casesensitive) = @_;
		my $self = { 
			BASEDIR		=> $basedir,
			ID		=> $id,
			DIRSEP		=> $dirsep,
			CASESENSITIVE	=> $casesensitive?1:0, #kindofa hack
			};
		return bless $self, $class;
	}

	sub qName { # Qualify the name
		my ($self, $name) = @_;
		my ($base, $id, $tmpname);
		
		if ($self->{CASESENSITIVE}) {
			$base 	= uc( $self->{BASEDIR} );
			$id   	= uc( $self->{ID} );
			$tmpname= uc( $name );
		}
		else {
			$base 	= $self->{BASEDIR};
			$id   	= $self->{ID};
			$tmpname= $name ;
		}
		if ( substr($tmpname, 0,length($base)) eq $base )  {
			return $name;
		}
		return join( $self->{DIRSEP}, $self->{BASEDIR}, $self->{ID}, $name);
	}

package NamerCmdsRmt; # still abstract...
	our @ISA;
	
	sub namerCmdsRmt {
		@ISA = ("NamerCmds");
		my $class = shift;
		my ($basedir, $id, $dirsep, $storehost, $storeuser, $casesensitive) = @_;
		my $self = NamerCmds->namerCmds($basedir, $id, $dirsep, $casesensitive);
		$self->{STOREHOST} = $storehost;
		$self->{STOREUSER} = $storeuser;
		return bless $self, $class;
	}


package WinNamer; # this one's concrete
	our @ISA;

	sub winNamerCmds {
		@WinNamer::ISA = ("NamerCmds");
		my $class = shift;
		my ($basedir, $id) = @_;
		my $winDirSep = "\\";
		my $self = NamerCmds->namerCmds($basedir, $id, $winDirSep); 
		return bless $self, $class;
	}

	#
	# x->dNew( $fspec [,$errlog] ) 
	#
	sub dNew {
		my ($self, $fspec, $errlog)  = @_;
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>nul";
		return `mkdir $fspec $redirtail`;
	}

	#
	# x->dLst( $fspec [,$errlog] ) # order is sorted by ctime
	#
	sub dLst {
		my ($self, $fspec, $errlog)  = @_;
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>nul";
		return `dir /b/s/ad/od/tc $fspec $redirtail`;
	}

	#
	# x->dMov( $fspecSrc, $fspecDst [,$errlog] ) 
	#
	sub dMov {
		my ($self, $fspecSrc, $fspecDst, $errlog) = @_;
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>nul";
		`move $fspecSrc $fspecDst $redirtail`;
	}
	#
	# x->dDel( $fspec [,$errlog] ) 
	#

	sub dDel {
		# precondition: $fspec dir contains no subdirectories
		my ($self, $fspec, $errlog) = @_;
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>nul";
		`del /q $fspec\\* $redirtail`;
		`rmdir $fspec $redirtail`;
	}

package NixNamer; # this one's concrete
	our @ISA;

	sub nixNamerCmds {
		@NixNamer::ISA = ("NamerCmdsRmt");
		my $class = shift;
		my ($basedir, $id, $storehost, $storeuser) = @_;
		my $nixDirSep = "/";
		my $self = NamerCmdsRmt->namerCmdsRmt($basedir,$id,$nixDirSep,$storehost, $storeuser,1); 
		return bless $self, $class;
	}

	#
	# x->dNew( $fspec [,$errlog] ) 
	#
	sub dNew {
		my ($self, $fspec, $errlog)  = @_;
		my ($storehost, $user);
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>/dev/null";
		$storehost	= $self->{STOREHOST};
		$user		= $self->{STOREUSER};
		return  `ssh $user\@$storehost mkdir $fspec $redirtail`;
	}

	#
	# x->dLst( $fspec [,$errlog] )   # order is sorted by ctime
	#
	sub dLst {
		my ($self, $fspec, $errlog)  = @_;
		my ($storehost, $user);
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>/dev/null";
		$storehost	= $self->{STOREHOST};
		$user		= $self->{STOREUSER};
		return `ssh $user\@$storehost ls -1d -c --sort=time $fspec $redirtail`;
	}

	#
	# x->dMov( $fspecSrc, $fspecDst [,$errlog] ) 
	#
	sub dMov {
		my ($self, $fspecSrc, $fspecDst, $errlog) = @_;
		my ($storehost, $storeuser);
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>/dev/null";
		$storehost	= $self->{STOREHOST};
		$storeuser	= $self->{STOREUSER};
		`ssh $storeuser\@$storehost mv $fspecSrc $fspecDst $redirtail`;
	}

	#
	# x->dDel( $fspec [,$errlog] ) 
	#
	sub dDel {
		# precondition: $fspec dir contains no subdirectories
		my ($self, $fspec, $errlog) = @_;
		my ($storehost, $storeuser);;
		my $redirtail = $errlog ? " 2>>$errlog" : " 2>/dev/null";
		$storehost	= $self->{STOREHOST};
		$storeuser	= $self->{STOREUSER};
		`ssh $storeuser\@$storehost rm -f $fspec/* $redirtail`;
		`ssh $storeuser\@$storehost rmdir $fspec $redirtail`;
	}

1;

__END__

=pod

=head1 NAME

NameRotator - date based name manipulator, as for a rolling backup destination 
directory

=head1 SYNOPSIS

	use NameRotator;
	
	# Windows, local

	#   $whelper updates names on local Windows box under c:\bak\xyz\
	my $whelper = WinNamer->winNamerCmds("c:\\bak", "xyz");
	my $wnamer = NameRotator->new($whelper, "err.log");
	my $wstoredir = $wnamer->setNextName( );

	# Unix, remote
	
	#   $xhelper uses ssh to update names under bkop@bkpstore:/bak/abc/
	my $xhelper = NixNamer->nixNamerCmds("/bak", "abc","bkpstore","bkop");
	my $xnamer = NameRotator->new($xhelper, "err.log");
	my $xstoredir = $xnamer->setNextName( );

=head1 DESCRIPTION

A NameRotator instance updates names according to contained rules. This 
was developed as part of a daily backup script, so default names and rules 
make the most sense in that context. The default rules serve to automatically 
generate a sequence of daily, weekly and monthly directory names for storing 
routine backups.

NameRotator uses a helper object (derived from class NamerCmds) to do the actual 
target naming operations: create, list,move, delete. Two helper class 
definitions are provided.

=over 2

=item C<WinNamer>

Runs on a Windows box -- manipulates local directory names.

=item C<NixNamer>

Runs on a linux box -- manipulates dir names on a remote linux box via ssh

=back

Additional helpers can be readily defined for different purposes. (Different 
storage target, different transport mechanism, etc)

A user generates rule compliant names via the NameRotator::setNextName method. 
(The 'daily' tag of the default initial rule is only accurately descriptive 
when setNextName happens to be invoked daily.) Directory names generated 
by the default daily rule are of the form:

 daily.100.2010010202153456
 daily.101.2010010302153457
 daily.102.2010010402153455


The rules designate a fixed number of slots available for daily backup 
(default: 6) and when all daily slots are full, the oldest slot gets reused. 
(Note in the example daily names given above that the middle tags, 100-102, 
are slot ID's, end tag indicates a name creation time of the form 
YYYYMMDDhhmmss.) Prior to overwriting a slot, the next rule gets applied. In 
this case, when all daily slots are full, the rule indicates that if a week has
elapsed between the oldest daily name and the most recent weekly name creation, 
the oldest daily slot (and associated directory content) is automatically moved
to a new weekly slot. A similar rule exists for moving the oldest weekly slot 
to a new monthly slot.

The rules aren't currently exposed via methods, so to update rules, one must 
make the appropriate @rotconfig tweak.

=head2 METHODS


=over 2


=item C<NameRotator::new($myHelper, $logfile)>

The constructor. Returns a reference to a new NameRotator instance.

C<$myHelper> is a reference to an instance subclassed from NamerCmds.

C<$logfile> is the filename where errors will get redirected.

=item C<NameRotator::setNextName()>

This is the main function. It generates and returns a new name [slot] 
according to current context and rules. The new slot will have been put in a 
usable state. (e.g., the corresponding directory would be created and emptied).

=item C<NamerCmds::qName( $name )>

Returns a fully qualified name in the target context. Any concrete subclass of 
NamerCmds must implement a consistent set of these name manipulation methods:

 x->dNew( $fspec [,$errlog] ) # create new name w/any associated context
 x->dLst( $fspec [,$errlog] ) # list names matching $fspec (ctime order)
 x->dMov( $fspecSrc, $fspecDst [,$errlog] ) # move (use fully qualified specs)
 x->dDel( $fspec [,$errlog] ) # delete name $fspec and its associated context



=item C<WinNamer::winNamerCmds($basedir, $myId);>

Constructor. Returns reference to a new WinNamer instance. (Subclass of 
NamerCmds) Names will be manipulated in the context of local Windows directory 
at C<"$basedir\\$myId"> 


=item C<NixNamer::nixNamerCmds($basedir, $myId, $storehost, $storeuser);>

Constructor. Returns reference to a new NixNamer instance. (Subclass of 
NamerCmds) Names will be manipulated in the context of remote unix host as 
seen from a local unix ssh connection to C<"$storehost@storeuser:$basedir\\$myId">. 
Note that deaing with passwords is out of scope here. Consider using keyfiles 
if that's an issue.

=back

=head1 CAVEATS

The directory deleters in current NamerCmds implementations will fail if the 
target directory contains subdirectories. (For my initial implementation, 
content was just a collection of tarfiles, which do get deleted correctly). 
The general error handling and constraint checking really ought to be improved 
before enabling support for recursive deletes.

=head1 LICENSE

This is released under the Artistic License... 

=head1 AUTHOR

Steve Hardy -- shardy@@differentchairs.com -- 
L<http://www.differentchairs.com/NameRotator.pm.txt>

=cut