#!/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] 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 # # 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 = (); $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; @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" ) { © ( $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 ); } 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; my ($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 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 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; } 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_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 "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_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; }
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#12 | 29823 | Sam Stafford |
Check for "tag" typos and exit immediately rather than swapping in a null value (which just results in cryptic errors falling out of p4). |
||
#11 | 29778 | Sam Stafford | Make tags work with @=CHANGE. | ||
#10 | 20091 | Sam Stafford |
Fix up "tag" command to handle ranges. Tags must be all alphabetic, as this made the regex easier. |
||
#9 | 19970 | Sam Stafford |
Add a "tag" command so we can run commands at the changelist level, which is extra useful for stuff involving moves. This doesn't create a Perforce label/tag, just creates a named alias in memory for the latest changelist at that time. Tags are cleared by the "cd" command just like the internal edit counter. E.g.: add foo edit foo tag apple edit foo branch foo@apple bar branch foo#2 baz test equal bar baz |
||
#8 | 15893 | Sam Stafford |
Add "test mbase" to test move base. Note that this will return an F on old servers that don't support "integ -Or". |
||
#7 | 15889 | Sam Stafford | Pull in Pascal's changes. | ||
#6 | 10209 | Sam Stafford | Tidying up output -- no [path] in the output if no path is set. | ||
#5 | 8643 | Sam Stafford |
Include flags (if any) after test output -- very handy for comparing results with -2 vs -3! |
||
#4 | 8516 | Sam Stafford | Fix dbstat harvesting in "merge" command. | ||
#3 | 8515 | Sam Stafford |
Add -dbstat option to add db.integed pos+scan numbers (for most recent merge/test integ command) to test output. |
||
#2 | 8510 | Sam Stafford | Added 'p4 copy' to itest. | ||
#1 | 8281 | Sam Stafford |
A script I use for testing integrate. Probably not of interest to too many other people, but I wanted a quick way to link to it. |