itest.pl #12

#!/usr/bin/env perl
# Usage: perl itest.pl SCRIPTFILE
#
# Contents of SCRIPTFILE are one of the following commands per line.
#
#          info
#          setp4          /path/to/p4 ...
#          cd             dirname
#
#          add            filename [numlines]
#          edit           filename [ lineno [ text ... ] ]
#          delete         filename
#          readd          filename#rev
# [-flags] undo           filename#rev
# [-flags] branch         source target
# [-flags] copy           source target
# [-flags] delete         source target
# [-flags] dirty          source target [ lineno [ text ... ] ]
# [-flags] ignore         source target
# [-flags] merge          source target
# [-flags] rename         source target
# [-flags] move           source target
# [-flags] p4copy         source target
#          tag            tagname
#
#          assert         TEST args ...
#          test           [-cMININUMGRADE] [-flags] [!]TEST args ...
#
# Tests:
#                         exist file ...                       
#                         equal file1 file2 ...
#                         base source target best1|best2 good1 ok1|ok2|ok3 ...
#                         integ source target [ destination ]
#                         ichanges source target count
#                         irange source target count
#                         baseless source target
#
# Command modifiers:
#		-edit     source target [ lineno [ text ... ] ]
#		-pend		(skips submit)
#		-prompt		(enters resolve option via prompt)
#		-revert		(reverts after submit)

use Cwd qw(chdir);      # Cwd's chdir() sets PWD, which Perforce needs.

$p4 = "p4";		# Changeable with the setp4 command.
			

$scriptLine = 0;
$editLine   = 0;
@path = ();
%tags = ();

$dbpos  = 0;
$dbscan = 0;

# Check for potentially dangerous P4PORT.  I don't trust myself.
$_ = `$p4 set P4PORT`;
chomp;
if ( /1666/ ) { print "P4PORT contains 1666: \"$_\".  Bailing.\n"; exit; }
if ( !/\d/ ) { print "You don't seem to have a P4PORT set.  Bailing.\n"; exit; }

foreach( @ARGV )
{
    if( $_ eq "-3" ) { $threeTest = 1; }
    if( $_ eq "-dbstat" ) { $dbstat = 1; }
}

