# 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 (oren@capella.co.il). # :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;