#! /usr/bin/env perl
# deleteBinaries.pl
########################################################################

########################################################################
# DELETE BINARY VERSIONS
#
# Programmed by David Weintraub
# Date: 10-October-2006
# Purpose:
#     This program will delete older versions of files stored as
#     binaries in Perforce.
#
#     Binaries will only be deleted under the following circumstances:
#     1). There are at least a "minimum" number of versions.
#     2). The are older or larger than permitted by the age matrix
#     3). They have no labels (unless -xlabels is specified).
#
#     The ageMatrix allows you to specify dates and file sizes. For
#     example, you might want to delete 10Gb files after one week,
#     1Gb files you can afford to keep for a month, and files under
#     100K you want to keep for 6 months. This is the only parameter
#     that cannot be specified on the command line. However, you can
#     specify it in the CONSTANTS section of this program.
#
#     The -xlabels flag operates like in the ClearCase "cleartool rmver"
#     command. If a version has a label on it, it won't be deleted
#     unless you've specified the -xlabels flag. This is useful for
#     making sure you don't delete "important" binaries you wanted to
#     keep. To remove older files, either delete the old labels, or
#     specify the "-xlabels" flag.
#
########################################################################

########################################################################
# PERL PRAGMAS
#
use warnings;
use strict;
#
########################################################################

########################################################################
# PERL MODULES
#
use File::Basename;
use Getopt::Long;
#
########################################################################

########################################################################
# CONSTANTS
#
# AgeMatrix: The numbers in pairs represent the minimum age of a file
# to delete and the minimum size to delete it. In the default, files
# under 30 days are not deleted. Files between 30 and 60 days are
# deleted if they are at least 100Mb in size, and files older than 60
# days are deleted if they are at least 100Kb in size. Delete all files
# older than 180 days no matter what's the size. NOTE: Files smaller
# than $MIN_FILE_SIZE are skipped over anyway. This prevents removing
# a revision that has already been removed.
#
our @AGE_MATRIX_DEFAULT = qw (
    30:100000000
    60:100000
    120:0

);

*MIN_FILE_SIZE = \100;			#Don't remove revisions under 100 bytes
    our $MIN_FILE_SIZE;			#Prevents removing prev removed revs.
*MIN_VERSIONS_DEFAULT = \2;
    our $MIN_VERSIONS_DEFAULT; 		#Minimum Number of Versions to Keep
*P4_CMD_DEFAULT = \"p4";
    our $P4_CMD_DEFAULT;
*P4_ROOT_DEFAULT = \"/perforce/efp_dev/backup/p4root";
    our $P4_ROOT_DEFAULT;
*DEPOT_ROOT_DEFAULT = \"//..."; 	#Start Checking at this point
    our $DEPOT_ROOT_DEFAULT;
*SECONDS_PER_DAY = \(24 * 60 * 60); 	#Hrs/Day * Min/Hr * Sec/Min
    our $SECONDS_PER_DAY;
*MESSAGE_DEFAULT = \'Version removed as of $DATE to save room';
    our $MESSAGE_DEFAULT;
*GZIP_CMD = \"gzip -9";
    our $GZIP_CMD;

#
#   ####NEED DATE FOR LOGGING
#

my @time = (localtime(time()))[3..5];
our $DATE_DEFAULT =
    sprintf ("%02d/%02d/%02d", $time[1], $time[0]++, $time[2]+1900);

#
########################################################################

######################################################################
# USAGE
#
our $USAGE =<<USAGE;

Usage: @{[basename($0)]} -p4 [-p4root <p4root>] [-root <depotRoot> ] [-xlabels] 
    [-cmd <p4Cmd> ] [-u <p4User>] [-p <p4Port>] [-P <p4Passwd>]
    [-min <minNum>] [ -log <logFile> ] [-verbose <verbose>] -stdout
    [-date <dateString>] [-message <message>] [-age <ageMatrix>]