foreach( @ARGV )
{
  if( /^-/ ) { next; }
  open SCRIPT, $_ or die "Unable to open $_: $!";
  while( <SCRIPT> )
  {
    $scriptLine++;
    chomp;
    $flags = "";
    $pend = 0;
    $force = 1;
    $revert = 0;

    # Do this twice to handle stuff like @TAGONE,@TAGTWO.
    if( /\@[=<>]*([A-Za-z]+)/ )
    {
	$var = $1;
        if( $tags{$var} ) {
	    s/$var/$tags{$var}/;
        } else {
            die "No such tag $var!";
        }
    }
    if( /\@[=<>]*([A-Za-z]+)/ )
    {
	$var = $1;
        if( $tags{$var} ) {
	    s/$var/$tags{$var}/;
        } else {
            die "No such tag $var!";
        }
    }

    @cmd = split /\s+/;
    $_ = shift @cmd;
    if ( !$_ )  {              $_ = shift @cmd; }
    if ( /^-/ ) { $flags = $_; $_ = shift @cmd; }
    if ( /-pend/ )   {  s/-pend//;   $pend   = 1; }
    if ( /-prompt/ ) {  s/-prompt//; $force  = 0; }
    if ( /-revert/ ) {  s/-revert//; $revert = 1; }

    if ( $_ eq '//' ) { next; }
    if ( $_ eq '#' )  { next; }
    if ( !$_ )        { next; }

    if    ( $_ eq "add"    ) { &add   ( $flags, @cmd ); }
    elsif ( $_ eq "branch" ) { &branch( $flags, @cmd ); }
    elsif ( $_ eq "copy"   ) { &copy  ( $flags, @cmd ); }
    elsif ( $_ eq "delete" ) { &delete( $flags, @cmd ); }
    elsif ( $_ eq "dirty"  ) { &dirty ( $flags, @cmd ); }
    elsif ( $_ eq "edit"   ) { &edit  ( $flags, @cmd ); }
    elsif ( $_ eq "ignore" ) { &ignore( $flags, @cmd ); }
    elsif ( $_ eq "merge"  ) { &merge ( $flags, @cmd ); }
    elsif ( $_ eq "move"   ) { &move  ( $flags, @cmd ); }
    elsif ( $_ eq "p4copy" ) { &p4copy( $flags, @cmd ); }
    elsif ( $_ eq "rename" ) { &rename( $flags, @cmd ); }
    elsif ( $_ eq "readd"  ) { &readd ( $flags, @cmd ); }
    elsif ( /-edit$/ )  { s/-edit$//; unshift @cmd, $_; 
                          &integ_edit ( $flags, @cmd ); }
    elsif ( $_ eq "revert" ) { &revert( $flags, @cmd ); }
    elsif ( $_ eq "chdir"  ) { &cd    ( $flags, @cmd ); }
    elsif ( $_ eq "cd"     ) { &cd    ( $flags, @cmd ); }
    elsif ( $_ eq "info"   ) { &info  ( $flags, @cmd ); }
    elsif ( $_ eq "setp4"  ) { &setp4 ( $flags, @cmd ); }
    elsif ( $_ eq "test"   ) { &test  ( $flags, @cmd ); }
    elsif ( $_ eq "assert" ) { &assert( $flags, @cmd ); }
    elsif ( $_ eq "tag"    ) { &tag   ( $flags, @cmd ); }
    elsif ( $_ eq "undo"   ) { &undo  ( $flags, @cmd ); }

    else { die "Unknown command \"$_\" at line $scriptLine!\n  "; }
  }
  close SCRIPT;
}

sub add
{
	my ($flags,@args) = @_;
	my ($file,$lines) = @args;
	if ( !$lines ) { $lines = 10; }

	open FILE, ">$file" or die "Couldn't write $file at line $scriptLine: $!\n  ";
	my $out = 0;
	while ( $out < $lines )
	{
	    $out++;
	    print FILE "$out: \n$out----\n";
	}
	close FILE;

	`$p4 add $file`;
	`$p4 submit -d "Add $file with $lines lines."`;
}

sub branch
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	`$p4 integ $flags $src $tgt`;
	if ( $pend ) { return; }
	`$p4 submit -d "Branch $src into $tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub copy
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	`$p4 integ $flags $src $tgt 2>&1`;
	if ( !$force ) { `echo at|$p4 resolve 2>&1`; }
	`$p4 resolve -at 2>&1`;
	if ( $pend ) { return; }
	`$p4 submit -d "Copy $src into $tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub p4copy
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;

	`$p4 copy $flags $src $tgt 2>&1`;
	if( $pend ) { return; }
	`$p4 submit -d "p4 copy $src into $tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub delete
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	if ( !$tgt ) { `$p4 delete $src 2>&1`; }
	else { `$p4 integ $flags $src $tgt 2>&1`; }

	if ( $tgt ) { $src .= " into "; }

	if ( $pend ) { return; }
	`$p4 submit -d "Delete $src$tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }	
}

sub dirty
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;
	my $line = shift @args;
	my $content = join " ", @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	`$p4 integ $flags $src $tgt`;
	`$p4 resolve -af 2>&1`;

	`chmod +w $tgt 2>&1`;
	`attrib -r $tgt 2>&1`;
	@ARGV=$tgt;
	$^I=".tmp";
	my $skip=0;
	while ( <> )
	{
	    if ( $skip )      { $skip = 0; next; }
	    if ( /^>>>>/ or /^<<<</ )    { next; }
	    if ( /^====/ )    { $skip = 1; next; }

	    if ( /^$line:/ ) { $_ = "$line: $content\n"; }
	    print;
	}

	`echo ae|$p4 resolve -f 2>&1`;
	unlink "$tgt.tmp"; 

	if ( $pend ) { return; }
	`$p4 submit -d "Dirty merge $src into $tgt."`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub edit
{
	my ($flags,@args) = @_;
	my $file = shift @args;
	my $line = shift @args;
	my $content = join " ", @args;
	if ( !$line ) { $line = ++$editLine; }
	if ( !$content ) { $content = "asdf"; }

	die "Edit of missing file $file at line $scriptLine" 
	    unless ( -e $file );

	`$p4 edit $file 2>&1`;

	$madeEdit = 0;

	@ARGV=$file;
	$^I=".tmp";
	while ( <> )
	{
	    if ( /^$line:/ ) 
	    { 
		$_ = "$line: $content\n";
		$madeEdit = 1;
	    }
	    print;
	}
	unlink "$file.tmp";

	if ( $pend ) { return; }
	`$p4 submit -d "Edit $file at line $line."`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
	die "No room to edit $file($line) at line $scriptLine!"
	    unless $madeEdit;
}

sub ignore
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	$_ = `$p4 integ $flags $src $tgt 2>&1`;

	if ( $_ eq "$src - all revision(s) already integrated.\n" )
	{   return; }

	if ( !$force ) { `echo ay|$p4 resolve 2>&1`; }
	`$p4 resolve -ay 2>&1`;

	if ( $pend ) { return; }
	`$p4 submit -d "$src ignored by $tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub integ_edit
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
        $_ = shift @args;
	($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

        `$p4 integ $flags $src $tgt`;

        if    ( $_ eq "copy" )   { `$p4 resolve -at`; }
	elsif ( $_ eq "ignore" ) { `$p4 resolve -ay`; }
	elsif ( $_ eq "merge"  ) { `$p4 resolve -am`; }
	elsif ( $_ eq "rename" ) { `$p4 delete $src`; }

        &edit ($flags,$tgt);
}

sub merge
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	$_ = `$p4 -Zdbstat integ $flags $src $tgt 2>&1`;
        &slurp_dbstat( $_ );
	if ( !$force ) { `echo am|$p4 resolve 2>&1`; }
	`$p4 resolve -am 2>&1`;

	if ( $pend ) { return; }
	`$p4 submit -d "Merge $src into $tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub move
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	
	`$p4 edit $src 2>&1`;
	`$p4 move $flags $src $tgt 2>&1`;

	if ( $pend ) { return; }
	`$p4 submit -d "Move $src to $tgt." 2>&1`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub readd
{
	my ($flags,@args) = @_;
	($_) = @args;

	`$p4 sync $_`;
	s/\#.*//;
	s/\@.*//;
	`$p4 add $_`;

	if ( $pend ) { return; }
	`$p4 submit -d "Re-add $_."`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub undo
{
	my ($flags,@args) = @_;
	($_) = @args;

	`$p4 undo $_`;
	`p4 sync ... 2>&1`;
	`p4 resolve -am 2>&1`;
	`p4 sync ... 2>&1`;
	`p4 resolve -am 2>&1`;
	if( $pend ) { return; }
	`p4 submit -d "Undo $_."`;

	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub rename
{
	my ($flags,@args) = @_;
	my ($src,$tgt) = @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	`$p4 integ $flags $src $tgt`;
	`$p4 delete $src`;

	if ( $pend ) { return; }
	`$p4 submit -d "Rename $src to $tgt."`;
	if ( $revert ) { `$p4 revert //... 2>&1`; }
}

sub revert
{
	`$p4 revert //... 2>&1`;
}

sub info
{
	$_ = `$p4 info`;
	if ( !/Server version: (.+) \(\d+\/\d+\/\d+\)\n/ )
	{
	    print "Unable to determine server version.  Connection problem?  Bailing.\n";
	    exit;
	}
	$_ = $1;

	# First two sections of version string are binary/platform.
	@version = split /\//;
	shift @version;
	shift @version;

	$_ = shift @version;
	@rela = split /\./;
	$_ = shift @version;
	@chga = split / /;

	# First two sections of release are NNNN.N release.
	$rel = shift @rela;
	$rel .= '.';
	$rel .= shift @rela;

	# First section of change is change number.
	$chg = shift @chga;

	print $rel.'/'.$chg."\n";
}

sub tag
{
	my ($flags,@args) = @_;
	my $name = shift @args;

	$_ = `p4 -Ztag -F %change% changes -m1`;
	chomp;
	$tags{$name} = $_;
}

sub cd
{
	my ($flags,@args) = @_;
	($_) = @args;
	my @dirs = split /\/|\\/;

	foreach ( @dirs )
	{
	    mkdir( $_ );
	    chdir( $_ );
	    if ( $_ eq "\.\." ) { pop @path; }
	    else { push (@path, $_); }
	}
	$editLine = 0; # assume that chdir = new case
        $dbpos = 0;
        $dbscan = 0;
	%tags = ();
}

sub setp4
{
	my ($flags,@args) = @_;
	$p4 = join " ", @args;
}

sub test
{
	my ($flags,@args) = @_;
	
	$_ = $flags;
	my $curve = "F";
	if ( /(-c([B-D]))/ )
	{
	    $curve = $2;
	    s/$1//;
	    $flags = $_;
	}
	my $grade = &get_grade( $flags, @args );

	if ( $curve && $grade gt $curve ) { $grade = $curve; }

	if ( $grade eq "F" ) { print " FAIL ("; }
	else { print " pass ("; }
	print $grade;
	print ") ";
        if( $dbstat )
        {
	    print $dbpos.'+'.$dbscan.' ';
        }
	if( $flags ne "" ) { $flags = ' ('.$flags.')'; }
	my $cmdline = join " ", @args;
	my $cmdpath = join "/", @path;
	if( $cmdpath ne "" ) { $cmdpath = '['.$cmdpath.'] '; }
	print $cmdpath . ': ' . $cmdline . $flags . "\n";
}

sub assert
{
	my ($flags,@args) = @_;
	
	my $grade = &get_grade( @_ );

	if ( $grade eq "F" ) 
	{ 
	    print "FAIL assert at line $scriptLine!\n";
	    exit 1;
	}
}

sub get_digest
{
	my $file = shift @_;
	open FSTAT, "$p4 fstat -Ol $file 2>&1|" or die "Fstat failed at $scriptLine: $!";
	while ( <FSTAT> )
	{
	    chomp;
	    if ( /\.\.\. digest ([A-Fa-f0-9]+)/ ) { return $1; }
	}
	return "b4df00d";
}

sub get_path
{
	my $file = shift @_;
	$_ = `$p4 -F %depotFile% files $file`;
	chomp;
	return $_;
}

sub get_grade
{
	my ($flags,@args) = @_;
	$_ = shift @args;
	my $cmd = $_;
	my $grade = "";
	my $invert = 0;
	if ( /^!/ ) { $invert = 1; s/^!//; }

	if    ( $_ eq "exist" ) { $grade = &test_exist( $flags,@args ); }
	elsif ( $_ eq "equal" ) { $grade = &test_equal( $flags,@args ); }
	elsif ( $_ eq "base"  ) { $grade = &test_base ( $flags,@args ); }
	elsif ( $_ eq "mbase" ) { $grade = &test_mbase( $flags,@args ); }
	elsif ( $_ eq "integ" ) { $grade = &test_integ( $flags,@args ); }
	elsif ( $_ eq "ichanges" ) { $grade = &test_ichanges( $flags, @args ); }
	elsif ( $_ eq "irange" )   { $grade = &test_irange( $flags, @args ); }
	elsif ( $_ eq "baseless" ) { $grade = &test_baseless( $flags, @args ); }
	else { die "Unknown test type $_ at line $scriptLine!\n  "; }

	if    ( $invert and $grade eq "F" ) { $grade = "A"; }
	elsif ( $invert and $grade eq "A" ) { $grade = "F"; }

	if ( !$grade ) { $grade = "F"; }

	return $grade;	
}

sub test_base
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	$_ = `$p4 -Zdbstat integ $flags -on $src $tgt 2>&1`;
        $_ = &slurp_dbstat( $_ );

	if ( !/ using base / ) { return "F"; }
	s/.*using base //;
	chomp;
	my $digest = &get_digest( $_ );

	my $grade = 'A';
	foreach( @args )
	{
	    my @ans = split /\?/, $_;
	    foreach( @ans )
	    {
	        if ( /^-/ ) { next; }
	        if ( $digest eq &get_digest( $_ ) ) { return $grade; }
	    }
	    $grade++;
	    if ( $grade eq "G" ) { $grade = 'F'; }
	}
	return "F";
}

sub test_mbase
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;

	$_ = `$p4 -Zdbstat integ $flags -n -Orb $src $tgt 2>&1`;
        $_ = &slurp_dbstat( $_ );

	if ( !/ must resolve move to .+ using base (.+)\n/ ) { return "F"; }
	my $base = $1;

	my $grade = 'A';
	foreach( @args )
	{
	    my @ans = split /\?/, $_;
	    foreach( @ans )
	    {
	        if ( /^-/ ) { next; }
	        if ( $base eq &get_path( $_ ) ) { return $grade; }
	    }
	    $grade++;
	    if ( $grade eq "G" ) { $grade = 'F'; }
	}
	return "F";
}

sub test_integ
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;
	my $open = shift @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	$_ = `$p4 -Zdbstat -Ztag integ $flags -n $src $tgt 2>&1`;
        $_ = &slurp_dbstat( $_ );

	/^\.\.\. depotFile (.+)\n/;
	$result = $1;
	if ( !$result ) { return "F"; }
	if ( !$open )   { return "A"; }

	$_ = `$p4 -Ztag files $open`;
	/^\.\.\. depotFile (.+)\n/;
	if ( $result eq $1 ) { return "A"; }
	return "F";
}

sub test_baseless
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	$_ = `$p4 -Zdbstat -Ztag integ $flags -on $src $tgt 2>&1`;
        $_ = &slurp_dbstat( $_ );

	/\.\.\. baseRev (.+)\n/;
	$result = $1;

	if( !$result ) 		{ return "A"; }
	if( $result eq "none" ) { return "A"; }
	return "F";
}

sub test_ichanges
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;
	my $num = shift @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

        $_ = `$p4 -Zdbstat ichanges $flags $src $tgt`;
        $_ = &slurp_dbstat( $_ );

	@got = split /\n/, $_;
	if ( @got == $num ) { return "A"; }
	return "F";
}

