# p4lib.pm -- library of useful functions for interfacing with Perforce
# Copyright (c) 2000-2005, Tensilica Inc.
# All rights reserved.
#
# Redistribution and use, with or without modification, are permitted provided
# that the following conditions are met:
#
# - Redistributions must retain the above copyright notice, this list of
# conditions, and the following disclaimer.
#
# - Modified software must be plainly marked as such, so as not to be
# misrepresented as being the original software.
#
# - Neither the names of the copyright holders or their contributors, nor
# any of their trademarks, may be used to endorse or promote products or
# services derived from this software without specific prior written
# permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# 2001-OCT-05 1.0 marc Initial version (pulled items from pls and p4view)
# 2001-OCT-10 1.1 marc p4intfiles: $dstrevnew now sometimes undefined when was expected
# 2002-OCT-02 1.2 marc Handle spaces in pathnames
# 2002-DEC-03 1.3 marc Add more p4 wrappers (users,groups,clients,branches,labels,dirs,files)
# 2005-APR-12 1.4 marc Update copyright/license notice.
sub p4getinfo {
# Get general info:
my ($info) = p4cmdout("info",0,1,1);
($p_user,$p_client,$p_clienthost,$p_clientroot,$p_curdir) = ("","","","","");
$info =~ s/^User name: (.*)$//m and $p_user = $1;
$info =~ s/^Client name: (.*)$//m and $p_client = $1;
$info =~ s/^Client host: (.*)$//m and $p_clienthost = $1;
$info =~ s/^Client root: (.*)$//m and $p_clientroot = $1;
$info =~ s/^Current directory: (.*)$//m and $p_curdir = $1;
}
# Called by various p4 routines here to optionally display progress
# details...
# tick("msg string" or undef) called in loop of a function
# tick("") called at end of a function
#
$tick_count = 0;
$tick_msg = "";
sub tick {
my $msg = shift;
return unless defined($msg);
if( $msg eq "" ) { # end of function?
print STDERR "\n" if $tick_count; # something was being displayed
$tick_count = 0;
} else {
if( $tick_msg ne $msg ) { # start of function
print STDERR "\n" if $tick_msg ne ""; # mid-function? shouldn't happen
print STDERR "$msg";
$tick_count = 0;
}
print STDERR "." if (++$tick_count % 100) == 0;
}
$tick_msg = $msg;
}
# Save last p4 command output, sometimes useful:
our $p4_last_info = "";
# Execute a Perforce command.
# Gather the results in various arrays according to each output line's type
# (using p4's -s command line option).
#
sub p4cmdout {
my($cmd,$showp,$doerror,$dowarn,$donum) = @_;
my $count = 0;
my $info = "";
my $text = "";
my $warning = "";
my $error = "";
my $exitcode = 0;
my $junk = "";
#print STDERR "<<$cmd>>\n";
open(OUTPIPE,"$p4prog -s $cmd|")
or die "$progname: can't exec '$p4prog -s $cmd': $!, stopped";
while( <OUTPIPE> ) {
#print STDERR "gives: $_";
print STDERR "." if $showp and (++$count % 100) == 0;
if( s/^info(\d*): //) { if($donum){$info .= ($1 eq "")?"0":$1;} $info .= $_; next; }
if( s/^text: // ) { $text .= $_; next; }
if( s/^warning: // ) { $warning .= $_; next; }
if( s/^error: // ) { $error .= $_; next; }
if( s/^exit: // ) { $exitcode = $_; chomp($exitcode); next; }
$junk .= $_;
}
close(OUTPIPE); # or warn "$progname: error closing pipe from '$cmd': $!";
print STDERR "\n" if $showp; # and $count >= 100;
$doerror and $error ne "" and die "$progname: error from '$p4prog -s $cmd': ${error}Stopped";
$dowarn and $warning ne "" and warn "$progname: warning from '$p4prog -s $cmd': $warning";
$junk eq "" or warn "$progname: unexpected output from '$p4prog -s $cmd': <<$junk>> (ignored)";
$p4_last_info = $info;
($info,$text,$warning,$error,$exitcode,$junk);
}
# Execute a Perforce command, with arbitrary large parameter input.
# Requires a temporary file...
#
sub p4cmdio {
my($cmd,$showp,$doerror,$dowarn,$donum, @parms) = @_;
my $tmpfile = "./_p4tmpcio_". $$ ."_";
open(OUT,">$tmpfile")
or die "$progname: can't create temporary file '$tmpfile': $!, stopped";
print OUT map("$_\n",@parms);
close(OUT)
or die "$progname: can't close temporary file '$tmpfile': $!, stopped";
$cmd = "-x $tmpfile $cmd";
# Note: pass zero doerror and handle error case here, to avoid leaving temp file undeleted.
my @result = p4cmdout($cmd,$showp,0,$dowarn,$donum);
unlink($tmpfile);
$doerror and $result[3] ne "" and die "$progname: error from '$p4prog -s $cmd': ".$result[3]."Stopped";
@result;
}
# Properly form a file path for passing to 'p4' on a command line.
# For now, just surround with single quotes so that spaces
# can be embedded in pathnames. These single quotes are also
# necessary to avoid expansion of '*' characters in system() calls.
# Other special characters not yet handled may require special handling here.
#
sub p4passpath {
my($path) = @_;
"'$path'";
}
# Given a file path given in arbitrary format (local, Perforce or client syntax),
# return the full file path in these three formats if 'p4 where' can map it.
# Possible return values:
# (0) # no mapping at all, or invalid path syntax
# (0,$p4path, $clipath, $locpath) # masked mapping found (effectively no map)
# (1,$p4path, $clipath, $locpath) # proper mapping found
#
sub p4where {
my($path) = @_;
my ($info) = p4cmdout("where ".p4passpath($path));
if( $info eq "" ) { # can't map? try with a sub-element
($info) = p4cmdout("where ".p4passpath("$path/--.SoMeFiLe.--"));
$info =~ s|/\-\-\.SoMeFiLe\.\-\-||gs;
}
if( $info eq "" ) {
# The requested pathname couldn't map via the client.
# Show what we can (either depot only or local files only).
return ();
}
chomp($info); $info =~ s|.*\n||s; # keep all but the last line
my $mapped = !($info =~ s|^\-||);
print STDERR "$progname: warning: path '$path' defined but unmapped by the client\n"
unless $mapped;
if( $info !~ m|^(//.*) (//.*) (/.*)$| ) { #/
die "$progname: can't parse output of $p4prog -s where '$path':\n".
"$progname: '$info'\n".
"$progname: stopped";
}
return ($mapped,$1,$2,$3); # p4path, clipath, locpath
#my ($p4path,$clipath,$locpath) = ($1,$2,$3);
#print STDERR "Depot path is $p4path\nClient path is $clipath\nLocal path is $locpath\n";
}
# Parse output of the 'p4 clients' command,
# and return it in structured format.
#
# Returns:
# array of [$cname,$croot,$ccomment]
#
sub p4clients {
my ($info) = p4cmdout("clients",0,1,1);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach (sort(split(/\n/,$info))) {
if( ! /^Client (\S+) \S+ root ([^\']+) \'\s*(.*?)\s*\'\s*$/ ) {
print STDERR "$progname: unparsable line from '$p4prog -s clients': $_\n";
next;
}
my($cname,$croot,$ccomment) = ($1,$2,$3);
#$ccomment =~ s|\s+\-?//.*||; # some people put commented out paths in here
push(@result, [$cname,$croot,$ccomment] );
}
@result;
}
# Parse output of the 'p4 branches' command,
# and return it in structured format.
#
# Returns:
# array of [$bname,$bdate,$bcomment]
#
sub p4branches {
my ($info) = p4cmdout("branches",0,1,1);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach (sort(split(/\n/,$info))) {
if( ! /^Branch (\S+) (\S+) \'\s*(.*?)\s*\'\s*$/ ) {
print STDERR "$progname: unparsable line from '$p4prog -s branches': $_\n";
next;
}
my($bname,$bdate,$bcomment) = ($1,$2,$3);
#$bcomment =~ s|\s+\-?//.*||; # some people put commented out paths in here
push(@result, [$bname,$bdate,$bcomment] );
}
@result;
}
# Parse output of the 'p4 users' command,
# and return it in structured format.
#
# Returns:
# array of [$name,$email,$fullname,$date]
#
sub p4users {
my ($info) = p4cmdout("users",0,1,1);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach (sort(split(/\n/,$info))) {
if( ! /^(\S+) \<([^\>]*)\> \((.*)\) accessed (\S+)\s*$/ ) {
print STDERR "$progname: unparsable line from '$p4prog -s users': $_\n";
next;
}
my($name,$email,$fullname,$date) = ($1,$2,$3,$4);
push(@result, [$name,$email,$fullname,$date] );
}
@result;
}
# Parse output of the 'p4 groups' command,
# and return it in structured format.
#
# Returns:
# array of $name
#
sub p4groups {
my ($user) = @_;
my $cmdline = "groups" . (defined($user)?" ".p4passpath($user):"");
my ($info) = p4cmdout($cmdline,0,1,1);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach (sort(split(/\n/,$info))) {
if( ! /^(\S+)\s*$/ ) {
print STDERR "$progname: unparsable line from '$p4prog -s $cmdline': $_\n";
next;
}
push(@result, $1);
}
@result;
}
# Parse output of the 'p4 labels' command,
# and return it in structured format.
#
# Parameters:
# $parms optional file[revRange] parameter to 'p4 labels'
#
# Returns:
# array of [$name,$date,$comment]
#
sub p4labels {
my ($filespec) = @_;
my $cmdline = "labels" . (defined($filespec)?" ".p4passpath($filespec):"");
my ($info) = p4cmdout($cmdline,0,1,1);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach (sort(split(/\n/,$info))) {
if( ! /^Label (\S+) (\S+) \'\s*(.*?)\s*\'\s*$/ ) {
print STDERR "$progname: unparsable line from '$p4prog -s $cmdline': $_\n";
next;
}
my($name,$date,$comment) = ($1,$2,$3);
push(@result, [$name,$date,$comment] );
}
@result;
}
# Return list of directories within a given Perforce directory path.
# Parse output of the 'p4 dirs' command,
# and return it in structured format.
#
# Parameters:
# $path dir[revRange] parameter (without trailing '/*', added here)
# $parms optional parameters (eg. "-C" or undef)
#
# Returns:
# array of $name (directory names only, not the full paths)
#
sub p4dirs {
my($path,$parms) = @_;
return () if $path eq "";
$parms = defined($parms) ? $parms." " : "";
my($info) = p4cmdout("dirs $parms".p4passpath("$path/*"));
$info =~ s|^.*/||mg; # only keep the directory name
chomp($info);
#return () if $info eq "";
#print STDERR "Got '$info'\n";
return split(/\n/,$info);
}
# Parse the output of a 'p4 files' or 'p4 opened' command,
# and return it in structured format.
#
# Parameters:
# $cmd p4 command to execute (eg. "files" or "opened -a")
# @args optional filepath arguments to p4 command
# Returns:
# array of [$fpath,$fname,$fvers,$action,$chgnum,$ftype,$byuser,$bycli,$lock]
#
sub p4files {
my($cmdline,@args) = @_;
foreach (@args) { $cmdline .= " ".p4passpath($_); }
my($info) = p4cmdout($cmdline);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
my %dirs = ();
foreach ( split(/\n/,$info) ) {
if( ! m%(//depot[^#]*)/([^/#]*)#(\S*) - (\S+)\s+(\S+)\s+(\S+)\s+\(([^) ]+)\)( by ([^@]+)@([^@ ]+))?( \*locked\*)?% ) {
print STDERR "$progname: unparsable line from '$p4prog -s $cmdline': $_\n";
next;
}
my($fpath,$fname,$fvers,$action,$chg,$chgnum,$ftype,$byuser,$bycli,$lock) = ($1,$2,$3,$4,$5,$6,$7,$9,$10,$11);
$lock = defined($lock);
#print "Got lock $fname '$lock'\n" if defined($lock);
if( $chgnum eq "change" ) {
$chgnum = $chg;
$chg = "change";
}
if( ($chgnum !~ /^\d+$/ and $chgnum ne "default") or $chg ne "change" ) {
print STDERR "$progname: illegal change number '$chg $chgnum' in line from '$p4prog -s $cmdline': $_\n";
}
push(@result, [$fpath,$fname,$fvers,$action,$chgnum,$ftype,$byuser,$bycli,$lock] );
#printf "%-9s #%-5s \@%-7s $fname ($fpath)\n", $ftype, $fvers, $chgnum;
}
return @result;
}
# Parse the output of a 'p4 have' command,
# and return it in structured format.
#
# Parameters:
# @args optional filepath arguments to p4 have
# Returns:
# array of [$fpath,$fname,$fvers,$flocal]
#
sub p4have {
my(@args) = @_;
my $cmdline = "have";
foreach (@args) { $cmdline .= " ".p4passpath($_); }
my($info) = p4cmdout($cmdline);
#$info =~ s|^.*/||mg; # only keep the directory name
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
foreach ( split(/\n/,$info) ) {
if( ! m@^(//depot[^#]*)/([^/#]*)#(\S*) - ([^#]+)$@ ) {
print STDERR "$progname: unparsable line from '$p4prog -s $cmdline: $_\n";
next;
}
my($fpath,$fname,$fvers,$flocal) = ($1,$2,$3,$4);
push(@result, [$fpath,$fname,$fvers,$flocal] );
#printf "#%-5s $fname ($fpath)\n", $fvers;
}
return @result;
}
# Parse output of a 'p4 resolve -n' (and 'p4 resolved'?) command,
# and return it in structured format.
#
# Parameters:
# $cmdline p4 command to execute (minus p4)
# $msg if defined as a non-empty string, $msg is printed
# with "."s to indicate progress
# Returns:
# array of [$locpath,$action,$respath,$resversfrom,$resversto or undef,$allvers]
#
sub p4resfiles_unused {
my($cmdline,$msg) = @_;
my($info) = p4cmdout($cmdline,defined($msg));
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach ( split(/\n/,$info) ) {
tick($msg);
if( ! m%(/[^#]+[^#/]) - ([^/]+)\s+(//depot[^#]*)#([0-9]+)(,#([0-9]+)|)% ) {
print STDERR "$progname: unparsable line from '$p4prog -s $cmdline': $_\n";
next;
}
my($locpath,$action,$respath,$resvers,$resv2,$resv3) = ($1,$2,$3,$4,$5,$6);
defined($resv3) or $resv3 = "";
my $allvers = "#$resvers"; $allvers .= $resv2 if defined($resv2);
push(@result, [$locpath,$action,$respath,$resvers,$resv3,$allvers] );
#print STDERR "*** $action '$locpath' '$respath'$allvers $resvers,$resv3.\n";
}
tick("");
return @result;
}
# Parse output of a 'p4 integrate' command,
# and return it in a structured format.
#
# Parameters:
# $cmdline p4 command to execute (minus p4)
# $msg if defined as a non-empty string, $msg is printed
# with "."s to indicate progress
# Returns:
# array of [$dstpath,$dstrevnew,$action,$srcpath,$srcreva,$srcrevb or undef,$srcrev]
#
sub p4intfiles {
my($cmdline,$msg,@opts) = @_;
my($info) = p4cmdout($cmdline,defined($msg),@opts);
chomp($info);
#print STDERR "Got '$info'\n";
my @result = ();
#print STDERR "$msg";
foreach ( split(/\n/,$info) ) {
tick($msg);
if( ! m%(//depot[^#]+[^#/])(#([0-9]+))? - ([^/]+(/[^/]+)?)\s+from\s+(//depot[^#]*)#([0-9]+)(,#([0-9]+))?( without \-([id]) flag)?$% ) {
print STDERR "$progname: unparsable line from '$p4prog -s $cmdline': <<$_>>\n";
next;
}
my($dstpath,$dstrev,$dstrevnew,$action,$ign1,$srcpath,$srcreva,$srcrevend,$srcrevb,$ign2,$flag) = ($1,$2,$3,$4,$5,$6,$7,$8,$9,$10,$11);
defined($srcrevb) or $srcrevb = $srcreva;
if( $action eq "can't integrate" ) {
$flag = "i" unless defined($flag);
$action = "no$flag";
$dstrevnew = "";
} else {
defined($dstrevnew)
or warn "$progname: missing destination path revision\n"
."$progname: p4 integrate output line: $_\n"
."$progname: cmdline: $cmdline\n";
defined($dstrevnew) or $dstrevnew = "";
}
my $srcrev = "#$srcreva"; $srcrev .= $srcrevend if defined($srcrevend);
push(@result, [$dstpath,$dstrevnew,$action,$srcpath,$srcreva,$srcrevb,$srcrev] );
#print STDERR "*** $action '$dstpath' $dstrevnew '$srcpath'$srcrev $srcreva,$srcrevb.\n";
}
tick("");
return @result;
}
# Parse output of a 'p4 filelog -l' command for a single Perforce file,
# and return the results in a structured form.
#
# Parameters:
# $path filepath to pass to 'p4 filelog -l'
# $n starting index to store in returned array of revs
# Returns:
# ($depotpath,@array_of_revs)
# where array_of_revs is array of (increasing $revnum from #1, increasing $revchg):
# [$depotpath, $n++,$revnum,$revchg,$revact,$revdate,$revuser,$revclient,$revtype,
# $revcomment, \@revpaths, \@from_paths,\@bout_paths, $head]
# and where revpaths, from_paths, and bout_paths are arrays of:
# [$from,$baction,$bpath,$brevall,$brevlo,$brevhi]
#
sub p4filelog {
my ($path,$n) = @_;
print STDERR "Calling filelog -l '$path'\n" if $v1;
my($info) = p4cmdout("filelog -l ".p4passpath($path),0,1,0,1);
chomp($info);
my @info = split(/\n/,$info);
my $depotpath = shift(@info);
$depotpath =~ s/^0// or warn "$progname: unexpected output format ($depotpath)";
#print STDERR "Got '$info'\n" if $v1;
print STDERR " full path = $depotpath\n" if $v1;
my @revs = ();
my $head = 1; # set for head rev
my $last_revnum = 0;
my $last_revchg = 0;
$_ = shift(@info);
while( defined($_) ) { # for each rev (#1,#2,...)
# Check for rev line, and extract all fields from it:
#
if( ! m|^1#(\d+) change (\d+) (\S+) on (\S+) by (\S+)\@(\S+) \((\S+)\)| ) {
print STDERR "$progname: missing expected rev line from '$p4prog -s filelog -l $path':\n$info";
exit 1;
}
my($revnum,$revchg,$revact,$revdate,$revuser,$revclient,$revtype) = ($1,$2,$3,$4,$5,$6,$7);
print STDERR " Got n=$revnum chg=$revchg act=$revact date=$revdate u=$revuser cli=$revclient typ=$revtype\n" if $v1;
# Verify assumptions about revision and change number ordering;
# code using this function depends on it!:
#
if( !$head and $revnum != $last_revnum - 1 ) {
# Missing revs probably okay:
warn "$progname: non-sequential rev number #$revnum following #$last_revnum";
# But out of order definitely not!:
die "$progname: rev numbers out of order, stopped" if $revnum >= $last_revnum;
}
if( !$head and $revchg >= $last_revchg ) {
die "$progname: out of order change number \@$revchg for #$revnum following \@$last_revchg for #$last_revnum, stopped";
}
$last_revnum = $revnum;
$last_revchg = $revchg;
# Extract comment lines:
#
my $revcomment = "";
while( defined($_ = shift(@info)) ) {
last if m|^1#| or !m|^1|;
s/^1//;
$revcomment .= "$_\n";
}
$revcomment =~ s|\s*\[imported from CVS by cvs2p4 at 2000/03/14 \d\d\:\d\d\:\d\d\]||m;
$revcomment =~ s/^\t//m;
$revcomment =~ s/^\n+//m;
$revcomment =~ s/\n+$//m;
print STDERR " Comment = <<$revcomment>>\n" if $v1;
# Extract each branching info under that rev:
#
my @bout_paths = ();
my @from_paths = ();
my @revpaths = ();
while( defined($_) and m|^2([a-z ]+) (//depot[^#]*)#(\d+)(,#(\d+))?| ) {
my($baction,$bpath,$brevlo,$ballhi,$brevhi) = ($1,$2,$3,$4,$5);
#print STDERR " [$brevlo|$ballhi|$brevhi]" if $v1;
defined($brevhi) or $brevhi = $brevlo;
defined($ballhi) or $ballhi = "";
my $brevall = "#$brevlo$ballhi";
# Known actions: branch/copy/merge/delete into/from, ignored, ignored by,
# edit into (to multiple copy/etc from), add into (to original (#1) branch from)
my $from = $baction eq "ignored" || ($baction =~ m/ from$/);
push(@revpaths, [$from,$baction,$bpath,$brevall,$brevlo,$brevhi] );
push(@from_paths, [$from,$baction,$bpath,$brevall,$brevlo,$brevhi] ) if $from;
push(@bout_paths, [$from,$baction,$bpath,$brevall,$brevlo,$brevhi] ) if !$from;
print STDERR " $from '$baction' $bpath,$brevlo,$brevhi [$brevall]\n" if $v1;
$_ = shift(@info);
}
unshift(@revs, [$depotpath, $n++,$revnum,$revchg,$revact,$revdate,$revuser,$revclient,$revtype, $revcomment, \@revpaths, \@from_paths,\@bout_paths, $head]);
$head = 0;
}
if( $last_revnum != 1 ) {
warn "$progname: last rev number is #$last_revnum instead of #1";
}
return ($depotpath, @revs);
}
1;