#!/usr/bin/perl -w
use strict;
require 5.005;

=head1 NAME

   pfour - wrapper around p4 to provide convenience commands

=head1 SYNOPSIS

   # get full usage
   pfour

   # check in all open files, no email
   pfour checkin "a headline" "some comment" 

   # take extended comments from stdin; send email about checkin
   pfour checkin "a headline" - whoever@whowhere.com

=head1 DESCRIPTION

Whenever some aspect of perforce has got too annoying, I've added a convenience command.

The syntax is similar to p4, but the commands are all different from p4.
If it doesn't recognize a command, it passes it on to p4.

The commands at the moment are:
  expected
  joinbranch
  labelize
  leavebranch
  newbranch
  releasebranch
  rmbranch
  sweep
  unsweep
  checkin
  emailchange

Run plain "pfour" to get full usage.

=head1 Perforce File Format

Here are the (apparent) rules for perforce files (used in -x, -i, -o):

 - any field can have a single-line or multi-line value.
 - a single-line value is like "foo: value".
 - a multi-line value is like "foo:\n\tline1\n\tline2\n".
 - the lines in a multi-line value must be either entirely
   blank, or have a leading space/tab. 
 - regardless of whether a leading space or tab is used,
   when retrieved, it appears as a tab.

=head1 AUTHOR

Copyright 1998-2000 Mark D. Anderson (mda@discerning.com).

Released under the same terms as Perl.

=head1 HISTORY

1998 - I (mda) started.

1999 - Rob Chekaluk added branch/merge functions.

2000 - I do more cleanup.

=head1 TODO

Add handling of generic options like -c ahead of command,
just like p4.

=cut

####
# CPAN modules
####
use Cwd;

####
# local modules
####

####
# configuration
####
my $p4 = find_p4();

sub find_p4 {
    my @libs = split($^O =~ m/win/i ? ';' : ':', $ENV{PATH});
    for (@libs) {
	my $trial = "$_/p4";
	return $trial if -x $trial;
	return "$trial.exe" if -x "$trial.exe";
    }
    for (qw(/usr/local/bin/p4)) {
	return $_ if -x $_;
    }
    warn "couldn't find p4, just trying plain 'p4'";
    return 'p4';
}

####
# variables
####

# Gentlemen, I think it will make users' lives easier if we
# can keep these commands in alphabetical order.
my %commands = (
		checkin => ['checkin <headline> <comment> <email_to>', 
			    'Check in currently opened files, with specified comment, sending email to specified destination (optional). comment can be "-".'],
		expected => ['expected <filename>', 
			     'Updates and checks in new expected output'],
		find_old_changelists => ['find_old_changelists <number_of_days_old>', 
			     'Finds pending changelists older than the given number of days and notifies the owner via email'],
		joinbranch => ['joinbranch <product> <branch_id>', 
			      'Accesses an existing branch'],
		labelize => ['labelize <label> <description> <view>', 
			     'Creates a label'],
		leavebranch => ['leavebranch <product> <branch_id>', 
			     'Removes access to an existing branch'],
		newbranch => ['newbranch <product> <branch_id> <description> [fromlabel]', 
			      'Creates a new branch'],
		releasebranch => ['releasebranch <product> <version>', 
			     'Creates a new branch corresponding to a labeled release'],
		rmbranch => ['rmbranch <product> <branch_id>', 
			     'Removes an existing branch entirely'],
		sweep => ['sweep', 
			  'Lists files in or below . you might have forgotten to add'],
		unsweep => ['unsweep', 
			    'Lists files in or below . which are in the depot (useful for tags, etc.)'],
		emailchange => ['emailchange <change_number> <email_to>', 
			    'Send email to specified destination describing change'],

		);

####
# utilities
####
sub usage {
  my ($err) = @_;

  print $err, "\n" if $err;

  print "Usage: pfour command [options]\n";
  print "commands are any p4 command, plus:\n";
  while (my ($k, $v) = (each %commands)) {
    print "  ", $v->[0], "\n    ", $v->[1], "\n";
  }
  exit 1;
}

####
# subs for each command
####

