#!/bin/sh # Not every host installs perl at the same location, handle many locations: PATH=/usr/xtensa/stools-5.0/bin:/usr/bin:/usr/local/bin:$PATH exec perl -x -S $0 ${1+"$@"} exit $? #!perl -w #line 8 # pls -- Perforce 'ls' -- lists combined Perforce and local directories # Copyright (c) 2000-2006, 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. # See `pls -h` for usage info. # # History: # 2006-FEB-15 1.6 marc Recognize alternate login methods # 2005-APR-12 1.5 marc Update copyright/license notice. # 2002-OCT-02 1.4 marc Handle spaces in pathnames # 2001-DEC-18 1.3 marc Improve perl and script path independence # 2001-OCT-05 1.2 marc Put p4where() logic in p4lib.pm. # 2001-??? 1.1b marc Use p4lib.pm. # 2001-FEB-23 1.1 marc Add -p4 option. # 2000-MAY-23 1.0 marc Initial version $progvers = "1.6"; $progname = "pls"; $p4prog = "p4"; my $scriptdir = $0; $scriptdir =~ s|[/\\][^/\\]+$||; # strip script name, leaving only dirname push @INC, $scriptdir; require p4lib; # Get arguments: @args = (); while( defined($_ = shift) ) { if( /^-q$/ ) { # don't show deleted files $no_del_files = 1; next; } if( /^-p4$/ ) { # set p4prog path if( !defined($p4prog = shift) ) { print STDERR "$progname: missing parameter after '-p4' option\n"; usage(); exit 1; } next; } if( /^-(h|help|\-h|\-help|\?)$/i ) { usage(); exit 0; } if( /^-/ ) { print STDERR "$progname: unrecognized option '$_'\n"; usage(); exit 1; } push(@args, $_); } # Only do p4 commands starting here, i.e. after -p4 option processed. # Verify login: my $verlogin = `$p4prog login -s`; chomp($verlogin); if ($verlogin !~ /ticket expires/ && $verlogin !~ /not necessary/ && $verlogin !~ /authenticated by password not ticket/) { print STDERR "Perforce account requires login\n"; # Try doing a login (requesting password on the spot): $vercode = system("$p4prog login"); if ($vercode != 0) { die "Perforce account still requires login (exit code $vercode)\nStopped"; } my($verlogin) = p4cmdout("login -s"); chomp($verlogin); if ($verlogin !~ /ticket expires/) { die "Perforce account still requires login ($verlogin)\n Stopped"; } } # Get various info: p4getinfo(); # Execute listing: if( @args == 0 ) { pls(""); } else { foreach (@args) { pls($_); } } exit 0; # done! sub usage { print <<"__END__"; Perforce lister v$progvers -- Displays contents of a Perforce/local directory Usage: pls [-q] [dirpath [...]] Options: -q do not display deleted files (unless opened etc) -h display this help message -p4 progname set path to p4 executable (default 'p4') Caveats: o You cannot specify a single file, only a directory o Invokes many p4 commands, so tends to be slow o Does not support // requests (does support //) o Does not display date/time or file size Displays the following columns: [_LOCAL__] HAVE RSLV [______OPENED______] [____DEPOT_____] perms p4 type rev rev change how others loc head change Name ---------- --------- ---- ---- ------- --- -------- --- ---- ------- ---- LOCAL perms: -rwxrwxrwx as per 'ls -l' if the file/dir is on your disk p4 type: p4 file type (text, ktext, DIR, etc) if Perforce knows about it; if opened vs depot types are different, parts of the type that differ are shown as '*' (eg. text vs ktext is shown as *text) (note that DIR is not a p4 type, it is inferred by the script) HAVE rev: revision of the file you have on your disk, or "head" if same as the head rev in the depot; prefixed with '*' if this rev (or for dirs, if any descendant file) includes resolved & unsubmitted revs; (NOT same as p4 have's rev if RSLV rev present) RSLV rev: revision of the file you last sync'ed, if newer and unresolved; "head" if same as head rev in depot; for dirs, displays number of descendant unresolved files; these unresolved files are due to p4 sync (for unresolved due to p4 integrate, see Name column) OPENED change: change number (or "default") if you have the file opened; for dirs, shows change number for all opened descendant files if they all have the same, else the number of opened files OPENED how: action used to open file (or set of descendant files for dirs); add=new file, int=integrate, del=deleted, bra=branch, edi=edit, ...=mixed actions (dirs only); last char replaced with '*' if you have locked the file (or for dirs, locked any descendant file) OPENED others: lists any other users who have opened the file (or for dirs, any descendant file), including yourself if you opened it on another client; ends with "..." if the list of users is too long to fit (generally the case if more than 1 other user); ends with '*' if any of these other users has locked the file(s) DEPOT loc: "DEP" if file visible in depot but not your client; "CLI" if file somehow visible in your client but not depot DEPOT head: head rev of file if present in depot (shown as !n instead of #n if depot file is deleted) DEPOT change: last change number at which file was changed/affected in the depot Name: name of the file; "-> " appended if is a symlink on your local disk; "<= [#rev[,rev]][ (#rev)]" appended for each file from which it was integrated but not submitted: #rev[,rev] indicates unresolved versions; (#rev) indicates resolved versions, where is copy, igno or merg (there are probably others). "<= ( unresolved) ( resolved)" appended for dirs for which any descendant file has been integrated but not submitted __END__ } #' # Return list of files within a given Perforce directory path: # sub p4flat_files { my($path,$what,$subdir_prefix) = @_; return () if $path eq ""; my $subs = defined($subdir_prefix); if( $subs ) { $subdir_prefix =~ s|^//depot||; # prefix is in depot syntax #$subdir_prefix .= "/" unless $subdir_prefix =~ m|/$|; # append '/' } $path .= "/".($subs ? "..." : "*"); my @files = p4files($what,$path); my @result = (); my %dirs = (); foreach my $f ( @files ) { my($fpath,$fname,$fvers,$action,$chgnum,$ftype,$byuser,$bycli,$lock) = @$f; my $chg = "change"; $fpath =~ s|^//depot||; #print "Got lock $fname '$lock'\n" if $lock; $chgnum = "\@".$chgnum if $chgnum =~ /^\d+$/; if( !$subs or $fpath eq $subdir_prefix ) { push(@result, [$fpath,$fname,$fvers,$action,$chg,$chgnum,$ftype,$byuser,$bycli,$lock] ); #printf "%-9s #%-5s \@%-7s $fname ($fpath)\n", $ftype, $fvers, $chgnum; } elsif( $fpath =~ s|^\Q$subdir_prefix\E/([^/]+)|| ) { my $subdir = $1; ${$dirs{$subdir}}[0]++; ${$dirs{$subdir}}[4] += 0; # just make sure it's defined ${$dirs{$subdir}}[5] += 0; # ditto if( $byuser eq $p_user and $bycli eq $p_client ) { ${${$dirs{$subdir}}[2]}{$action} = 1; ${${$dirs{$subdir}}[3]}{$chgnum} = 1; ${$dirs{$subdir}}[4]++ if $lock; } else { ${${$dirs{$subdir}}[1]}{$byuser."@".$bycli} = 1; ${$dirs{$subdir}}[5]++ if $lock; } #push(@result, [$subdir_prefix,$subdir,"-","-",$chg,$chgnum,$ftype,$byuser,$bycli,$lock] ); #printf "Got subdir file: %-9s #%-5s \@%-7s $fname ($fpath)\n", $ftype, $fvers, $chgnum; } else { printf "Got unknown file: %-9s #%-5s \@%-7s $fname ($fpath)\n", $ftype, $fvers, $chgnum; } } foreach (keys %dirs) { my $nelems = ${$dirs{$_}}[0]; my @who = keys %{${$dirs{$_}}[1]}; my @actions = keys %{${$dirs{$_}}[2]}; my @changes = keys %{${$dirs{$_}}[3]}; my $nlocks = ${$dirs{$_}}[4]; my $nlockso = ${$dirs{$_}}[5]; my $dirwho = join(",",@who).","; my $diract = (@actions == 1) ? $actions[0] : (@actions == 0) ? "" : "..."; my $dirchg = (@changes == 1) ? $changes[0] : (@changes == 0) ? "" : "($nelems)"; push(@result, [$subdir_prefix,$_,$nelems,$diract,"-",$dirchg,"DIR",$dirwho,"",$nlocks,$nlockso] ); } return @result; } # Return list of files within a given Perforce directory path # (parse 'p4 resolved' and 'p4 resolve -n' output): # sub p4resfiles { my($path,$what,$subdir_prefix,$loc_prefix) = @_; return () if $path eq ""; my $subs = defined($subdir_prefix); my $cmdline = "$what ".p4passpath("$path/".($subs ? "..." : "*")); ##print "Doing '$cmdline'\n"; my($info) = p4cmdout($cmdline); chomp($info); #print STDERR "Got '$info'\n"; my @result = (); my %dirs = (); #print "subs $subs\n"; foreach ( split(/\n/,$info) ) { if( ! m%(/[^#]+/)([^/#]*) - ([^/]+)\s+(//depot[^#]*/)([^/#]*)#([0-9]+)(,#([0-9]+)|)% ) { print STDERR "$progname: unparsable line from '$p4prog -s $cmdline': $_\n"; next; } my($locpath,$locname,$action,$respath,$resname,$resvers,$resv2,$resv3) = ($1,$2,$3,$4,$5,$6,$7,$8); defined($resv3) or $resv3 = ""; my $frompathname; $action = substr($action,0,4); if( $locpath !~ s|^\Q$loc_prefix/|| ) { print "Couldn't find prefix '$loc_prefix' in '$locpath'\n"; return (); } if( $respath =~ s|^\Q$subdir_prefix/|| ) { if( $respath !~ s|^\Q$locpath|| ) { foreach ($locpath =~ m|/|g) { $respath = "../$respath"; } } if( $locname eq $resname and $respath eq "" ) { $frompathname = ""; # itself } else { $frompathname = $respath.$resname; } } else { $frompathname = $respath.$resname; # Try to get a shorter version using relative pathname: my $p1 = $subdir_prefix."/".$locpath.$locname; my $p2 = $frompathname; #print "A. p1 = $p1\n p2 = $p2\n"; while(1) { $p1 =~ m|^([^/]*/)| or last; $f1 = $1; $p2 =~ m|^([^/]*/)| or last; $f2 = $1; $f1 eq $f2 or last; $p1 = substr($p1,length($f1)); $p2 = substr($p2,length($f1)); } #print "B. p1 = $p1\n p2 = $p2\n"; foreach ($p1 =~ m|/|g) { $p2 = "../$p2"; } $frompathname = $p2 if length($p2) < length($frompathname); # Try to get a shorter version using branch pathname: #...(not yet implemented)... } #print "Got $action\[$resvers|$resv2|$resv3] <$locpath>'$locname' from <$frompathname>\n"; if( !$subs or $locpath eq "" ) { push(@result, [$locname,$frompathname,$action,$resvers,$resv3] ); } else { $locpath =~ m|^([^/]*)|; my $subdir = $1; ${$dirs{$subdir}}[0] += ($frompathname eq ""); ${$dirs{$subdir}}[1] += ($frompathname ne ""); } } foreach (keys %dirs) { my $nself = ${$dirs{$_}}[0]; my $nintg = ${$dirs{$_}}[1]; push(@result, [$_," ","","",$nintg] ) if $nintg > 0; push(@result, [$_,"","","","$nself"] ) if $nself > 0; } #print "\n"; return @result; } # Return list of files within a given Perforce directory path # (parse 'p4 have' output): # sub p4havefiles { my($path) = @_; return () if $path eq ""; my @havelist = p4have("$path/*"); my @result = (); foreach (@havelist) { my($fpath,$fname,$fvers) = @$_; $fpath =~ s|^//depot||; push(@result, [$fpath,$fname,$fvers] ); } return @result; } sub pls { my ($args) = @_; my $p4path = ""; # path to list in Perforce format, ie. prefixed # with //depot or // my $locpath = ""; my $clipath = ""; defined($args) or $args = ""; # We have to remove any "." and "..": # my $roots = 0; $roots++ while $args =~ s|^/||; # count leading slashes $args = "/$args/"; # insure it starts and ends in slash $args =~ s|//+|/|g; # collapse repeated slashes $args =~ s|/\./|/|g; # strip out any "." # Strip out any "xxx/..": while($args =~ s@/([^/.][^/]*|\.[^/.][^/]*|\.\.[^/]+)/\.\./@/@g) { } # There may be some leading ".." left, should be okay. $roots = 2 if $roots > 2; $args =~ s|^/||; # remove added leading '/' $args =~ s|^\.\./||g if $roots > 0; # strip out any .. across root my $argstrail = $args; # save path that has trailing '/' $args =~ s|/$||; # remove added trailing '/' if( $roots == 2 ) { if( $args eq "" ) { # Empty rooted path ("//"). # Special case, must list clients and depots: print "Contents of //:\n"; print "Clients:\n"; my ($allclients) = p4cmdout("clients",0,1,1); chomp($allclients); foreach (sort(split(/\n/,$allclients))) { /^Client (\S+) \S+ root ([^\']+) \'\s*(.*?)\s*\'\s*$/ or next; my($cname,$croot,$ccomment) = ($1,$2,$3); $ccomment =~ s|\s+\-?//.*||; # some people put commented out paths in here printf "//%-20s -> %s (%s)\n", $cname,$croot,$ccomment; } print "Depots:\n"; my ($alldepots) = p4cmdout("depots",0,1,1); chomp($alldepots); foreach (sort(split(/\n/,$alldepots))) { /^Depot (\S+) \S+ (\S+) subdir [^\']+ \'\s*(.*?)\s*\'\s*$/ or next; my($dname,$dwhat,$dcomment) = ($1,$2,$3); printf "//%-20s %-6s (%s)\n", $dname,$dwhat,$dcomment; } return; } $args = "//".$args; $p4path = $args; if( $argstrail =~ m|^depot/| ) { # # already in depot format } else { # Verify that path is in client format: #... } } else { $args = "/".$args if $roots > 0; $args = "." if $args eq ""; $locpath = $args; } #print STDERR "Got p4path = '$p4path'\n"; #print STDERR "Got locpath = '$locpath'\n"; # Use 'p4 where' to convert native format to Perforce format # (default to //depot syntax): my ($mapped,$w_p4path,$w_clipath,$w_locpath) = p4where($args); ($p4path,$clipath,$locpath) = ($w_p4path,$w_clipath,$w_locpath) if defined($w_p4path); # my ($info) = p4cmdout("where ".p4passpath($args)); # if( $info eq "" ) { # can't map? try with a sub-element # ($info) = p4cmdout("where ".p4passpath("$args/--.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). # } else { # chomp($info); $info =~ s|.*\n||s; # keep all but the last line # my $notmapped = ($info =~ s|^\-||); # if( $info !~ m|^(//.*) (//.*) (/.*)$| ) { # die "$progname: can't parse output of '$p4prog -s where $args':\n". # "$progname: '$info'\n". # "$progname: stopped"; # } # $p4path = $1; # $clipath = $2; # $locpath = $3; # #print STDERR "Depot path is $p4path\n"; # #print STDERR "Client path is $clipath\n"; # #print STDERR "Local path is $locpath\n"; # print STDERR "$progname: warning: requested directory defined but unmapped by the client\n" # if $notmapped; # } $args = ($p4path ne "") ? $p4path : $locpath; print "Contents of $args:\n"; # Get (directory) contents of Perforce directory: # foreach (p4dirs($p4path)) { $alldirs{$_} |= 1; } # is in depot foreach (p4dirs($clipath)) { $alldirs{$_} |= 2; } # is in client # Get contents of local directory: # my @locitems = (); if( $locpath ne "" ) { if( opendir(DIR, $locpath) ) { @locitems = readdir(DIR); closedir DIR; } } # @locdirs = grep { -d "$locpath/$_" } @locitems; foreach (@locitems) { my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = lstat("$locpath/$_") or next; $_ eq "." and next; $_ eq ".." and next; my $type; my $symlink = ""; if (-f _) { $type = '-'; } elsif (-d _) { $type = 'd'; } elsif (-c _) { $type = 'c'; } elsif (-b _) { $type = 'b'; } elsif (-p _) { $type = 'p'; } elsif (-S _) { $type = 's'; } else { $type = 'l'; $symlink = ' -> ' . readlink("$locpath/$_"); } if( $type eq 'd' ) { $alldirs{$_} |= 4; # is local } else { # 0 dev device number of filesystem # 1 ino inode number # 2 mode file mode (type and permissions) # 3 nlink number of (hard) links to the file # 4 uid numeric user ID of file's owner # 5 gid numeric group ID of file's owner # 6 rdev the device identifier (special files only) # 7 size total size of file, in bytes # 8 atime last access time since the epoch # 9 mtime last modify time since the epoch # 10 ctime inode change time (NOT creation time!) since the epoch # 11 blksize preferred block size for file system I/O # 12 blocks actual number of blocks allocated $allfiles{$_} = 1; } $locfiles{$_} = [$mode,$size,$mtime,$uid,$gid,$type,$symlink]; } # # Display directories: # # # foreach (sort keys %alldirs) { # my $where = $alldirs{$_}; # print "directory ", # ($where & 1)?"depot":" ", # " ", # ($where & 2)?"client":" ", # " $_\n"; # } foreach (p4flat_files($p4path ,"files")) { $allfiles{$$_[1]} += ($$_[3] ne "delete"); $depfiles{$$_[1]} = $_; } foreach (p4flat_files($clipath,"files")) { $allfiles{$$_[1]} += ($$_[3] ne "delete"); $clifiles{$$_[1]} = $_; } foreach (p4havefiles($p4path )) { $allfiles{$$_[1]} = 1; $dephfiles{$$_[1]} = $$_[2]; } # foreach (p4havefiles($clipath)) { # $allfiles{$$_[1]} = 1; # $clihfiles{$$_[1]} = $$_[2]; # } foreach (p4resfiles($p4path ,"resolve -n",$p4path,$locpath)) { if( $$_[3] eq "" ) { # directory? $alldirs{$$_[0]} = 1; } else { $allfiles{$$_[0]} = 1; } if( $$_[1] eq "" ) { # self? $depresons{$$_[0]} = $_; } else { $$_[5] = 1; # indicate unresolved push(@{${$depreso{$$_[0]}}{$$_[1]}}, $_); } } # Note - order matters (resolved done after resolve -n) ### BUG!!! need to p4resfiles() on client, not just depot, ### !!!!!! because some 'resolved' indications are only ### !!!!!! shown for client views (eg. integrate to new file) foreach (p4resfiles($p4path ,"resolved",$p4path,$locpath)) { if( $$_[3] eq "" ) { # directory? $alldirs{$$_[0]} = 1; } else { $allfiles{$$_[0]} = 1; } if( $$_[1] eq "" ) { # self? $depresods{$$_[0]} = $_; } else { $$_[5] = 0; # indicate resolved push(@{${$depreso{$$_[0]}}{$$_[1]}}, $_); } } #foreach (p4flat_files($p4path ,"opened")) { $allfiles{$$_[1]} = 1; $depofiles{$$_[1]} = $_; } #foreach (p4flat_files($clipath,"opened")) { $allfiles{$$_[1]} = 1; $cliofiles{$$_[1]} = $_; } foreach (p4flat_files($p4path ,"opened -a",$p4path)) { if( $$_[6] eq "DIR" ) { $alldirs{$$_[1]} = 1; $depoafiles{$$_[1]} .= $$_[7]; $depofiles{$$_[1]} = $_; $filelocked{$$_[1]} += $$_[10]; } else { $allfiles{$$_[1]} = 1; if( $$_[7] eq $p_user and $$_[8] eq $p_client ) { $depofiles{$$_[1]} = $_; } else { $depoafiles{$$_[1]} .= $$_[7]."@".$$_[8].","; $filelocked{$$_[1]} += $$_[9]; } } } # foreach (p4flat_files($clipath,"opened -a",$p4path)) { # if( $$_[6] eq "DIR" ) { # $alldirs{$$_[1]} = 1; # $clioafiles{$$_[1]} .= $$_[7]; # $cliofiles{$$_[1]} = $_; # } else { # $allfiles{$$_[1]} = 1; # if( $$_[7] eq $p_user and $$_[8] eq $p_client ) { # $cliofiles{$$_[1]} = $_; # } else { # $clioafiles{$$_[1]} .= $$_[7]."@".$$_[8].","; # } # } # } # If requested, don't list files that are deleted, unopened, and # otherwise non-displayable: # if( $no_del_files ) { @delfiles = grep {$allfiles{$_} == 0} (keys %allfiles); foreach $f (@delfiles) { delete $allfiles{$f}; } } #Contents of //depot/dev/rtos/Xtensa/Software/rtos/vxworks/xt1000: # Display in this format: print "[_LOCAL__] HAVE RSLV [______OPENED______] [____DEPOT_____]\n". " perms size p4 type rev rev change how others loc head change Name\n". "---------- ---- --------- ---- ---- ------- --- -------- --- ---- ------- ----\n"; #-rwxr-xr-x ktext head default bra rutt cli #1 @20909 Makefile.in -> xxx #drwxr-xr-x dir/text dir @12345 ... dep Tools # #1 +head !2 oldfile # #2 +#4 default int #5 @22476 sysSerial.c.tpp <+= sysSerialPoll.c.tpp#2 #-rw-r--r-- ktext default add focal <= ../../blip/target.nr#2 done #.... #1 done #2 ... #-rw-r--r-- ktext default add xyz <= //depot/rel/2_0/Xtensa/... foreach $f (sort keys %allfiles, keys %alldirs) { #my $where = $allfiles{$f}; #print " '$f'\n"; my $fullp4path = $p4path."/".$f; # full p4 pathname of $f my $isdep = exists($depfiles{$f}); my $dep = $depfiles{$f} if $isdep; my $iscli = exists($clifiles{$f}); my $cli = $clifiles{$f} if $iscli; my $isdeph = exists($dephfiles{$f}); my $deph = $dephfiles{$f} if $isdeph; # my $isclih = exists($clihfiles{$f}); my $clih = $clihfiles{$f} if $isclih; my $isdepo = exists($depofiles{$f}); my $depo = $depofiles{$f} if $isdepo; # my $isclio = exists($cliofiles{$f}); my $clio = $cliofiles{$f} if $isclio; my $isdepoa= exists($depoafiles{$f}); my $depoa = $depoafiles{$f} if $isdepoa; # my $isclioa= exists($clioafiles{$f}); my $clioa = $clioafiles{$f} if $isclioa; my $isloc = exists($locfiles{$f}); my $loc = $locfiles{$f} if $isloc; my $isdeprn= exists($depreso{$f}); my $deprn = $depreso{$f} if $isdeprn; my $isdeprs= exists($depresods{$f}); my $deprs = $depresods{$f} if $isdeprs; my $isdepns= exists($depresons{$f}); my $depns = $depresons{$f} if $isdepns; # Build display line: my $line = ""; my $symlink = ""; my $filesize = -1; # Local info: if( $isloc ) { my ($mode,$size,$mtime,$uid,$gid,$type,$symlnk) = @$loc; $symlink = $symlnk; #$line .= sprintf("%X",$mode >> 9); $line .= $type .(($mode & 0400)?"r":"-") .(($mode & 0200)?"w":"-") .(($mode & 0100)?"x":"-") .(($mode & 0040)?"r":"-") .(($mode & 0020)?"w":"-") .(($mode & 0010)?"x":"-") .(($mode & 0004)?"r":"-") .(($mode & 0002)?"w":"-") .(($mode & 0001)?"x":"-") ." "; $filesize = $size if $type ne 'd'; } else { $line .= " "; # No filesize for now. } if ($filesize >= 0) { use integer; my $suffix = 0; my $decimal = ""; while ($filesize >= 1024) { my $remainder = ($filesize & 1023); $decimal = "." . ($remainder * 10 / 1024); $filesize /= 1024; $suffix++; } $decimal = "" if $filesize > 9; my @suffixes = ("", "k", "M", "G", "T", "P", "E"); $filesize .= $decimal . $suffixes[$suffix]; $line .= substr(" " . $filesize, -4, 4) . " "; } else { $line .= " "; } # Type info (start cumulating): my %types = (); # Resolved info (self): $line_resf = ($isdeprs ? "*" : " "); # Have (and unresolved) info: $line_rslv = " "; if( $isdeph ) { my $have_ver = $deph; if( $isdepns ) { # Unresolved changes from depot version of this file: $have_ver = $$depns[3] - 1; $reso_ver = (($$depns[4] eq "") ? $$depns[3] : $$depns[4]); # Note: p4's "have" version number ($deph) is ignored # (generally same as $reso_ver though I think...?) if( $isdep and $$dep[2] == $reso_ver ) { $line_rslv = "head "; } else { $line_rslv = sprintf("#%-4u", $reso_ver); } } if( $isdep and $$dep[2] == $have_ver ) { $line_have = "head "; } else { $line_have = sprintf("#%-4u", $have_ver); } } else { $line_have = " "; # Special case for directories: if( $isdepns ) { $line_rslv = substr("(".$$depns[4].") ",0,5); } } # Opened info: if( $isdepo ) { my($fpath,$fname,$fvers,$action,$chg,$chgnum,$ftype,$x1,$x2,$lock) = @$depo; $types{$ftype} = 1; # if( $isdep and $$dep[2] == $fvers ) { # $line_open = "head "; # } else { # $line_open = sprintf("%s%-4u", ($action eq "delete" ? "!":"#"),$fvers); # } $action = substr($action,0,2)."*" if $lock; $line_open = sprintf("%-8s%-3.3s ", $chgnum,$action); } else { $line_open = " "; } # Others info: $depoa = "" unless $isdepoa; $depoa =~ s/,$//; my @depoa = split(/,/,$depoa); #my @depoa = grep {$_ ne $p_user."@".$p_client} @depoa; foreach (@depoa) {s/\@.*//;} $depoa = join(',',@depoa); if( @depoa < 1 ) { $line_others = ""; } elsif( @depoa > 1 ) { $line_others = substr($depoa,0,5)."..."; } else { $line_others = substr($depoa,0,8); } $line_others .= ((exists($filelocked{$f}) and $filelocked{$f}) ? "*" : ""); $line_others = substr($line_others." ",0,9); # Depot info: if( $isdep or $iscli ) { if( $isdep and !$iscli ) { $line_dep = "DEP "; } elsif( $iscli and !$isdep ) { $line_dep = "CLI "; } else { $line_dep = " "; } my $info = $isdep ? $dep : $cli; my($fpath,$fname,$fvers,$action,$chg,$chgnum,$ftype) = @$info; $types{$ftype} = 1; $line_dep .= sprintf("%s%-4u%-8s", ($action eq "delete" ? "!":"#"),$fvers,$chgnum); } else { $line_dep = " "; } # Item type: my $isdir = exists($alldirs{$f}); if( exists($types{"DIR"}) ) { $isdir = 1; delete $types{"DIR"}; } my @types = keys %types; if( $isdir ) { $line_type = "DIR"; $line_type .= "/" if @types > 0; } else { $line_type = ""; } if( @types == 1 ) { $line_type .= $types[0]; } elsif( @types > 1 ) { my $first = pop(@types); my $suffix = $first; foreach (@types) { while( ! /\Q$suffix\E$/ ) {$suffix = substr($suffix,1);} } $first =~ s/\Q$suffix\E$//; foreach (@types) { s/\Q$suffix\E$//; } my $prefix = $first; foreach (@types) { while( ! /^\Q$prefix\E/ ) {$prefix = substr($prefix,0,length($prefix)-1);} } $first =~ s/^\Q$prefix\E//; foreach (@types) { s/^\Q$prefix\E//; } $line_type .= $prefix."*".$suffix; } $line_type = substr($line_type." ",0,9); # Print most of the line: # print "$line$line_type$line_resf$line_have$line_rslv$line_open$line_others$line_dep$f$symlink"; # Integration/branching information (resolved/unresolved, but not submitted): foreach $intfile (keys %{$deprn}) { print " <= "; if( $intfile eq $fullp4path ) { # same filename? print "self"; # should never happen } elsif( $intfile ne " " ) { # Try to shorten the name if it's similar to the file being integrated to. # Tensilica-specific name compression: if same in different branch, # just display the branch name. # Is $f in a branch?: my $bpath = $fullp4path; if( $bpath =~ s@^//depot/(main|rel/[^/]+|dev/[^/]+|user/[^/]+)/@@ ) { #my $fbranch = $1; # Current file (integrate destination) is in branch $1, # and $bpath now contains the branch-relative pathname. # Is $intfile same as $f in another branch?: if( $intfile =~ m@^//depot/(main|rel/[^/]+|dev/[^/]+|user/[^/]+)/\Q$bpath\E$@ ) { my $intbranch = $1; # branch from which this file was integrated print $intbranch; } else { print $intfile; } } else { print $intfile; } } foreach my $rev (@{${$deprn}{$intfile}}) { my($locname,$frompathname,$action,$resvers,$resv3,$unresol) = @$rev; if( $resvers ne "" ) { # Normal files: if( $unresol ) { print "#$resvers"; print ",$resv3" if $resv3 ne ""; } else { print " ($action #$resvers"; print ",$resv3" if $resv3 ne ""; print ")"; } } else { # Directories: if( $unresol ) { print " ($resv3 unresolved)"; } else { print " ($resv3 resolved)"; } } } } print "\n"; } # foreach item exit 0; open(FILES,"$p4prog files $args|") or die "$progname: can't $p4prog files $args: $!, stopped"; while( ) { chomp; if( ! m@//depot([^#]*)/([^/#]*)#(\S*) - (\S+)\s+(\S+)\s+(\S+)\s+\(([^) ]+)\)@ ) { print "*** unparsable line: $_\n"; next; } my($fpath,$fname,$fvers,$action,$chg,$chgnum,$ftype) = ($1,$2,$3,$4,$5,$6,$7); printf "%-9s #%-5s \@%-7s $fname ($fpath)\n", $ftype, $fvers, $chgnum; } close FILES; }