# All rights reserved. Capella Computers Ltd. (C) 1997
# Copyright (C) 1997 Capella Computers Ltd.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# Any feedback should be sent to Oren Ben-Kiki ([email protected]).
# :FILE:
# A PERL package for invoking 'p4' functionality. This is tailored for the
# particular use we make of p4, and not a general-purpose package.
use strict;
use English;
package P4; # P4 operations.
# PACKAGE VARIABLES:
my $p4path = $ENV{P4PATH}; # Path to p4 installation.
defined($p4path)
|| die("P4PATH environment variable is not set.\n");
my $p4exe = "$p4path/lib/p4"; # Where the p4 executable is.
my $p4temp = $ENV{P4TEMP}; # Path to p4 temporary files.
defined($p4temp)
|| die("P4TEMP environment variable is not set.\n");
my $p4user = $ENV{P4USER}; # P4 user id.
defined($p4user)
|| die("P4USER environment variable is not set.\n");
my $p4client = $ENV{P4CLIENT}; # P4 client id.
defined($p4client)
|| die("P4CLIENT environment variable is not set.\n");
my $p4root = $ENV{P4ROOT}; # Root of client view.
defined($p4root)
|| die("P4ROOT environment variable is not set.\n");
# P4JOB is also an environment variable we use; however, being optional,
# it is only examined when it is asked for (in the current_job method).
my %do_unlock_on_error; # Unlock depot on abnormal exit?
my $temp_file; # Current temporary file, if any.
my $to_unlink; # Unlink temp_file on close of from_p4?
# PUBLIC METHODS:
# Access variables:
# Return the current user.
sub current_user {
return $p4user;
}
# Verify that the current user is (not) a specific one.
sub verify_current_user {
my $valid = shift; # List of valid users?
# The rest of @::ARG is expected to contain the list of valid users.
# Check them one by one
my $user;
foreach $user (@::ARG) {
if ($p4user eq $user) {
$valid
|| crash("Sorry, $p4user, this operation is blocked for ",
join(' and ', @::ARG), '.');
# Be nice
return 1;
}
}
!$valid
|| crash("Sorry, $p4user, this operation is restricted to ",
join(' or ', @::ARG), " only.");
# Be nice.
return 1;
}
# Return the current client
sub current_client {
return $p4client;
}
# Return the root directory of the client view.
sub view_root {
return $p4root;
}
# Return the current job, which must be defined.
sub current_job {
if (defined($ENV{P4JOB})) {
return $ENV{P4JOB};
} else {
# Any argument means it is OK for it to be undefined.
# The first argument is the return value.
$#::ARG >= 0
|| crash("P4JOB environment variable is not set.");
return shift;
}
}
# Convert a depot name to a name on the local disk.
sub depot_to_disk {
my $name = shift; # Depot name of file
# Just replace the '//depot/ with the client's view root;
# this assumes the client view is defined as:
# //depot/... //<client>/...
# With $p4root as the root client directory.
$name =~ s#^//depot#$p4root#;
return $name;
}
# Job commands:
# These patterns are used to parse job descriptions.
my $job_header_pattern = # Pattern for job header line.
"job(\\d+) " # Job number.
. "on (\\S+) " # Creation date.
. "by (\\w+)"; # User name.
my $job_data_pattern = # Pattern for job data line.
"Data: (\\w+) " # Job status.
. "(\\d+|\\-) " # Development change, or '-'.
. "(\\w+|\\-) " # Development client, or '-'.
. "(\\d+|\\-) " # Integration change, or '-'.
. "(\\w+|\\-) " # Integration client, or '-'.
. "(\\d+|\\-) " # Version, or '-'.
. "(\\w+|\\-) " # Reviewer name, or '-'.
. "(\\d+) " # Retry count (1-based).
. "(.*)"; # Short title.
# Return the list of all jobs.
sub jobs {
# Invoke p4 for a full list of jobs.
read_from_p4('jobs', '-l');
# Collect each line into a hash of jobs.
my %jobs;
my $line;
while ($line = <FROM_P4>) {
# Look for a line starting the description of a job.
if ($line =~ /$job_header_pattern/) {
my $job = int($1);
my $created = $2;
my $user = $3;
# The description line comes after a blank line.
$line = <FROM_P4>;
$line = <FROM_P4>;
defined($line)
|| crash("Bad output from 'p4 jobs'.");
if ($line =~ /$job_data_pattern/) {
my $status = $1;
my $dev_chg = $2;
my $dev_client = $3;
my $int_chg = $4;
my $int_client = $5;
my $version = $6;
my $reviewer = $7;
my $retry = $8;
my $title = $9;
my %record = (
'user' => $user,
'created' => $created,
'status' => $status,
'dev_chg' => $dev_chg,
'dev_client' => $dev_client,
'int_chg' => $int_chg,
'int_client' => $int_client,
'version' => $version,
'reviewer' => $reviewer,
'retry' => $retry,
'title' => $title,
);
$jobs{$job} = \%record;
} else {
# This may be a pain if they are added on purpose.
warn("Foreign job$1 created by $user on $created.\n");
}
}
}
# Done.
done_from_p4();
return %jobs;
}
# Obtain a single job's record.
sub job_record {
my $job = shift; # Number of job to obtain record for.
# Get p4 to print its definition.
my $name = p4_job_name($job);
read_from_p4('job', '-o', $name);
# Parse the definition.
my ($user, $created, $status);
my ($dev_chg, $dev_client, $int_chg, $int_client);
my ($version, $reviewer, $retry, $title, @issues, @description);
my $in_descr = 0;
my $line;
while ($line = <FROM_P4>) {
# Description ends when next field begins.
if ($in_descr && $line =~ /^\S/) {
$in_descr = 0;
}
# Parse fields.
if ($line =~ /^User:\s+(\w*)/) {
$user = $1;
} elsif ($line =~ /^Date:\s+(\S*)/) {
$created = $1;
} elsif ($line =~ /^Description:/) {
$line = <FROM_P4>;
defined($line)
|| crash("Job description line is missing.");
$line !~ /<enter description here>/
|| crash("Job $job does not exist.");
if ($line =~ /$job_data_pattern/) {
$status = $1;
$dev_chg = $2;
$dev_client = $3;
$int_chg = $4;
$int_client = $5;
$version = $6;
$reviewer = $7;
$retry = $8;
$title = $9;
}
$in_descr = 1;
# Parse description.
} elsif ($in_descr) {
if ($line =~ /Issues: /) {
@issues = split(/\s+/, $line);
shift(@issues);
shift(@issues);
} else {
$line =~ s/^\s+//;
push(@description, $line);
}
}
}
# Make sure we've got everything we need.
(defined($user)
&& defined($created)
&& defined($status)
&& defined($dev_chg)
&& defined($dev_client)
&& defined($int_chg)
&& defined($int_client)
&& defined($version)
&& defined($reviewer)
&& defined($retry)
&& defined($title))
|| crash("Couldn't parse job definition.");
# Done.
done_from_p4();
my %record = (
'user' => $user,
'created' => $created,
'status' => $status,
'dev_chg' => $dev_chg,
'dev_client' => $dev_client,
'int_chg' => $int_chg,
'int_client' => $int_client,
'version' => $version,
'reviewer' => $reviewer,
'retry' => $retry,
'title' => $title,
'issues' => \@issues,
'description' => \@description,
);
return %record;
}
# Edit job description.
sub edit_job {
my $job = shift; # Id of job to edit.
# Invoke p4 to invoke the editor, and pray the caller
# does not trash the job.
my $name = p4_job_name($job);
call_sys('p4', "$p4exe job $name");
# Be nice.
return 1;
}
# Verify a job record contains the correct status.
sub verify_job_status {
my $job = shift; # Id of job in question.
my $record = shift; # (Reference) to job record.
# The rest of @::ARG is expected to contain the list of valid status.
my $job_status = $record->{status};
my $status;
foreach $status (@::ARG) {
if ($job_status eq $status) {
# Be nice
return 1;
}
}
crash("Job $job is in '$job_status' status ",
"instead of in '", join("' status or in '", @::ARG), "' status.");
}
# Verify a job record contains the correct user.
sub verify_job_user {
my $job = shift; # Id of job in question.
my $record = shift; # (Reference) to job record.
my $user = shift; # Required user.
my $job_user = $record->{user};
$job_user eq $user
|| crash("Job $job is developed by $job_user instead of by $user.");
# Be nice.
return 1;
}
# Verify that job record contains a valid reviewer
sub verify_job_reviewer {
my $job = shift; # Id of job in question.
my $record = shift; # (Reference) to job record.
# Look for whoevere reviewed it.
my $job_reviewer = $record->{reviewer};
$job_reviewer ne '-'
|| crash("Job $job has not been reviewed yet.");
# Be nice.
return 1;
}
# Verify a job record contains the correct development client.
sub verify_job_development_client {
my $job = shift; # Id of job in question.
my $record = shift; # (Reference) to job record.
my $client = shift; # Required client.
my $job_client = $record->{dev_client};
$job_client eq $client
|| crash("Job $job is developed on $job_client instead of on $client.");
# Be nice.
return 1;
}
# Verify a job record contains the correct integration client.
sub verify_job_integration_client {
my $job = shift; # Id of job in question.
my $record = shift; # (Reference) to job record.
my $client = shift; # Required client.
my $job_client = $record->{int_client};
$job_client eq $client
|| crash("Job $job is integrated on $job_client ",
"instead of on $client.");
# Be nice.
return 1;
}
# Obtain the list of changes affecting a job.
sub job_fixes {
my $job = shift; # Job to obtain fixes of.
# Get the fixes list.
my $name = p4_job_name($job);
read_from_p4('fixes', '-j', $name);
# Collect results into a list of change.
my @changes = ();
my $line;
while ($line = <FROM_P4>) {
if ($line =~ /^$name fixed by change (\d+)/) {
my $change = $1;
push(@changes, $change);
} else {
crash("Couldn't parse fixes list.");
}
}
# Done.
done_from_p4();
return @changes;
}
# Create a new job. Note that its p4 status will be 'closed', not 'opened',
# otherwise it will stuff itself into any changelist around. Our status will
# be 'new', of course.
sub create_job {
my $title = shift; # Short (one line) title of job.
# The rest of @::ARG is expected to contain the list of issues.
# Create the new job.
write_to_p4('job', '-i');
print TO_P4 "Job: new\n";
print TO_P4 "User: nobody\n"; # Not yet assigned to anyone.
print TO_P4 "Status: new\n"; # Can't close it yet.
print TO_P4 "Description:\n";
print TO_P4 "\tData: new - - - - - - 1 $title\n";
print TO_P4 "\tIssues: ", join(' ', @::ARG), "\n";
done_to_p4();
# Read the new job number.
my $result = <FROM_P4>;
my $job;
if ($result =~ /Job job(\d*) saved./) {
$job = int($1);
} else {
print "Expected: Job jobXXXXXX created.\n";
print "Got: $result";
crash("Couldn't create new job.");
}
done_from_p4();
# Now, close it. This means we don't have to worry about it changing
# state in the future or getting itself stuffed into changelists.
my $name = p4_job_name($job);
write_to_p4('job', '-i');
print TO_P4 "Job: ", $name, "\n";
print TO_P4 "User: nobody\n";
print TO_P4 "Status: closed\n"; # Can close it at last.
print TO_P4 "Description:\n";
print TO_P4 "\tData: new - - - - - - 1 $title\n";
print TO_P4 "\tIssues: ", join(' ', @::ARG), "\n";
done_to_p4();
# Make sure it went well.
expect_from_p4("Job $name saved.");
# Done.
return $job;
}
# Update a job. This expects a valid job record.
sub update_job {
my $job = shift; # Number of job to delete.
my $record = shift; # The updated record.
my $user = $record->{user}; # The assigned user.
my $created = $record->{created}; # The creation date.
my $status = $record->{status}; # The job status.
my $dev_chg = $record->{dev_chg}; # The development change, if any.
my $dev_client = $record->{dev_client}; # The development client, if any.
my $int_chg = $record->{int_chg}; # The integration change, if any.
my $int_client = $record->{int_client}; # The integration client, if any.
my $version = $record->{version}; # The version created by the job.
my $reviewer = $record->{reviewer}; # The last reviewer of the job.
my $retry = $record->{retry}; # The retry count.
my $title = $record->{title}; # The short job title.
my $issues = $record->{issues}; # The list of issues handled.
my $description = $record->{description}; # The full description.
# Send p4 the new record.
my $name = p4_job_name($job);
write_to_p4('job', '-i');
print TO_P4 "Job: $name\n";
print TO_P4 "User: $user\n";
print TO_P4 "Status: closed\n";
print TO_P4 "Date: $created 00:00:00\n"; # Cheating, but works.
print TO_P4 "Description:\n";
print TO_P4 "\tData: $status $dev_chg $dev_client $int_chg $int_client ",
"$version $reviewer $retry $title\n";
print TO_P4 "\tIssues: ", join(' ', @$issues), "\n";
print TO_P4 "\t", join("\t", @$description), "\n";
done_to_p4();
# Verify it went well.
expect_from_p4("Job $name saved.");
# Be nice.
return 1;
}
# Delete a job. This assumes the operation is valid.
sub delete_job {
my $job = shift; # Number of job to delete.
# Just ask p4 to do so.
my $name = p4_job_name($job);
read_from_p4('job', '-d', $name);
expect_from_p4("Job $name deleted.");
# Be nice.
return 1;
}
# Branch commands:
# Create a new branch.
sub create_branch {
my $branch = shift; # Name of branch to create.
my $title = shift; # Title of branch.
my $from = shift; # Source files pattern.
my $to = shift; # Target file pattern.
# Just ask p4 to do it.
write_to_p4('branch', '-i');
print TO_P4 "Branch: $branch\n";
print TO_P4 "Description:\n";
print TO_P4 "\t$title\n";
print TO_P4 "View:\n";
print TO_P4 "\t$from $to\n";
done_to_p4();
# Verify results.
expect_from_p4("Branch $branch saved.");
# Be nice.
return 1;
}
# Integrate a branch. We have to deal with the horrid bug #350.
sub integrate_branch {
my $branch = shift; # Branch to integrate.
my $change = shift; # Change to do integration in.
my $type = shift; # Quick (buggy) or sure (slow)?
# @::ARG is expected to contain any further arguments to 'integrate',
# such as '-r'.
if ($type eq 'quick') {
# This is for cases were we don't care that not all files are
# actually copied to the target of the branch - due to the change
# being submitted soon, and the files got through 'p4 get'.
call_sys('p4', "$p4exe integ", @::ARG, '-b', $branch, '-c', $change);
# Be nice.
return 1;
}
# Invoke p4 to do the integration.
read_from_p4('integ', @::ARG, '-b', $branch, '-c', $change);
# Collect the list of operations done.
my ($line, %copy);
while ($line = <FROM_P4>) {
# We are looking for simple additions, which are
# reported as a 'branch' operation. All the rest
# are covered either by 'integ' or 'resolve'.
print $line;
if ($line =~ /^(.*)#.* \- branch from ([^#]*)#/) {
my $target = $1;
my $source = $2;
# First, we need to make sure we've got the
# source file on the local disk.
$::OUTPUT_AUTOFLUSH = 1; print "(get) ";
call_sys('p4', $p4exe, 'get', $source);
$::OUTPUT_AUTOFLUSH = 1; print "";
# Now we need to convert between the 'depot' file name and the
# local disk file name. To be absolutely safe, we should add a
# call to 'p4 where' in between, but since we expect the client
# views to always be the same, this overhead can be avoided.
$target = depot_to_disk($target);
$source = depot_to_disk($source);
# At last, we can copy the source file to the target file locally.
$::OUTPUT_AUTOFLUSH = 1; print "(cp) $target - copy $source\n";
copy_file($source, $target);
}
}
# Done.
done_from_p4();
# Be nice.
return 1;
}
# Verify that there's nothing to be done for branch integration.
sub verify_integrate_branch {
my $branch = shift; # Branch to verify integration of.
# Ask p4 what needs to be done.
read_from_p4('integ', '-n', '-b', $branch);
# The expected response is that nothing is to be done.
my $line = <FROM_P4>;
chop($line);
if ($line eq "All revision(s) already integrated."
|| $line eq "All revision(s) already integrated in pending change.") {
done_from_p4();
# Be nice.
return 1;
}
# Print the list of required integrations.
print "It seems the baseline has changed since the last synchronization:\n";
print $line, "\n";
while ($line = <FROM_P4>) {
print $line;
}
crash("You need to synchronize your developement by running 'p4ws'.");
}
# Delete a branch.
sub delete_branch {
my $branch = shift; # Doomed branch.
# Invoke p4 to delete it and verify results.
read_from_p4('branch', '-d', $branch);
expect_from_p4("Branch $branch deleted.");
}
# User commands:
# List all users.
sub users {
# Ask p4 to do it.
call_sys('p4', $p4exe, 'users');
# Be nice.
return 1;
}
# Change commands:
# List all changes (with optional filter)
sub changes {
my $filter = shift; # (Optional) filter on changes
# If no filter asked for, just call p4 directly
if (!defined($filter)) {
call_sys('p4', $p4exe, 'changes');
# Be nice.
return 1;
}
# Read line by line and filter it
read_from_p4('changes');
my $line;
while ($line = <FROM_P4>) {
# Print only lines which match the filter.
if ($line =~ /$filter/) {
print $line;
}
}
done_from_p4();
# Be nice.
return 1;
}
# Obtain a single change record.
sub change_record {
my $change = shift; # Change to obtain record of.
# Get p4 to print its definition.
read_from_p4('change', '-o', $change);
# Parse the definition.
my ($user, $client, $created, $status, $title);
my $line;
while ($line = <FROM_P4>) {
if ($line =~ /^User:\s+(\w*)/) {
$user = $1;
} elsif ($line =~ /^Client:\s+(\S*)/) {
$client = $1;
} elsif ($line =~ /^Date:\s+(\S*)/) {
$created = $1;
} elsif ($line =~ /^Status:\s+(\S*)/) {
$status = $1;
} elsif ($line =~ /^Description:/) {
$line = <FROM_P4>;
defined($line)
|| crash("Change description line is missing.");
$line !~ /<enter description here>/
|| crash("Change $change does not exist.");
if ($line =~ /^\s+(.*)/) {
$title = $1;
}
}
}
# Make sure we've got everything we need.
(defined($user)
&& defined($client)
&& defined($created)
&& defined($status)
&& defined($title))
|| crash("Couldn't parse change definition.");
# Done.
done_from_p4();
my %record = (
'user' => $user,
'client' => $client,
'created' => $created,
'status' => $status,
'title' => $title,
);
return %record;
}
# Create a new change.
sub create_change {
my $user = shift; # The user for the change.
my $title = shift; # The title of this change.
# Ask p4 to create the change.
write_to_p4('change', '-i');
print TO_P4 "Change: new\n";
print TO_P4 "Client: $p4client\n";
print TO_P4 "User: $user\n";
print TO_P4 "Status: new\n";
print TO_P4 "Description:\n";
print TO_P4 "\t$title\n";
done_to_p4();
# Now examine the results for the new change number.
my $result = <FROM_P4>;
if ($result =~ /^Change (\d*) created./) {
done_from_p4();
return $1;
} else {
# Something went wrong.
crash("Expected: Change <#> created.\n",
"Got: $result");
}
}
# Submit a change.
sub submit_change {
my $change = shift; # Change to submit.
# Invoke p4 to do it.
read_from_p4('submit', '-c', $change);
# Look for the updated change number.
# Display the lines to the user in case they are of interest.
my $renumbered;
my $line;
while ($line = <FROM_P4>) {
print $line;
if ($line =~ /^Change $change submitted./) {
$renumbered = $change;
}
if ($line =~ /Change $change renamed change (\d+) and submitted./) {
$renumbered = $1;
}
}
# If we got the renumbering line, the submit was successful.
defined($renumbered)
|| crash("Attempt to submit change $change has failed.");
# Close file.
done_from_p4();
# Return the new number of the change.
return $renumbered;
}
# Delete a change.
sub delete_change {
my $change = shift; # Change to delete.
# Invoke p4 to do it.
read_from_p4('change', '-d', $change);
expect_from_p4("Change $change deleted.");
# Be nice.
return 1;
}
# These map between integration operations and normal ones.
my %integ_to_work = (
'integrate' => 'edit',
'delete' => 'delete',
'branch' => 'add'
);
# Convert an integration change operation to a normal operation.
sub integ_to_work {
my $integ_op = shift; # Operation to convert.
my $work_op = $integ_to_work{$integ_op};
defined($work_op)
|| crash("Integration operation '$integ_op' is not recognized.");
return $work_op;
}
# Get hash of files (and operations) of a change.
sub change_files {
my $change = shift; # Change to list details of
# Ask p4 for a change description
read_from_p4('describe', '-s', $change);
# Look for file operation lines.
my %change_files;
my $line;
while ($line = <FROM_P4>) {
if ($line =~ m://depot/baseline/(\S+)#\d+ (\w+):) {
my $file = $1;
my $op = integ_to_work($2);
$change_files{$file} = $op;
}
}
# Done.
done_from_p4();
return %change_files;
}
# Fix commands:
# Create a new fix.
sub create_fix {
my $change = shift; # Change to associate with job.
my $job = shift; # Job to associate with change.
# Just invoke p4 to do it (verifying the results).
my $name = p4_job_name($job);
read_from_p4('fix', '-c', $change, $name);
expect_from_p4("$name fixed by change $change.");
# Be nice.
1;
}
# Delete a fix.
sub delete_fix {
my $change = shift; # Change to disassociate with job.
my $job = shift; # Job to disassociate with change.
# Just invoke p4 to do it (verifying the results).
my $name = p4_job_name($job);
read_from_p4('fix', '-d', '-c', $change, $name);
expect_from_p4("Deleted fix $name by change $change.");
# Be nice.
1;
}
# File commands:
# Get files from depot.
sub get_files {
# @::ARG is expected to contain the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'get', @::ARG);
# Be nice.
return 1;
}
# Refresh (unopened) files from depot.
sub refresh_files {
# @::ARG is expected to contain the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'refresh', @::ARG);
# Be nice.
return 1;
}
# Print files from depot.
sub print_files {
# @::ARG is expected to contain the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'print', @::ARG);
# Be nice.
return 1;
}
# Diff files to the depot.
sub diff_files {
# @::ARG is expected to contain the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'diff', @::ARG);
# Be nice.
return 1;
}
# Resolve (integrated) files from depot.
sub resolve_files {
my $reresolve = shift; # Is this a re-resolve?
# @::ARG is expected to contain the list of files,
# and any relevant control arguments.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, ($reresolve ? 'reresolve' : 'resolve'), @::ARG);
# Be nice.
return 1;
}
# Verify there's nothing more to do to resolve files.
sub verify_resolve_files {
my $view = shift; # View for files to resolve
# Ask p4 whether there's anything to do.
read_from_p4('resolve', '-n', $view);
# Expect that no files need to be resolved.
my $line = <FROM_P4>;
chop($line);
if ($line eq "$view - no file(s) to resolve.") {
done_from_p4();
# Be nice.
return 1;
}
# Print the list of required integrations.
print "It seems you didn't completely resolve the last synchronization:\n";
print $line, "\n";
while ($line = <FROM_P4>) {
print $line;
}
crash("You need to synchronize your developement by running 'p4ws'.");
}
# Verify there's nothing more to do to get files.
sub verify_get_files {
my $view = shift; # View for files to resolve
# Ask p4 whether there's anything to do.
read_from_p4('get', '-n', $view);
# Expect that no files need to be resolved.
my $line = <FROM_P4>;
chop($line);
if ($line eq "$view - file(s) up-to-date.") {
done_from_p4();
# Be nice.
return 1;
}
# Print the list of required integrations.
print "It seems you don't have the latest version of $view:\n";
print $line, "\n";
while ($line = <FROM_P4>) {
print $line;
}
crash("You can get the latest version using 'p4fg'.");
}
# Revert files (to before change started).
sub revert_files {
my $change = shift; # Change to revert files for
my $del_opt = shift; # '-d' if we're to delete files.
# @::ARG is expected to contain the change number + the list of files.
if ($del_opt eq '') {
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'revert', '-c', $change, @::ARG);
# Be nice.
return 1;
}
# Read all reverted files
read_from_p4('revert', '-c', $change, @::ARG);
my $line;
while ($line = <FROM_P4>) {
print $line;
if ($line =~ /([^#]*)#.* \- was branch, cleared/) {
my $file = depot_to_disk($1);
$::OUTPUT_AUTOFLUSH = 1; print "(rm) $file\n";
remove_file($file);
}
if ($line =~ /([^#]*)#.* \- was add, abandoned/) {
my $file = depot_to_disk($1);
$::OUTPUT_AUTOFLUSH = 1; print "(rm) $file\n";
remove_file($file);
}
}
# Done.
done_from_p4();
# Be nice.
return 1;
}
# Delete files.
sub delete_files {
# @::ARG is expected to contain the change number + the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'delete', '-c', @::ARG);
# Be nice.
return 1;
}
# Edit files.
sub edit_files {
# @::ARG is expected to contain the change number + the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'edit', '-c', @::ARG);
# Be nice.
return 1;
}
# Add files.
sub add_files {
# @::ARG is expected to contain the change number + the list of files.
# Invoke p4, hoping for the best.
call_sys('p4', $p4exe, 'add', '-c', @::ARG);
# Be nice.
return 1;
}
# Return all opened files and their operations.
sub opened_files {
my $job = shift; # Job to get file operations for.
my $record = shift; # (Reference to) job's record.
my $must_have = shift; # Must have opened files?
# Do not insist on files by default.
if (!defined($must_have)) {
$must_have = 0;
}
# Ask p4 for the list.
my $user = $record->{user};
my $retry = $record->{retry};
my $status = $record->{status};
my $prefix = ($status eq 'work'
? "//depot/$user/$job-$retry"
: "//depot/baseline");
read_from_p4('opened', $prefix . '/...');
# Collect files into a hash table.
my %job_files;
my $line;
while ($line = <FROM_P4>) {
# Verify that there _are_ any opened files, if requested.
if ($line =~ /not opened on this client/) {
!$must_have
|| crash("Job $job (attempt #$retry) by $user ",
"has no opened files.");
# Look for file operations.
} elsif ($line =~ m:$prefix/(\S+)#\d+ \- (\w+):) {
my $file = $1;
my $op = $2;
$job_files{$file} = $op;
# Something went wrong...
} else {
crash($line, "Bad output from 'p4 opened'.");
}
}
# Done.
done_from_p4();
return %job_files;
}
# Add into an array any opened files from a previous submit of a job.
sub old_opened_files {
my $job = shift; # Job to get file operations for.
my $record = shift; # (Reference to) job's record.
my $job_files = shift; # (Reference to) current job files.
# Due to our protection scheme, p4 only allows the following to
# the integrator.
my $user = $record->{user};
my $retry = $record->{retry};
$ENV{P4USER} = 'integ';
read_from_p4('integ', '-n', '-r', '-b', "$user-$job-$retry");
$ENV{P4USER} = $p4user;
# Parse all lines.
my $line;
while ($line = <FROM_P4>) {
if ($line =~ m://depot/baseline/(\S+)#\d+ \- (\w+):) {
my $file = $1;
my $op = integ_to_work($2);
# Only add the file if it isn't in the current change.
if (!defined($job_files->{$file})) {
$job_files->{$file} = $op;
}
}
}
done_from_p4();
# Be nice.
return 1;
}
# Obliterate files. This is not part of any change!
sub obliterate_files {
# @::ARG is expected to contain the list of files.
# Due to our protection scheme, p4 only allows the following to
# the integrator.
$ENV{P4USER} = 'integ';
call_sys('p4', $p4exe, 'obliterate', '-y', @::ARG);
$ENV{P4USER} = $p4user;
# Be nice.
return 1;
}
# Version commands:
# Obtain the currently used version number.
sub get_version {
# The last used version number is stored in a special job.
read_from_p4('job', '-o', 'version');
# Look for the version number.
my $version;
my $line;
while ($line = <FROM_P4>) {
# Job does not exist - "version 0".
if ($line =~ /<enter description here>/) {
$version = 0;
last;
}
# Job exists - contains used version number in description.
if ($line =~ /Version: (\d+)/) {
$version = $1;
last;
}
}
# Verify we got it.
defined($version)
|| crash("Bad output from 'p4 job'.");
# Done.
done_from_p4();
return $version;
}
# Set the version number.
sub set_version {
my $version = shift; # Version number to set to.
# Create/Update the version job.
write_to_p4('job', '-i');
print TO_P4 "Job: version\n";
print TO_P4 "User: version\n";
print TO_P4 "Status: closed\n";
print TO_P4 "Description:\n";
print TO_P4 "\tVersion: ", $version, "\n";
done_to_p4();
# Verify results.
expect_from_p4("Job version saved.");
# Be nice.
return 1;
}
# Create a version.
sub create_version {
my $version = shift; # Version of project.
my $job = shift; # The job creating this version.
my $record = shift; # (Reference to) job's record.
my $freeze = shift; # Create frozen version?
# By default, do not freeze.
if (!defined($freeze)) {
$freeze = 0;
}
# Create the new version. Note that the version only covers the baseline.
write_to_p4('label', '-i');
print TO_P4 "Label: L$version\n";
print TO_P4 "Owner: ", ($freeze ? 'version' : $p4user), "\n";
print TO_P4 "Description:\n";
my $user = $record->{user};
my $reviewer = $record->{reviewer};
my $title = $record->{title};
print TO_P4 "\tData: $job $user $reviewer $title\n";
print TO_P4 "View:\n";
print TO_P4 "\t//depot/baseline/... //L$version/...\n";
done_to_p4();
# Verify results.
expect_from_p4("Label L$version saved.");
# Be nice.
return 1;
}
# Synchronize the version with the current state of affair.
sub sync_version {
my $version = shift; # Version to sync version of.
# Call p4 to do it.
call_sys('p4', $p4exe, 'labelsync', '-l', "L$version");
# Be nice.
return 1;
}
# Get list of all versions.
sub versions {
# Invoke p4 for the full list.
read_from_p4('labels');
# Parse results.
my %versions;
my $line;
while ($line = <FROM_P4>) {
if ($line =~ /Label L(\d+) (\S+) 'Data: (\d+) (\w+) (\w+) (.*)'/) {
my $version = $1;
my $created = $2;
my $job = $3;
my $user = $4;
my $reviewer = $5;
my $title = $6;
my %record = (
'created' => $created,
'job' => $job,
'user' => $user,
'reviewer' => $reviewer,
'title' => $title,
);
$versions{$version} = \%record;
} else {
# This may be a pain if they are added on purpose.
warn($line);
warn("- is a foreign label.\n");
}
}
# Done.
done_from_p4();
return %versions;
}
# PRIVATE METHODS:
# Convert an integer job number to p4's job name.
sub p4_job_name {
my $job = shift; # Our job identifier
# Numbers are stored as JobXXXXXX in p4.
if ($job =~ /^\d+$/) {
return sprintf("job%06d", $job);
# Lock jobs are stored as lock_XX and owner_XX in p4.
} elsif ($job =~ /lock_\S+/ || $job =~ /owner_\S+/) {
return $job;
# Otherwise, it is some bad name.
} else {
crash("Bad job name '$job'.");
}
}
# Invoke p4 in various ways:
# Invoke a system command.
sub call_sys {
my $msg = shift; # Message in case it fails.
# $::OUTPUT_AUTOFLUSH = 1; print join(' ', @::ARG), "\n";
my $status = system(join(' ', @::ARG)) / 256;
$status == 0
|| crash("$msg failed: status $status.");
# Be nice.
return 1;
}
# Invoke a p4 command and read from it via FROM_P4.
sub read_from_p4 {
open(FROM_P4, "$p4exe " . join(' ', @::ARG) . ' 2>&1 |')
|| crash("Can't run p4: $!");
# Be nice.
return 1;
}
# Close read connection to p4.
sub done_from_p4 {
close(FROM_P4)
|| crash("Can't disconnect from p4: $!");
# Can't always delete temporary file since maybe both to_p4 and
# from_p4 were called together; in this case, closing the first
# from_p4 should not delete the temporary file - only the second
# should.
if (defined($temp_file) && defined($to_unlink)) {
unlink($temp_file)
|| warn("Can't delete $temp_file: $!");
$temp_file = undef;
$to_unlink = undef;
}
# Be nice.
return 1;
}
# Invoke a p4 command and send to its standard input.
# Output from p4 is collected into a temporary file.
sub write_to_p4 {
$temp_file = "$p4temp/" . abs($::PID) . '.cp4';
open(TO_P4, '| ' . "$p4exe " . join(' ', @::ARG) . ' > ' . $temp_file)
|| crash("Can't run p4: $!");
# Be nice.
return 1;
}
# Close write connection to p4; open read connection to result.
sub done_to_p4 {
close(TO_P4)
|| crash("Can't disconnect from p4: $!");
# Now open the temporary file through the same FROM_P4 file handle;
# this allows other methods which read from it to be applied to both
# output from from_p4 and from to_p4. Signal done_from_p4 to delete
# the file when we are done.
open(FROM_P4, $temp_file)
|| crash("Can't open $temp_file: $!");
$to_unlink = 1;
# Be nice.
return 1;
}
# Examine p4 output to check for expected results.
sub expect_from_p4 {
# @::ARG is expected to be a list of acceptable alternatives.
# Obtain the result.
my $result = <FROM_P4>;
chop($result);
defined($result)
|| crash("p4 was mysteriously silent.");
# Examine all alternatives.
my $expect;
foreach $expect (@::ARG) {
if ($expect eq $result) {
done_from_p4();
# Be nice.
return 1;
}
}
# Isn't there - print a nice message.
my $prefix = 'Expected: ';
foreach $expect (@::ARG) {
print $prefix, $expect, "\n";
$prefix = 'Or: ';
}
crash("Got: $result");
}
# HIGH LEVEL COMMANDS:
# The following provide some high-level behaviour which is
# not directly available from p4.
# Depot-level lock commands:
# Lock depot-level entity.
sub lock {
my $what = shift; # What to lock.
my $what_for = shift; # Reason for lock.
# Create a job with the name 'lock_<something>'; if it exists, it indicates
# the lock is owned by someone else. This turns out to be an atomic
# test-and-set operation.
# Create the new job.
write_to_p4('job', '-i');
print TO_P4 "Job: lock_$what\n";
print TO_P4 "User: lock\n";
print TO_P4 "Status: closed\n";
print TO_P4 "Description:\n";
print TO_P4 "\tIndicates $what is locked.\n";
done_to_p4();
# Read the new job number.
my $line = <FROM_P4>;
# Saved means job didn't previously exist.
if ($line =~ /Job lock_$what saved./) {
done_from_p4();
# By default, release the lock if something goes wrong.
$do_unlock_on_error{$what} = 1;
# Record the new owner of the lock.
set_locker($what, $p4user, $what_for);
# Be nice
return 1;
}
# Unchanged means lock already exists - owned by someone else.
if ($line =~ /Job lock_$what not changed./) {
my ($locker, $reason) = get_locker($what);
die("Sorry, $what is already locked by $locker for $reason.\n");
}
# Anything else is a cause to worry.
print "### Creating $what lock:\n";
print $line;
while ($line = <FROM_P4>) {
print $line;
}
die("p4 failed to create $what lock.\n");
}
# Store the owner of a lock so we'll be able to report it later.
sub set_locker {
my $what = shift; # What has been locked.
my $locker = shift; # New lock owner.
my $what_for = shift; # Reason for lock.
# Create/update lock owner record.
write_to_p4('job', '-i');
print TO_P4 "Job: owner_$what\n";
print TO_P4 "User: $locker\n";
print TO_P4 "Status: closed\n";
print TO_P4 "Description:\n";
print TO_P4 "\tReason: $what_for\n";
done_to_p4();
# Verify results.
expect_from_p4("Job owner_$what saved.", "Job owner_$what not changed.");
# Be nice.
return 1;
}
# Obtain lock owner and reason for lock.
sub get_locker {
my $what = shift; # Lock for what?
# Ask p4 for the data.
read_from_p4('job', '-o', "owner_$what");
# Parse each line.
my ($locker, $what_for);
my $line;
while ($line = <FROM_P4>) {
# User is the owner of the lock.
if ($line =~ /^User:\s+(\w+)/) {
$locker = $1;
}
# Our 'Reason:' line is the reason for the lock.
if ($line =~ /\s+Reason:\s+(.*)/) {
$what_for = $1;
}
}
done_from_p4();
# This could happen due to race conditions, for example.
if (!defined($what_for)) {
$locker = 'nobody';
$what_for = 'no reason';
}
# Done.
return ($locker, $what_for);
}
# Check whether something is locked.
sub check_lock {
my $what = shift; # What to check lock of.
# Look for the lock job.
read_from_p4('job', '-o', "lock_$what");
# Look for the description line.
my $line;
while ($line = <FROM_P4>) {
# This means job does not exists - whatever it is isn't locked.
if ($line =~ /<enter description here>/) {
# Not locked.
done_from_p4();
return 0;
}
}
# Is locked.
done_from_p4();
return 1;
}
# Verify something is locked.
sub verify_lock {
my $what = shift; # What to verify lock of.
# Make sure whatever it is is locked.
check_lock($what)
|| die("It seems $what is not locked.\n");
# Be nice.
return 1;
}
# Release a lock.
sub unlock {
# @::ARG is expected to contain the list of things to unlock.
# If no arguments were given, release all locks
if ($#::ARG < 0) {
@::ARG = keys(%do_unlock_on_error);
}
# Loop on all locks.
my $what;
foreach $what (@::ARG) {
# Turn this off, so if anything else goes wrong, we won't have a loop.
if (defined($do_unlock_on_error{$what})) {
delete($do_unlock_on_error{$what});
}
# Delete the lock job first, then the owner.
delete_job("lock_$what");
delete_job("owner_$what");
}
# Be nice.
return 1;
}
# Control automatic unlocking on abnormal termination.
sub unlock_on_error {
my $what = shift; # What lock to control
my $to_unlock = shift; # 1 - unlock, 0 - do not.
if ($to_unlock) {
$do_unlock_on_error{$what} = 1;
} elsif (defined($do_unlock_on_error{$what})) {
delete($do_unlock_on_error{$what});
}
# Be nice.
return 1;
}
# Die while unlocking depot.
sub crash {
# @::ARG is expected to contain error message, as usual for 'die'.
print(@::ARG, "\n");
# On error, do brutal unlock; this prevents loops, sidesteps the issue
# of <FROM_P4> and so on. Ignore errors; nothing can be done, and an
# error message will be given anyway.
my $printed = 0;
my $what;
foreach $what (keys %do_unlock_on_error) {
if (!$printed) {
print "### Remove broken locks...\n";
$printed = 1;
}
system($p4exe, 'job', '-d', "lock_$what");
system($p4exe, 'job', '-d', "owner_$what");
}
# Give up the ghost.
exit(1);
}
# File level lock commands:
# Convert a general depot file name to a lock file name.
sub depot_to_lock {
my $name = shift; # Depot file name
# If it is a baseline name, strip that
$name =~ s#//depot/baseline/##;
# If it is a development name, strip that
$name =~ s#//depot/\w+/\d+\-\d+/##;
return $name;
}
# Obtain the list of all locked files.
sub locked_files {
# Ask p4 for the list, stored in a special job.
read_from_p4('job', '-o', 'locked_files');
# Skip all irrelevant header lines.
my $line;
while ($line = <FROM_P4>) {
if ($line =~ /^Description:/) {
last;
}
}
# Start filling the locked files hash.
my %files;
while ($line = <FROM_P4>) {
if ($line =~ /\s+(\d+) (\S+)/) {
my $job = $1;
my $file = $2;
$files{$file} = $job;
}
}
# Done.
done_from_p4();
return %files;
}
# Set the list of locked files. Note that this overrides the complete list, not
# just adds entries. It should be done only when protected by a depot lock.
sub lock_files {
my $files = shift; # (Reference to) locked files hash
# Ask for the current job definition,
write_to_p4('job', '-i');
print TO_P4 "Job: locked_files\n";
print TO_P4 "User: lock\n";
print TO_P4 "Status: closed\n";
print TO_P4 "Description:\n";
print TO_P4 "\tList of locked depot files:\n";
# Loop on all entries
my ($file, $job);
while (($file, $job) = each(%$files)) {
print TO_P4 "\t$job $file\n";
}
# Submit to p4; verify results.
done_to_p4();
expect_from_p4("Job locked_files saved.",
"Job locked_files not changed.");
# Be nice.
return 1;
}
# Report utilities:
# Print list of all locks.
sub print_locks {
# Ask for the full list of jobs.
read_from_p4('jobs');
# Print nice column titles.
print "Job\tCreated \tUser\tReason\n";
print "---\t----------\t----\t------\n";
# Look for 'owner' locks.
my $line;
while ($line = <FROM_P4>) {
if ($line =~ /owner_(\S+) on (\S+) by (\w+) 'Reason: (.*)'/) {
my $job = $1;
my $date = $2;
my $user = $3;
my $reason = $4;
# Print it nicely.
print $job, "\t";
print $date, "\t";
print $user, "\t";
print $reason, "\n";
}
}
done_from_p4();
# Be nice.
return 1;
}
# Display a file log.
sub print_files_log {
# @::ARG is expected to contain the list of files.
# Invoke p4 to get raw files log.
read_from_p4('filelog', @::ARG);
my $pattern =
"#(\\d+) " # File version number.
. "change \\d+ " # Number of change (ignored).
. "\\S+ " # File operation (pretty useless).
. "on (\\S+) " # Date of integration.
. "by \\S+ " # Integrator (always 'integ').
. "'Integrate (\\d+)\-(\\d+) " # Job and retry number.
. "by (\\w+)\\. '"; # Developer.
# Filter out noise lines.
my $line;
while ($line = <FROM_P4>) {
# detect file name lines:
if ($line =~ /^\S+$/) {
print "\n", $line, "\n";
# Print nice column titles.
print "Ver.\tJob\tRe\tUser\tDate\n";
print "----\t---\t--\t----\t----\n";
}
# Parse relevant file history lines:
if ($line =~ /$pattern/) {
my $file_version = $1;
my $date = $2;
my $job = $3;
my $retry = $4;
my $user = $5;
print ' ', $file_version, "\t";
print $job, "\t";
print $retry, "\t";
print $user, "\t";
print $date, "\n";
}
}
# Be nice.
return 1;
}
# Verification utilities:
# Verify that development/integration is ready.
sub verify_job_ready {
my $job = shift; # Id of job to verify
my $record = shift; # (Reference to) job's record
# Verify that there's nothing to be done to re-integrate the work branch,
# or to resolve conflicts from previous integrations.
my $user = $record->{user};
my $retry = $record->{retry};
my $branch = "$user-$job-$retry";
my $status = $record->{status};
my $flag = ($status eq 'work' ? '' : '-r');
P4::verify_integrate_branch($branch, $flag);
P4::verify_resolve_files('//depot/baseline/...');
P4::verify_resolve_files("//depot/$user/$job-$retry/...");
# Adapt directory and messages to the mode we're working in.
my $dir = P4::view_root()
. ($status eq 'work' ? "/$user/$job-$retry" : '/baseline');
my $start_msg = ($status eq 'work'
? "### Verify development directory...\n"
: "### Verify integration directory...\n");
my $fail_msg = ($status eq 'work'
? "Work on job $job (attempt #$retry) by $user is NOT ready for review.\n"
: "Integration of job $job (attempt #$retry) by $user is NOT confirmed.\n");
$::OUTPUT_AUTOFLUSH = 1;
print $start_msg;
# This verifies the developer-provided invariant.
verify_dir($dir, $status, $job, $record->{version})
|| crash($::EVAL_ERROR, $fail_msg);
# Be nice.
return 1;
}
# Verify that a specified directory satisfies the invariant.
sub verify_dir {
my $dir = shift; # Directory to verify.
$::p4mode = $::p4mode = shift; # The mode (work/integ/base).
$::p4job = $::p4job = shift; # The relevant job number.
$::p4version = $::p4version = shift; # The project version.
# The last three are repeated
# twice to shut 'strict' up; they
# are to be used by 'verify.pl'.
# What exactly does a verification include is up to the development team.
# What we do is execute a 'verify.pl' script which is expected to exist
# in the top-level directory. If it does not call 'die', it is assumed
# that the work directory passes the verification.
chdir($dir)
|| crash("chdir($dir): $!");
# Do the actual verification.
return do './verify.pl';
}
# Verify that job would not lock already-locked files.
# Return the updated files to be locked if work is ended.
sub verify_job_locks {
my $job = shift; # Job to verify locks of.
my $record = shift; # (Reference to) job's record
# Print nice message in case things go wrong.
print "### Verify job file locks...\n";
# We need to get the files to be locked for this job.
# First, look for files opened in the development branch.
my %job_files = opened_files($job, $record, 1);
# Next, add into it the files from previous submits of the same job, if any.
old_opened_files($job, $record, \%job_files);
# This is the list of the files already locked.
my %locked_files = locked_files();
# Start adding the job files to the lock files,
# informing the caller of any collisions.
my $collisions = 0;
my $job_file;
foreach $job_file (keys(%job_files)) {
my $lock_job = $locked_files{$job_file};
if (defined($lock_job)) {
print "$job_file is locked by job $lock_job\n";
$collisions++;
} else {
$locked_files{$job_file} = $job;
}
}
# Make sure there were no collisions.
my $user = $record->{user};
my $retry = $record->{retry};
!$collisions
|| crash("Job $job (attempt #$retry) by $user ",
"conflicts with submitted jobs.");
# Done.
return %locked_files;
}
# FILE SYSTEM UTILITIES:
# The following should really be factored out to a separate package.
# This is the UNIX implementation (which will work on DOS if you have
# something like the MKS UNIX utilities). A DOS version is not that
# trivial, it turns out - but who wants to work in DOS anyway? :-)
# Delete a directory, including any sub files/directories.
sub remove_dir {
my $dir = shift; # Directory to delete.
# This will remove it if at all possible.
call_sys("remove directory $dir", "rm -rf $dir");
# Be nice.
return 1;
}
# Remove a file.
sub remove_file {
my $file = shift; # File to delete.
# This will remove it if at all possible.
call_sys("remove file $file", "rm -f $file");
# Be nice.
return 1;
}
# Copy one file to another.
sub copy_file {
my $source = shift; # File to copy from
my $target = shift; # File to copy into
# First, we need to make sure the target directory exists.
# This assumes that there is always a directory component
# in the name, which is safe in our case.
my $dir = $target;
$dir =~ s:/[^/]*$::;
if (! -d $dir) {
call_sys("create directory $dir", "mkdir -p $dir");
}
# Now we can safely call 'cp'.
call_sys("copy $source to $target", "cp -pf $source $target");
# Be nice
return 1;
}
# Be nice.
1;