#=====================================================================
# pf_checkin -- 
# figure out what the outstanding opened files are, submit them with
# specified comment, and possibly send out notification email.
# The notification email includes the comment, and http links to the
# specified files.
sub pf_checkin {
  my ($headline, $comment, $email_to) = @_;
  usage("insufficient arguments to checkin") unless $comment;

  # get comment, and put tabs in front for p4 operation
  if ($comment eq '-') {
    $comment = '';
    while (<STDIN>) {$comment .= $_}
  }
  my $description = "$headline\n$comment";
  $description =~ s|\n|\n\t|mg;

  # determine what the files are
  my @opened_files = `$p4 opened 2>&1`;
  my $files = "";
  my $email_files = "";
  for (@opened_files) {
    s/#\d+//;     # strip version numbers
    s/ - / # /; # make description a comment
    die "invalid line in p4 opened list: $_" unless s|//depot|\t//depot|;
    $files .= $_;
    s|//depot|http://intwww/latest_src|;
    $email_files .= $_;
  }
  die "p4 opened failed: @opened_files" unless $files;

  # prepare for submit
  # Client: $client\nUser: $user\nStatus: new
  my $input = "Change: new\nDescription:\n\t$description\nFiles:\n$files\n";
  my $outfile = "/tmp/pfour$$";
  #print "Sending this to p4 submit:\n$input\n";

  # do submit
  #open(PL, "| $p4 submit -i > $outfile 2>&1" ) || die "could not open p4 command";
  open(PL, "| $p4 submit -i 2>&1 | tee $outfile" ) || die "could not open p4 command";
  print PL "$input";
  close PL;
  #system("cat $outfile");

  # find out what happened
  open (OUTFILE, "<$outfile");
  my $results = ''; while(<OUTFILE>) {$results .= $_}
  close (OUTFILE);

  # maybe send email
  if ($email_to) {
    open(EM, "| /usr/bin/mailx -s 'checkin - $headline' $email_to");
    print EM "Headline:\n\t$headline\nComments:\n\t$comment\nFiles:\n$email_files\nResults:\n\t$results\n";
    close EM;
  }
  unlink $outfile;
}  


#=====================================================================
# pf_find_old_changelists -- 
# this finds old pending changelists and sends an email to the owning user
use Time::Local;

sub pf_find_old_changelists {
    my ($window_days) = @_;
    usage("Insufficient arguments to find_old_changelists") 
	unless $window_days;
    usage("Number of days must be positive") 
	if $window_days <= 0;

    my %user_list;
    my $window_time = time() - $window_days * 86400;
    my @pending = `$p4 changes -s pending`;

    #----------------------------------------------------
    # Find the old changelists and aggregate them by user
    #----------------------------------------------------
    for my $c (@pending) {
	if ($c =~ m|on (\d+)\/(\d+)\/(\d+) by (\S+)\@|) {
	    my $year = $1 - 1900;
	    my $mon = $2 - 1;
	    my $mday = $3;
	    my $user = $4;

	    my $changelist_time = timelocal(0, 0, 0, $mday, $mon, $year);
	    if ($changelist_time < $window_time) {
		#print "$user $c";
		push @{ $user_list{$user} }, $c;
	    } # if
	} # if

    } # for

    #----------------------------------------
    # Notify each user of his old changelists
    #----------------------------------------
    for my $u (keys %user_list) {
	open(EM, "| /usr/bin/mailx -s 'Old changelists' $u\@whowhere.com");
	print EM "You have the following pending changelists that are greater than $window_days days old:\n\n";

	for my $ch ( @{ $user_list{$u} } ) {
	    print EM "   $ch";
	}

	print EM "\n";
	print EM "To get info about a changelist:    p4 describe <changelist number>\n";
	print EM "To see the files in a changelist:  p4 opened -a | grep <changelist number>\n";
	print EM "To delete a changelist:            p4 change -d <changelist number>\n";
	close EM;
    }

  1;
}

