Util::SelfDestruct - Conditionally prevent execution of a script

 # Immediately prevent execution of script by dying on invocation
 # if it has already been executed once before. (The default behavior
 # is to self destruct by dying, unless instructed otherwise).
 use Util::SelfDestruct;

 # Delete the script after it is executed
 use Util::SelfDestruct('unlink');

 # Prevent execution of the script by dying if it
 # is executed after Dec 17th 2005 at 6pm
 use Util::SelfDestruct(after => '2005-12-17 18h00m00s');

 # Delete the script after execution, if it is executed
 # between 1st Dec 2005 and 17th Dec 2005 at 4:05pm
 use Util::SelfDestruct('unlink', 
                        after => '2005-12-01',
                        before => '2005-12-17 16:05:00',
                   );

 YYYYMMDDHHMMSS
 YYYYMMDD

 YYYY-MM-DD HH:MM:SS
 YYYY-MM-DD

############################################################
#
#   $Id: SelfDestruct.pm,v 1.20 2006/01/12 22:45:11 nicolaw Exp $
#   Util::SelfDestruct - Conditionally prevent execution of a script
#
#   Copyright 2005,2006 Nicola Worthington
#
#   Licensed under the Apache License, Version 2.0 (the "License");
#   you may not use this file except in compliance with the License.
#   You may obtain a copy of the License at
#
#       http://www.apache.org/licenses/LICENSE-2.0
#
#   Unless required by applicable law or agreed to in writing, software
#   distributed under the License is distributed on an "AS IS" BASIS,
#   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#   See the License for the specific language governing permissions and
#   limitations under the License.
#
############################################################

package Util::SelfDestruct;
# vim:ts=4:sw=4:tw=78

BEGIN {
	use strict;
	use Carp qw(cluck croak);
	use Cwd qw(abs_path);
	use Fcntl qw(:DEFAULT :flock);

	use constant DEBUG => $ENV{'DEBUG'} ? 1 : 0;
	use constant PROGRAM_NAME => -e abs_path($0) ? abs_path($0) : undef;
	use constant HOME => -d (getpwuid($>))[7] ? (getpwuid($>))[7] : $ENV{HOME};
	use constant RC_FILE => HOME.'/.selfdestruct';

	use vars qw($VERSION $PARAM);
	$VERSION = '1.21' || sprintf('%d.%02d', q$Revision$ =~ /(\d+)/g);
	$PARAM = {};
}

END {
	if (my ($action,$context) = _whatActionToTake($PARAM)) {
		if ($action eq 'unlink' && !exists $PARAM->{ABORT}) {
			if (unlink(PROGRAM_NAME)) {
				cluck(__PACKAGE__.": $context");
			} else {
				croak(sprintf('Failed to unlink %s during self destruct: %s',
						PROGRAM_FILE,$!));
			}
		}
	}
}

sub import {
	my $class = shift;

	my %alias = (
			'delete'      => 'unlink',
			'erase'       => 'unlink',
		);
	my %struct = (
			'unlink' => 'bool',
			'after'  => 'value',
			'before' => 'value',
		);

	while (my $k = lc(shift(@_))) {
		$k = $alias{$k} if exists $alias{$k};
		if ($struct{$k} eq 'bool') {
			$PARAM->{$k}++;
		} else {
			$PARAM->{$k} = lc(shift(@_));
			if ($k eq 'before') {
				$PARAM->{$k} = _mungeDateTime($PARAM->{$k},'000000');
			} elsif ($k eq 'after') {
				$PARAM->{$k} = _mungeDateTime($PARAM->{$k},'235959');
			}
			delete $PARAM->{$k} unless defined $PARAM->{$k};
		}
	}

	if ((exists $PARAM->{'before'} || exists $PARAM->{'after'}) &&
		exists $PARAM->{'now'}) {
		$PARAM->{ABORT}++;
		croak "The 'now' flag cannot be used in conjunction with the ",
			"'before' or 'after' options";
	}

	DUMP('$PARAM',$PARAM);

	if (my ($action,$context) = _whatActionToTake($PARAM)) {
		if ($action eq 'die') {
			croak(__PACKAGE__.": $context");
		}
	}
	_writeExecHistory() unless exists $PARAM->{'unlink'};
}