Usage: @{[basename($0)]} -h

    WHERE:

	<p4root>:    Location of the Perforce Root (\$P4ROOT).
	             Default is "$P4_ROOT_DEFAULT".
	<depotRoot>: Where to start to search in the Depot Tree
		     Default is "$DEPOT_ROOT_DEFAULT".
	-xlabels:    Must be set to for script to delete binaries
	             which have labels attached.
	<p4Cmd>:     Perforce Command. Default is "$P4_CMD_DEFAULT".
	<p4User>:    Perforce User. Default is taken from environment.
	<p4Passwd>:  Perforce Password. Default is taken from environment.
	<p4Port>:    Perforce Port (P4PORT). Default is from environment.
	<minNum>:    Minimum Number of Binary Versions to keep.
		     Default is "$MIN_VERSIONS_DEFAULT".
	<logFile>:   The name of the file to log everything to. Default
	             is to log everything to STDOUT.
	-verbose:    Log everything and not just deletions.
	-stdout      Echo logging to STDOUT and to logfile.
	             Default is not to echo anything to STDOUT.
	<message>:   Message to replace binary. You can use \$DATE
	             as a marco for date replacement (Remember to quote
		     for the \$ sign!). The default is:
		     $MESSAGE_DEFAULT.
	<date>:      The date to use. Default is '$DATE_DEFAULT'.
	<ageMatrix>: This sets the aging matrix of the files to remove.
	             You specify the revisions via "<days>:<size>" where
		     <days> is the age in days, and <size> is the minimum
		     size of the file. You can specify multiple "-age"
		     parameters to build up an age matrix. For example,
		     if you put "-age 30:1000000000 -age 60:100000000",
		     you are saying don't remove files unless they are
		     at least 30 days old and are bigger than 1Gb. Then,
		     if the file is older than 60 days remove it if it
		     is over 100Mb in size.
	-h:          Prints this help message.
USAGE
#
########################################################################

########################################################################
# GET OPTIONS
#

#
#   ####GetOptions Parameters
#

my ($p4Root, $depotRoot, $xlabelFlag, $helpFlag);
my ($p4, $p4User, $p4Port, $p4Passwd, $minVersions);
my ($logFileName, $verboseFlag, $stdoutFlag, $messageString);
my ($dateString, @ageMatrix);

my %depotHash;		#Hash of Depot Mappings

my $results = GetOptions (
    "p4root=s"  => \$p4Root,
    "root=s"    => \$depotRoot,
    "xlabel"    => \$xlabelFlag,
    "cmd=s"     => \$p4,
    "u=s"       => \$p4User,
    "p=s"       => \$p4Port,
    "P=s"       => \$p4Passwd,
    "min=s"     => \$minVersions,
    "message=s" => \$messageString,
    "log=s"     => \$logFileName,
    "verbose"   => \$verboseFlag,
    "stdout"    => \$stdoutFlag,
    "date=s"    => \$dateString,
    "age=s"     => \@ageMatrix,
    "help"      => \$helpFlag);

unless ($results) {
    die qq(ERROR: Invalid Arguments\n$USAGE\n);
}
#
########################################################################

########################################################################
# PARSE OPTIONS
#
$p4Root =        $P4_ROOT_DEFAULT      unless ($p4Root);
$depotRoot =     $DEPOT_ROOT_DEFAULT   unless ($depotRoot);
$p4 =            $P4_CMD_DEFAULT       unless ($p4);
$minVersions =   $MIN_VERSIONS_DEFAULT unless ($minVersions);
$messageString = $MESSAGE_DEFAULT      unless ($messageString);
$dateString =    $DATE_DEFAULT         unless ($dateString);
@ageMatrix =     @AGE_MATRIX_DEFAULT   unless (@ageMatrix);

if ($p4Port) {
    $p4 = "$p4 -p $p4Port";
}
if ($p4User) {
    $p4 = "$p4 -u $p4User";
}
if ($p4Passwd) {
    $p4 = "$p4 -P $p4Passwd";
}
$messageString =~ s/\$DATE/$dateString/g;
my $totalDeleted = 0;
#
########################################################################