#=====================================================================
# pf_sweep -- 
# this finds everything not checked in yet, and also not in a pending add
# it works from the cwd, and assumes that the client is set to
# something reasonable.
sub pf_sweep {
    # TODO: command line arg
    my $start = $ENV{P4TOP} || '.';
    my $dev_null = ($^O =~ m/win/i) ? '/tmp/junk.txt' : '/dev/null';
    # if we combine in stdout, then sometimes stderr/stdout get intermixed, and
    # the grep/cut gets confused
    # BUG: the no such filters out Unintelligible revision specification 'product_search.mas#'.
    # but to handle that, have to handle file names with '#' in them
  my @files = `find $start -type f | grep -v '.nfs' | xargs $p4 files 2>&1 >$dev_null | grep 'no such' | cut -f1 -d' ' | xargs $p4 opened 2>&1 | grep 'not opened' | cut -f1 -d' '`;
  for (@files) {
    #chop;
    print $_;
  }
  1;
}

#=====================================================================
# pf_unsweep -- 
# note that this lists everything in the depot -- they
# might be missing from your workspace
sub pf_unsweep {
    my $cmd = "$p4 have ./... | cut -f3 -d' '";
    print "running '$cmd'\n";
my @files = `$cmd`;
  my $wd = cwd();
  for (@files) {
    s|$wd/||;
    print;
  }
}

#=====================================================================
# pf_labelize -- 
# This assumes P4CLIENT is set.
sub pf_labelize {
  my ($label_string, $description, $view) = @_;
  usage("insufficient arguments to labelize") unless $view;

  # Convert 2-character sequences to their proper control character
  $view =~ s|\\n|\n|g;
  $view =~ s|\\t|\t|g;

  open(PL, "| $p4 label -i") || die "could not open p4 command";
  print PL "Label: ${label_string}\nDescription:\n\t${description}\nView:\n\t${view}\n";
  close PL;
  system("$p4 labelsync -l $label_string");
}

#=====================================================================
# pf_expected -- checks in new test harness expected output
# This assumes P4CLIENT is set.
sub pf_expected {
  my ($filename) = @_;
  usage("insufficient arguments to expected") unless $filename;

  open(CHANGESPEC, "$p4 change -o |") || die "could not open p4 change command";
  open(SUBMIT, "| $p4 submit -i") || die "could not open p4 submit command";

  while (<CHANGESPEC>) {
      next if /\/\/depot/ && $_ !~ /$filename/; 
      s/<enter description here>/New expected output/; 
      print SUBMIT;
  } # while

  close CHANGESPEC;
  close SUBMIT;

  print "\n";

} # pf_expected


#=====================================================================
# newbranch_editclient -- adds a branch to my client view
sub newbranch_editclient {
    my ($branchname) = @_;

    open(CLIENT_OLD, "$p4 client -o |") 
	|| die "Could not open old client";
    open(CLIENT_NEW, "| $p4 client -i") 
	|| die "Could not open p4 client command";

    while (<CLIENT_OLD>) {
	print CLIENT_NEW;
    } # while

    print CLIENT_NEW "\t//depot/${branchname}/... //$ENV{'P4CLIENT'}/${branchname}/...";

    close CLIENT_OLD;
    close CLIENT_NEW;
} # newbranch_editclient


#=====================================================================
# pf_releasebranch -- creates a branch corresponding to a pre-labeled release
sub pf_releasebranch {
  my ($product, $id) = @_;
  die("Insufficient arguments") unless $product && $id;

  my $desc = "\"Branch for ${product}-${id} release\"";
  &pf_newbranch($product, $id, $desc, "${product}-${id}-label");

} # pf_releasebranch