sub test_irange
{
	my ($flags,@args) = @_;
	my $src = shift @args;
	my $tgt = shift @args;
	my $num = shift @args;
	if ( $threeTest ) { $flags = "-3 ".$flags; }

	$_ = `$p4 -Zdbstat -Ztag integ $flags -n $src $tgt 2>&1`;
        $_ = &slurp_dbstat( $_ );

	/\.\.\. startFromRev (.+)\n/;
	$start = $1;
	if( $start eq "none" ) { $start = 0; }

	/\.\.\. endFromRev (.+)\n/;
	$end = $1;

	if( !$end ) { return "F"; }
	if( $end - $start == $num ) { return "A"; }
	return "F";	
}

sub test_equal
{
	my ($flags,@args) = @_;
	$_ = shift @args;
	my $digest = &get_digest( $_ );
	foreach( @args )
	{
	    if ( $_ and $digest ne &get_digest( $_ ) ) { return "F"; }
	}
	return "A";
}

sub test_exist
{
	my ($flags,@args) = @_;
	foreach( @args )
	{
	    if ( &test_exist_file( $_ ) eq "F" ) { return "F"; }
	}
	return "A";
}

sub test_exist_file
{
	my ($file) = @_;

	if ( !$_ ) { return "A"; } #nothing always exists.

	open FILES, "$p4 -Ztag files $file 2>&1|" or die "Unable to run p4 at $scriptLine: $!";
	while ( <FILES> )
	{
	    if ( /^\.\.\. action/ &&
		 !/delete/ ) { return "A"; }
	}
	close FILES;
	return "F";
}

sub slurp_dbstat
{
      @in = split /\n/, $_;
      @out = ();
      my $table = "";
      foreach( @in )
      {
	  if( !/^---/ )
          {
              push @out, $_;
              next;
          }
          if( /^--- db\.(\w+)/ )
          {
              $table = $1;
              next;
          }
          next if( $table ne 'integed' );
          if( /get\+pos\+scan put\+del \d+\+(\d+)\+(\d+)/ )
          {
	      $dbpos  = $1;
              $dbscan = $2;
          }
      }
      return ( join "\n", @out )."\n";
}