sub _writeExecHistory {
	return _processExecHistory('write');
}

sub _readExecHistory {
	return _processExecHistory('read');
}

sub _processExecHistory {
	my $action = shift || 'read';

	my $matchInFile = 0;
	my $programName = PROGRAM_NAME;
	my $mode = (-e RC_FILE ? '+<' : '+>');

	if (open(FH,$mode,RC_FILE) && flock(FH,LOCK_EX)) {
		#seek(FH, 0, 0);
		while (my $str = <FH>) {
			chomp $str;;
			if ($str eq $programName) {
				$matchInFile++;
				last;
			}
		}
		if ($action eq 'write' && !$matchInFile) {
			print FH "$programName\n";
		}
		(flock(FH,LOCK_UN) && close(FH)) ||
			cluck(sprintf("Unable to close file handle FH for file %s: %s", RC_FILE,$!));

	} else {
		croak(sprintf("Unable to open file handle FH with exclusive lock for file '%s': %s",
				RC_FILE,$!));
	}

	return $matchInFile;
}

sub _whatActionToTake {
	my $param = shift;
	return undef if $param->{ABORT};

	my $context = '';
	my $action = exists $param->{'unlink'} ? 'unlink' : 'die';
	my $now = _unixtime2isodate(time());

	# No specific timing
	if (!exists $param->{'after'} && !exists $param->{'before'}) {
		if (exists $param->{'unlink'}) {
			$context = 'unlink after execution';
		} elsif (_readExecHistory() > 0) {
			$context = 'die on subsequent execution (only allow execution once)';
		} else {
			$action = '';
		}

	} elsif ((exists $param->{'after'} && exists $param->{'before'})
		&& $now > $param->{'after'} && $now < $param->{'before'}) {
		$context = "$now > $param->{after} and $now < $param->{before}";

	} elsif ((exists $param->{'after'} && !exists $param->{'before'})
		&& $now > $param->{'after'}) {
		$context = "$now > $param->{after}";

	} elsif ((exists $param->{'before'} && !exists $param->{'after'})
		&& $now < $param->{'before'}) {
		$context = "$now < $param->{before}";

	} else {
		$action = '';
	}

	return ($action,$context);
}

sub _mungeDateTime {
	my $str = shift || '';
	my $padding = shift || '000000';

	(my $isodate = $str) =~ s/\D//g;
	if ((length($str) - length($isodate) < 10) &&
		(my ($year,$mon,$mday,$hour,$min,$sec) =
		$isodate =~ /^\s*(19\d{2}|2\d{3})(0[1-9]|1[12])(0[1-9]|[12][0-9]|3[01])
										(?:([01][0-9]|2[0-3])([0-5][0-9])([0-5][0-9]))?\s*$/x)) {
		if (defined $hour) {
			return $isodate;
		} elsif ($padding =~ /^([01][0-9]|2[0-3])([0-5][0-9])([0-5][0-9])$/) {
			return "$isodate$padding";
		}
	}

	return undef;
}

sub _unixtime2isodate {
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
		 = localtime(shift() || time());
	$year += 1900; $mon++;
	my $isodate = sprintf('%04d%02d%02d%02d%02d%02d',
					$year,$mon,$mday,$hour,$min,$sec);
	return $isodate;
}

sub TRACE {
	return unless DEBUG;
	warn(shift());
}

sub DUMP {
	return unless DEBUG;
	eval {
		require Data::Dumper;
		warn(shift().': '.Data::Dumper::Dumper(shift()));
	}
}

1;

__END__