#=====================================================================
# pf_newbranch -- creates a new branch using a 4-step process
sub pf_newbranch {
  my ($product, $id, $description, $fromlabel) = @_;
  die("Insufficient arguments") unless $product && $id && $description;

  my $branchname = "${product}-${id}";

  #------------------
  # Is P4CLIENT set?
  #------------------
  die "P4CLIENT variable is not set"
      if (! defined $ENV{'P4CLIENT'} || $ENV{'P4CLIENT'} eq "");

  #------------------------
  # Does the product exist?
  #------------------------
  my @files = `$p4 files //depot/${product}/... 2>&1`;
  die "Product $product does not exist" 
      if scalar(grep /no such file/, @files) > 0;

  #--------------------------------
  # Does the branch already exist?
  #--------------------------------
  my @branches = `$p4 branches 2>&1`;
  my $exists = scalar(grep /^Branch $branchname/, @branches) == 0 ? 0 : 1;
  die "Branch $branchname already exists" if $exists;

  #------------------------------
  # Was the branch ever created?
  #------------------------------
  my @integrated = `$p4 integrated //depot/${branchname}/... 2>&1`;
  my $former = scalar(grep /no file\(s\) integrated/, @integrated) > 0 ? 0 : 1;
  die "$branchname is a former branch" if $former;

  #---------------------------------
  # Does the associated label exist?
  #---------------------------------
  if (defined $fromlabel) {
      my @labels = `$p4 labels 2>&1`;
      my $labelexists = scalar(grep /\s$fromlabel\s/, @labels) == 0 ? 0 : 1;
      die "Label $fromlabel does not exist" if ! $labelexists;
  }

  #---------------------------
  # Step 1: Create the branch 
  #---------------------------
  print "Creating new branch $branchname. Please standby...\n";
  open(BRANCH_SAMPLE, "$p4 branch -o $branchname |") 
      || die "could not open branch sample";
  open(BRANCH, "| $p4 branch -i") 
      || die "could not open p4 branch command";

  while (<BRANCH_SAMPLE>) {
      s|(//depot/)(... //depot/)(...)|${1}${product}/${2}${branchname}/${3}|g; 
  print BRANCH;
  } # while

  close BRANCH;
  close BRANCH_SAMPLE;

  #-----------------------------------------
  # Step 2: Add the branch to my client view
  #-----------------------------------------
  &newbranch_editclient($branchname);

  #-------------------------------------------------
  # Step 3: Integrate the new files for branching
  #
  # Branch from the associated label if requested.
  # This assumes a label naming convention of
  # <product>-<version>-label.
  #-------------------------------------------------
  my $filepattern = "";
  if (defined $fromlabel) {
      $filepattern = "//depot/${branchname}/...\@${fromlabel}";
  }

  `$p4 integrate -b $branchname $filepattern 2>&1`;

  #----------------
  # Step 4: Submit
  #----------------
  open(CHANGESPEC, "$p4 change -o |") 
    || die "Could not open p4 change command";
  open(SUBMIT, "| $p4 submit -i") 
    || die "Could not open p4 submit command";

  while (<CHANGESPEC>) {
      next if /\/\/depot/ && $_ !~ /$branchname/; 
      s/<enter description here>/$description/; 
      print SUBMIT;
  } # while

  close CHANGESPEC;
  close SUBMIT;

  print "Done.\n";
} # pf_newbranch


#=====================================================================
# pf_joinbranch -- joins an existing branch
sub pf_joinbranch {
  my ($product, $id) = @_;
  die("Insufficient arguments") unless $product && $id;

  my $branchname = "${product}-${id}";

  #------------------
  # Is P4CLIENT set?
  #------------------
  die "P4CLIENT variable is not set"
      if (! defined $ENV{'P4CLIENT'} || $ENV{'P4CLIENT'} eq "");

  #------------------------
  # Does the product exist?
  #------------------------
  my @files = `$p4 files //depot/${product}/... 2>&1`;
  die "Product $product does not exist" 
      if scalar(grep /no such file/, @files) > 0;

  #------------------------
  # Does the branch exist?
  #------------------------
  my @branches = `$p4 branches 2>&1`;
  my $exists = scalar(grep /^Branch $branchname/, @branches) == 0 ? 0 : 1;
  die "Branch $branchname does not exist" if ! $exists;

  #------------------------------------------------------------
  # Join the branch by adding it to my client view and syncing.
  #------------------------------------------------------------
  &newbranch_editclient($branchname);

  print "Joining existing branch $branchname. Please standby...\n";
  my @sync = `$p4 sync //depot/${branchname}/... 2>&1`;

  print "Done.\n";
} # pf_joinbranch


#=====================================================================
# rmbranch_editclient -- removes a branch from my client view
sub rmbranch_editclient {
    my ($branchname) = @_;

    open(CLIENT_OLD, "$p4 client -o |") 
	|| die "Could not open old client";
    open(CLIENT_NEW, "| $p4 client -i") 
	|| die "Could not open p4 client command";

    while (<CLIENT_OLD>) {
	next if m|//depot/$branchname/|;
	print CLIENT_NEW;
    } # while

    close CLIENT_OLD;
    close CLIENT_NEW;
} # rmbranch_editclient


#=====================================================================
# pf_rmbranch -- leave and remove an existing branch
sub pf_rmbranch {
  my ($product, $id) = @_;
  die("Insufficient arguments") unless $product && $id;

  my $branchname = "${product}-${id}";

  #-------------------------------
  # Are environment variables set?
  #-------------------------------
  die "P4CLIENT environment variable is not set"
      if (! defined $ENV{'P4CLIENT'} || $ENV{'P4CLIENT'} eq "");

  die "HOME environment variable is not set"
      if (! defined $ENV{'HOME'} || $ENV{'HOME'} eq "");

  die "USER environment variable is not set"
      if (! defined $ENV{'USER'} || $ENV{'USER'} eq "");

  #------------------------------------
  # Make sure the branch already exists
  #------------------------------------
  my @branches = `$p4 branches 2>&1`;
  die "Branch $branchname does not exist" 
      if (grep(/^Branch $branchname/, @branches) == 0);

  #------------------------------------------
  # Make sure the branch is in my client view
  #------------------------------------------
  my @myview = `$p4 client -o`;
  die "Branch $branchname is not in your client view"
     if scalar(grep m|//depot/$branchname/\.\.\.|, @myview) == 0;

  #---------------------------
  # Make sure the files exist
  #---------------------------
  my $branch_file_root = "$ENV{'HOME'}/projects/${branchname}";
  die "$branch_file_root does not exist"
     if (! -d $branch_file_root);

  #---------------------------------------
  # Make sure I am the owner of the branch
  #---------------------------------------
  my @branch_view = `$p4 branch -o $branchname 2>&1`;
  my @ownerlines = grep /^Owner/, @branch_view;
  die "Too many owner lines in branch view" if scalar(@ownerlines) != 1;

  my $owner;
  my $ownerline = $ownerlines[0];
  if ($ownerline =~ /^Owner\:\s+(\w+)\s/) {
      $owner = $1;
  }
  else {
      die "Cannot determine owner of branch $branchname";
  }

  die "You are not the owner of branch $branchname"
      if ($owner ne $ENV{'USER'});

  #-------------------------------------------------
  # Check if any other clients are using this branch
  #-------------------------------------------------
  my @clients = `$p4 clients | awk '{print \$2}'`;
  my $client;
  my $clients_are_using = 0;
  for $client (@clients) {
      chop($client);
      next if $client eq $ENV{'P4CLIENT'};

      my @clientview = `$p4 client -o $client`;
      if (scalar(grep m|//depot/$branchname/\.\.\.|, @clientview) != 0) {
	  if (! $clients_are_using) {
	      print "+++ ERROR: The following clients are still using the branch:\n";
	      $clients_are_using = 1;
	  }
	  
	  print "\t$client\n";
      }
	  
  } # for

  exit if $clients_are_using;

  #-------------------------
  # Delete the branch itself
  #-------------------------
  # print "Deleting branch $branchname\n";
  my $out = `$p4 branch -d $branchname 2>&1`;
  print "$out";

  #------------------------
  # Remove the branch files
  #------------------------
  print "Removing files from branch $branchname. Please standby...\n";
  my @delete = `$p4 delete //depot/${branchname}/... 2>&1`;

  open(CHANGESPEC, "$p4 change -o |") 
    || die "Could not open p4 change command";
  open(SUBMIT, "| $p4 submit -i") 
    || die "Could not open p4 submit command";

  while (<CHANGESPEC>) {
      next if /\/\/depot/ && $_ !~ /$branchname/; 
      s/<enter description here>/Deletion of branch $branchname/; 
      print SUBMIT;
  } # while

  close CHANGESPEC;
  close SUBMIT;

  if (-d $branch_file_root) {
      print "Removing $branch_file_root. Please standby...\n";
      `/bin/rm -rf $branch_file_root`;
  }

  my $latest_src_root = "/home/build/latest_src/${branchname}";
  if (-d $latest_src_root) {
      print "Removing $latest_src_root. Please standby...\n";
      `/bin/rm -rf $latest_src_root`;
  }

  #--------------------------------------
  # Remove the branch from my client view
  #--------------------------------------
  &rmbranch_editclient($branchname);

} # pf_rmbranch


#=====================================================================
# pf_leavebranch -- leave an existing branch
sub pf_leavebranch {
  my ($product, $id) = @_;
  die("Insufficient arguments") unless $product && $id;

  my $branchname = "${product}-${id}";

  #-------------------------------
  # Are environment variables set?
  #-------------------------------
  die "P4CLIENT environment variable is not set"
      if (! defined $ENV{'P4CLIENT'} || $ENV{'P4CLIENT'} eq "");

  die "HOME environment variable is not set"
      if (! defined $ENV{'HOME'} || $ENV{'HOME'} eq "");

  die "USER environment variable is not set"
      if (! defined $ENV{'USER'} || $ENV{'USER'} eq "");

  #------------------------------------
  # Make sure the branch already exists
  #------------------------------------
  my @branches = `$p4 branches 2>&1`;
  die "Branch $branchname does not exist" 
      if (grep(/^Branch $branchname/, @branches) == 0);

  #------------------------------------------
  # Make sure the branch is in my client view
  #------------------------------------------
  my @myview = `$p4 client -o`;
  die "Branch $branchname is not in your client view"
      if scalar(grep m|//depot/$branchname/\.\.\.|, @myview) == 0;

  #---------------------------
  # Make sure the files exist
  #---------------------------
  my $branch_file_root = "$ENV{'HOME'}/projects/${branchname}";
  die "$branch_file_root does not exist"
      if (! -d $branch_file_root);

  #--------------------------------------
  # Remove the branch from my client view
  #--------------------------------------
  &rmbranch_editclient($branchname);

  #------------------------
  # Remove the branch files
  #------------------------
  print "Leaving existing branch $branchname. Please standby...\n";
  my @sync = `$p4 sync //depot/${branchname}/... 2>&1`;

  `/bin/rm -rf $branch_file_root`;

} # pf_leavebranch


#=====================================================================
# pf_emailchange -- 
# Send out notification email about a change.
# The notification email includes all change info with
# filenames replaced with http links to the
# specified files.
sub pf_emailchange {
  my ($change_number, $email_to) = @_;
  usage("insufficient arguments to emailchange") unless $email_to;
  my $outfile = "/tmp/pfour$$";

  # do describe change
  open(PL, "| $p4 describe $change_number 2>&1 | tee $outfile" ) || die "could not open p4 command";
  close PL;
  #system("cat $outfile");

  # find out what happened
  open (OUTFILE, "<$outfile");
  my $results = ''; while(<OUTFILE>) {$results .= $_}
  close (OUTFILE);

  $results =~ s|//depot|http://intwww/latest_src|g;
  $results =~ s|#[0-9]+ add| add|g;
  $results =~ s|#[0-9]+ delete| delete|g;
  $results =~ s|#[0-9]+ edit| edit|g;
  # maybe send email
  if ($email_to) {
    open(EM, "| /usr/bin/mailx -s 'describe change - $change_number' $email_to");
    print EM "$results\n";

    print EM "\n--------------------------------------------------\n";
    print EM "This report brought to you by 'pfour emailchange'.\n";
    close EM;
  }
  unlink $outfile;
}  

#=====================================================================
# main --
sub main {
  # flush stdout
  $| = 1;

  # if no args, give usage
  usage() if not @ARGV;

  my $cmd = shift @ARGV;
  # if it is a command we understand, do
  if ($commands{$cmd}) {
      my $args = "";
      if (@ARGV) {
	  for (@ARGV) {$args .= " '$_',"}; 
	  chop($args);
	  eval "pf_$cmd($args)";
      }
      else {
	  eval "pf_$cmd";
      }
      usage("+++ ERROR: $@") if $@;
      exit;
  }

  # otherwise hand off to p4
  my $pcmd = "$p4 $cmd @ARGV";
  print "not a special pfour command; running '$pcmd'...\n";
  system($pcmd);
}

main();