########################################################################
# OPEN LOGFILE
#
if ($logFileName) {
    open(LOGFILE, ">>$logFileName") or
	die qq(Can't open file "$logFileName" for writing\n");
}
#
########################################################################

########################################################################
# CONVERT AGE MATRIX TO SECONDS
#
# The Age Matrix was in days, but this really doesn't do us too
# much good. What we want to know is how many seconds since the
# epic is "X" days ago. Therefore, we now have to go through
# the age matrix and convert all of this info.
#
for (my $entry = 0; $entry <= $#ageMatrix; $entry++) {
    if ($ageMatrix[$entry] !~ /^\d+:\d+$/) {
	die qq(ERROR: Invalid Entry #$entry in Age Matrix.\n) .
	    qq(Entries must be in the form of <days>:<size> and ) .
	    qq(<days> and <size> must both be integers\n$USAGE\n);
    }
    my ($days, $size) = split(":", $ageMatrix[$entry]);
    my $age = time() - ($days * $SECONDS_PER_DAY);
    $ageMatrix[$entry] = {};	#Change Entry from Scalar to Anonymous Hash
    $ageMatrix[$entry]->{"days"} = $days;
    $ageMatrix[$entry]->{"age"} = $age;
    $ageMatrix[$entry]->{"size"} = $size;
}
#
########################################################################

########################################################################
# MAP DEPOTS
#
# I don't trust nothin'. This will map the location of the depot
# directories from the $P4ROOT. Normally, "//depot" should map to
# $P4ROOT/depot/, but one never knows...
#
{
    open(DEPOT, qq($p4 -ztag depots|)) or
	die qq(Can't execute command "$p4 -ztag depots"\n);

    my %keyHash;
    while (<DEPOT>) {
	chomp;
	if (/^\.\.\.\s+(\S+)\s+(.*)$/) {
	    $keyHash{"$1"} = "$2";
	} elsif ((exists($keyHash{"type"}))
	    and ($keyHash{"type"} eq "local")) {
	    $keyHash{"map"} =~ s#/.*##;	#Remove Suffix
	    $depotHash{$keyHash{"name"}} = $keyHash{"map"};
	}
    }
    undef %keyHash;		#Blank out for next depot
}
#
########################################################################

########################################################################
# PARSE THROUGH ALL THE FILES
#
{
    open(FILES, qq($p4 -ztag files $depotRoot|)) or
	die qq(Can't execute command "$p4 -ztag files $depotRoot"\n);

    my %keyHash;
    while (<FILES>) {
	chomp;
	if (/\.\.\.\s+(\S+)\s+(.*)$/) {
	    $keyHash{"$1"} = "$2";
	} elsif (exists($keyHash{"depotFile"})) {
	    my $fileName = $keyHash{"depotFile"};
#
#   ####Remap $filename to Actual File in Depot Name
#
	    (my $dirName = $fileName) =~ s#//([^/]+)##; #Remove Depot Prefix
	    if (not exists($depotHash{$1})) {
		logit (qq(File "$fileName" is not in a local depot), 0);
		next;
	    }
	    $dirName = "$P4_ROOT_DEFAULT/$depotHash{$1}" . "$dirName,d";
	    deleteBinary($dirName, $fileName) if (-d "$dirName");
	}
    }
    logit(qq(TOTAL DELETE: $totalDeleted bytes), 0);
}
#
########################################################################

########################################################################
# SUB DELETE BINARY
#
#
# This routine will go through each file that is suspected of being
# a binary file, and delete the oldest versions.

sub deleteBinary {
    my $dirName = shift;	#Directory Name on Disk
    my $fileName = shift;	#File in Perforce Depot

#
#   ####Get Information on ALL versions of the file
#

    open(REVISION, qq($p4 -ztag files -a "$fileName"|)) or
	die qq(Can't execute "$p4 -ztag files -a '$fileName'"\n);

    my %keyHash;
    my $versionCount = 0;
REVISION:
    while (<REVISION>) {
    my $fileSize;
	chomp;
	if(/\.\.\.\s+(\S+)\s+(.*)$/) {
	    $keyHash{"$1"} = "$2";
	} elsif (exists($keyHash{"rev"})) {
	    $versionCount++;
	    my $rev = $keyHash{"rev"};
	    my $fileDate = $keyHash{"time"};
	    my $fileType = $keyHash{"type"};
	    my $unixFileName;
	    if ($fileType =~ /^u.*binary$/) {
		$unixFileName = "$dirName/1.$rev";
	    } else {
		$unixFileName = "$dirName/1.$rev.gz";
	    }
	    if ($fileSize = (-s "$unixFileName")) {

#
#  ####Make sure we have enough versions
#
		
		if ($fileSize <= $MIN_FILE_SIZE) {
		    logit(qq(File "$unixFileName" already removed), 0);
		    next REVISION;
		}
		if ($versionCount <= $minVersions) {
		    logit ((qq(Keeping "$unixFileName": )
			. qq(Low Version Count: $versionCount)), 1);
		    next REVISION;
		}
#
#    ####Candidate for Deletion: Check For Labels
#

		if (not $xlabelFlag) {   #Skip if -xlabel was specified
		    open(LABEL, qq($p4 -s labels "$fileName#$rev,$rev"|)) or
			die qq(Couldn't execute "$p4 -s labels ) .
			    qq('$fileName#$rev'");

		    chomp (my $line = <LABEL>);	#Only look at first line
		    if ($line =~ /^info:/) {	#Version has a label on it!
			logit ((qq(Keeping "$unixFileName": )
			    . qq(Has Attached Label)), 1);
			next REVISION;
		    }
		}
#
#    ####Candidate for Deletion: Check Size and age
#
		for (my $age = 0; $age <= $#ageMatrix; $age++) {
		    if ($fileDate > $ageMatrix[$age]->{"age"}) {
			logit ((qq(Keeping "$unixFileName:" )
			    . qq(File is less than )
			    . qq($ageMatrix[$age]->{"days"} old)), 1);
			next REVISION;
		    }
		    if ($fileSize > $ageMatrix[$age]->{"size"}) {
			logit ((qq(Deleting "$unixFileName": )
			    . qq(File is over $ageMatrix[$age]->{"days"} )
			    . qq(days old and is over )
			    . qq($ageMatrix[$age]->{"size"} bytes)), 0);
#
#   ####File is large enough and old enough: "Delete" Version
#
			my $cmd;
			if ($unixFileName =~ /\.gz$/) {	#Compressed!
			    $cmd = qq(echo "$messageString" | ) .
				qq($GZIP_CMD > "$unixFileName");
			} else {	#Uncompressed
			    $cmd = qq(echo "$messageString" ) .
				qq(> "$unixFileName");
			}
			my $error = system(qq($cmd));
			if ($error) {
			    die qq(Cannot execute command $cmd: $!\n);
			}
#
#   ####File Has Been Deleted: Reverify It
#
			$cmd = qq($p4 verify -v "$fileName#$rev,$rev");
			if (-e "/dev/null") {
			    $cmd .= " > /dev/null";	#Unix/Mac OS
			} else {
			    $cmd .= " > NUL";		#MS Windows
			}
			system (qq($cmd));
			$totalDeleted += $fileSize;
			next REVISION;
		    }	#End if ($fileSize > $ageMatrix[$age]->{"size"})
		}	#End for (my $age = 0; $age <= $#ageMatrix; $age++)
		logit ((qq(Keeping "$unixFileName": )
		    . qq(File does not match Age Matrix Criteria)), 1);
	    }	#End if (my $fileSize = (-s "$unixFileName"))
	}	#End elsif(exists($keyHash{$rev}))
    }	#End while (<REVISION>)
}	#End sub deleteBinary
#
########################################################################

########################################################################
# SUBROUTINE LOGIT
#
# Logs all output. Could write to STDOUT or to logfile depending upon
# command line parameters.
#
sub logit {
    my $message = shift;
    my $messageType = shift;	#0 = Deletion. 1 = Non Delete Message

    if (($verboseFlag and $messageType == 1) or ($messageType == 0)) {
	if ($logFileName) {
	    print LOGFILE "$dateString: $message\n" or
		die qq(WARNING: CAN'T WRITE TO LOGFILE "$logFileName"!\n);
	}
	if ((not $logFileName) or ($logFileName and $stdoutFlag)) {
	    print "$dateString: $message\n";
	    print "=" x 72 . "\n";
	}
    }
}
#
########################################################################