########################################################################
# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
#
# Module name : jats.sh
# Module type : Makefile system
# Compiler(s) : n/a
# Environment(s): jats
#
# Description : JATS Subversion Interface Functions
#
# Requires a subversion client to be present on the machine
# Does require at least SubVersion 1.5
# Uses features not available in 1.4
#
# The package currently implements a set of functions
# There are some intentional limitations:
# 1) Non recursive
# 2) Errors terminate operation
#
# This package contains experimental argument passing
# processes. Sometimes use a hash of arguments
#
#......................................................................#
require 5.008_002;
use strict;
use warnings;
our $USER;
use JatsEnv;
package JatsSvn;
use JatsError;
use JatsSystem;
use JatsSvnCore qw(:All);
use JatsLocateFiles;
use File::Path; # Instead of FileUtils
use File::Basename;
use Cwd;
# automatically export what we need into namespace of caller.
use Exporter();
our (@ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK);
@ISA = qw(Exporter JatsSvnCore);
@EXPORT = qw(
NewSession
NewSessionByWS
NewSessionByUrl
SvnRmView
SvnIsaSimpleLabel
SvnComment
SvnUserCmd
SvnPath2Url
SvnPaths
);
@EXPORT_OK = qw(
);
%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);
#
# Global Variables
#
#-------------------------------------------------------------------------------
# Function : SvnCo
#
# Description : Create a workspace
# Can be used to extract files, without creating the
# subversion control files.
#
# Inputs : $self - Instance data
# $RepoPath - Within the repository
# $Path - Local path
# Hash of Options
# export - Bool: Export Only
# escrow - Bool: Less sanity testing
# force - Bool: Force export to overwrite
# print - Bool: Don't print files exported
# pretext=aa - Text: Display before operation
#
# Returns : Nothing
#
sub SvnCo
{
my $self = shift;
my $RepoPath = shift;
my $path = shift;
my %opt = @_;
Debug ("SvnCo", $RepoPath, $path);
Error ("SvnCo: Odd number of args") unless ((@_ % 2) == 0);
#
# Set some defaults
#
my $cmd = $opt{export} ? 'export' : 'checkout';
my $print = exists $opt{print} ? $opt{print} : 1;
$self->{CoText} = $opt{pretext} || 'Extracting';
# Define RE to be used to test extraction
# Bad news: Some Cots packages have /tags/
# Kludge : Allow /tags/ in escrow mode
#
# $self->{CoRe} = '((/)(tags|branches|trunk)(/|$))';
# $self->{CoRe} =~ s~tags\|~~ if ( $opt{escrow} );
$self->{CoRe} = '((/)(branches|trunk)(/|$))';
#
# Ensure that the output path does not exist
# Do not allow the user to create a local work space
# where one already exists
#
Error ("SvnCo: No PATH specified" ) unless ( $path );
Error ("SvnCo: Target path already exists", "Path: " . $path ) if ( ! $opt{force} && -e $path );
#
# Build up the command line
#
my @args = $cmd;
push @args, qw( --ignore-externals );
push @args, qw( --force ) if ( $opt{force} );
push @args, $RepoPath, $path;
my @co_list;
if ( $self->SvnCmd ( @args,
{
'process' => \&ProcessCo,
'data' => \@co_list,
'credentials' => 1,
'nosavedata' => 1,
'printdata' => $print,
}
) || @co_list )
{
#
# We have a checkout limitation
# Delete the workspace and then report the error
#
# Note: For some reason a simple rmtree doesn't work
# Nor does glob show all the directories
#
Verbose2 ("Remove WorkSpace: $path");
rmtree( $path, IsVerbose(3) );
rmtree( $path, IsVerbose(3) );
Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );
}
#
# Cleanup
#
delete $self->{CoText};
delete $self->{CoRe};
return;
#
# Internal routine to scan each the checkout
#
# Due to the structure of a SubVersion repository it would be
# possible for a user to extract the entire repository. This is
# not good as the repo could be very very large
#
# Assume that the structure of the repo is such that our
# user is not allowed to extract a directory tree that contains
# key paths - such as /tags/ as this would indicate that they are
# attempting to extract something that is not a package
#
#
sub ProcessCo
{
my $self = shift;
my $data = shift;
if ( $self->{PRINTDATA} )
{
#
# Pretty display for user
# Hide some noise, but not much
#
unless ( $data =~ m~^Export complete.~ )
{
Information1 ( $self->{CoText} . ': ' . $data);
}
}
#
# Detect user attempting to checkout too much of a repo
# If the extract contains a 'key' directory then create error
#
# Re is provide by caller such that $1 is the dirpath
#
if ( $data =~ m~$self->{CoRe}~ )
{
my $bad_dir = $1;
push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";
return 1;
}
##
## Limit the size of the WorkSpace
## This limit is a bit artificial, but does attempt to
## limit views that encompass too much.
##
#if ( $#{$self->{RESULT_LIST}} > 100 )
#{
# Warning ("View is too large - DEBUG USE ONLY. WILL BE REMOVED" );
# push @{$self->{ERROR_LIST}}, "View too large";
# return 1;
#}
}
}
#-------------------------------------------------------------------------------
# Function : SvnSwitch
#
# Description : Switches files and directories
#
# Inputs : $self - Instance data
# $RepoPath - Within the repository
# $Path - Local path
# Options - Options
# --NoPrint - Don't print files exported
# --KeepWs - Don't delete the WorkSpace on error
#
# Returns : Nothing
#
sub SvnSwitch
{
my ($self, $RepoPath, $path, @opts) = @_;
my $printdata = ! grep (/^--NoPrint/, @opts );
my $keepWs = grep (/^--KeepWs/, @opts );
Debug ("SvnSwitch", $RepoPath, $path);
#
# Build up the command line
#
my @sw_list;
if ( $self->SvnCmd ( 'switch', $RepoPath, $path,
{
'process' => \&ProcessSwitch,
'data' => \@sw_list,
'credentials' => 1,
'nosavedata' => 1,
'printdata' => $printdata,
}
) || @sw_list )
{
#
# We have a switch problem
# Delete the workspace and then report the error
#
# Note: For some reason a simple rmtree doesn't work
# Nor does glob show all the directories
#
unless ( $keepWs )
{
Verbose2 ("Remove WorkSpace: $path");
rmtree( $path, IsVerbose(3) );
rmtree( $path, IsVerbose(3) );
Error ("Switch elements", @{$self->{ERROR_LIST}}, @sw_list );
}
Warning("Switch error: Workspace state unknown", @{$self->{ERROR_LIST}}, @sw_list);
}
return;
#
# Internal routine to scan each line of the Switch output
# Use to provide a nice display
#
sub ProcessSwitch
{
my $self = shift;
my $data = shift;
if ( $self->{PRINTDATA} )
{
#
# Pretty display for user
#
Information1 ("Switching : $data");
}
}
}
#-------------------------------------------------------------------------------
# Function : SvnCi
#
# Description : Check in the specified WorkSpace
#
# Inputs : $self - Instance data
# A hash of named arguments
# comment - Commit comment
# allowSame - Allow no change to the workspace
#
# Returns : Tag of the checkin
#
sub SvnCi
{
my $self = shift;
my %opt = @_;
my $status_url;
my $ws_rev;
Debug ("SvnCi");
Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);
#
# Validate the source path
# Note: populates %{$self->{InfoWs}} with 'info' data
#
my $path = SvnValidateWs ($self, 'SvnCi');
#
# Examine %{$self->{InfoWs}}, which has the results of an 'info'
# command the locate the URL.
#
# This contains the target view space
# Sanity test. Don't allow Checkin to a /tags/ area
#
$status_url = $self->{InfoWs}{URL};
$ws_rev = $self->{InfoWs}{Revision};
Error ("SvnCi: Cannot determine Repositoty URL")
unless ( $status_url );
Error ("SvnCi: Not allowed to commit to a 'tags' area", "URL: $status_url")
if ( $status_url =~ m~/tags(/|$)~ );
#
# Commit
# Will modify Repo, so kill the cached Info
# Will only be a real issue if we tag in the same session
#
delete $self->{'InfoWs'};
delete $self->{'InfoRepo'};
$self->SvnCmd ( 'commit', $path
, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),
, { 'credentials' => 1,
'process' => \&ProcessRevNo,
'error' => "SvnCi: Copy Error",
}
);
#
# No error and no commit
# Workspace was not changed, may be allowed
#
delete $self->{NoRepoChanges};
if ( ! $self->{REVNO} && $opt{allowSame} )
{
Warning ("SvnCi: Workspace matches Repository. No commit");
$self->{REVNO} = $ws_rev;
$self->{NoRepoChanges} = 1;
}
Error ("SvnCi: Cannot determine Revision Number", @{$self->{RESULT_LIST}})
unless ( $self->{REVNO} );
#
# Update the view
# Doing this so that the local view contains an up to date
# revision number. If not done, and a 'copy' is done based
# on this view then the branch information will indicate that
# the copy is based on an incorrect version.
# This can be confusing!
#
$self->SvnCmd ( 'update' , $path
, '--ignore-externals'
, { 'credentials' => 1,
'error' => "SvnCi: Updating WorkSpace" }
);
#
# Pass the updated revision number back to the user
#
$self->CalcRmReference($status_url);
Message ("Commit Tag is: " . $self->{RMREF} );
return $self->{RMREF} ;
}
#-------------------------------------------------------------------------------
# Function : SvnCreatePackage
#
# Description : Create a package and any associated files
#
# Inputs : $self - Instance data
# A hash of named arguments
# package - Name of the package
# May include subdirs
# new - True: Must not already exist
# replace - True: Replace targets
# import - DirTree to import
# label - Tag for imported DirTree
# type - Import TTB target
# printdata - True: Print extracted files (default)
#
#
# Returns : Revision of the copy
#
sub SvnCreatePackage
{
my $self = shift;
my %opt = @_;
my $target;
Debug ("SvnCreatePackage", @_);
Error ("Odd number of args to SvnCreatePackage") unless ((@_ % 2) == 0);
my %dirs = ( 'trunk/' => 0,
'tags/' => 0,
'branches/' => 0 );
#
# Sanity Tests and defaul values
#
my $package = $self->Full || Error ("SvnCreatePackage: No package name provided");
Error ("SvnCreatePackage: Invalid import path") if ( $opt{'import'} && ! -d $opt{'import'} );
Error ("SvnCreatePackage: Tag without Import") if ( $opt{'label'} && ! $opt{'import'} );
$opt{'label'} = SvnIsaSimpleLabel( $opt{'label'} ) if ( $opt{'label'} );
$opt{'printdata'} = 1 unless ( exists $opt{'printdata'} );
#
# Package path cannot contain any of the keyword paths tags,trunk,branches
# as this would place a package with a package
#
Error ("Package path contains a reserved word ($1)", "Path: $package")
if ( $package =~ m~/(tags|branches|trunk)(/|$)~ );
#
# Package path cannot be pegged, or look like one
#
Error ("Package name contains a Peg ($1)", "Path: $package")
if ( $package =~ m~.*(@\d+)$~ );
#
# Determine TTB target
# The TTB type for branches and tags also conatins the branch or tag
#
$opt{'type'} = 'trunk' unless ( $opt{'type'} );
if ( $opt{'type'} =~ m~^(tags|branches|trunk)(/|$)(.*)~ ) {
Error ("SvnCreatePackage: TTB type ($1) must be followed by a path element")
if ( (($1 eq 'tags') or ($1 eq 'branches' )) && ! $3 );
Error ('SvnCreatePackage: TTB type of trunk must not be followed by a path element: ' . $opt{'type'})
if ( ($1 eq 'trunk') && $3 );
} else {
Error ("SvnCreatePackage: Invalid TTB Type: " . $opt{'type'} );
}
#
# Before we import data we must ensure that the targets do not exist
# Determine the import target(s)
#
my $import_target;
my $copy_target;
$self->{DEVBRANCH} = 'trunk';
if ( $opt{'import'} )
{
#
# Primary target
# trunk, branck or tag
#
$import_target = $package . '/' . $opt{'type'};
$self->{DEVBRANCH} = $opt{'type'} ;
$self->SvnValidateTarget( 'target' => $import_target,
'delete' => $opt{'replace'},
'available' => 1 );
#
# Secondary target
# Are we tagging the import too
#
if ( $opt{'label'} )
{
$copy_target = $package . '/tags/' . $opt{'label'};
$self->SvnValidateTarget( 'target' => $copy_target,
'delete' => $opt{'replace'},
'available' => 1 );
}
}
#
# Probe to see if the package exists
#
my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'SvnCreatePackage', $package );
if ( @$ref_dirs )
{
Error ("SvnCreatePackage: Package directory exists",
"Cannot create a package here. Unexpected subdirectories:", @$ref_dirs);
}
if ( @$ref_files )
{
Warning ("SvnCreatePackage: Unexpected files found",
"Path: $package",
"Unexpected files found: @$ref_files");
}
#
# Check sanity of the users source directory - if importing
# The following directories are not allowed
# .svn - attempting to import an svn workspace
# tags, trunk, branches - attempt to import directory with reserved names
# .git, .hg, .cvs - other version control systems
#
if ( $import_target )
{
my $search = JatsLocateFiles->new("--Recurse=1",
"--DirsOnly",
"--FullPath",
"--FilterIn=.svn",
"--FilterIn=.git",
"--FilterIn=.hg",
"--FilterIn=.cvs",
"--FilterIn=tags",
"--FilterIn=trunk",
"--FilterIn=branches",
);
my @badDirs = $search->search($opt{'import'});
if (@badDirs)
{
Error("SvnCreatePackage: Invalid directories found within imported source tree:", @badDirs);
}
}
if ( @$ref_svn )
{
#
# Do we need a new one
#
Error ("SvnCreatePackage: Package exists: $package") if $opt{'new'};
#
# Some subversion files have been found here
# Create the rest
# Assume that the directory tree is good
#
#
# Some, or all, of the required package subdirectories exist
# Determine the new ones to created so that it can be done
# in an atomic step
#
delete $dirs{$_} foreach ( @$ref_svn );
if ( keys %dirs )
{
Warning ("SvnCreatePackage: Not all package subdirs present",
"Remaining dirs will be created",
"Found: @$ref_svn") if @$ref_svn;
}
else
{
Warning ("SvnCreatePackage: Package already present");
}
}
#
# Create package directories that have not been discovered
# trunk
# branches
# tags
#
my @dirs;
push @dirs, $package . '/' . $_ foreach ( keys %dirs );
$target = $package . '/trunk';
#
# Create missing directories - if any
#
if ( @dirs )
{
$self->SvnCmd ('mkdir', @dirs
, '-m', $self->Path() . ': Created by SvnCreatePackage'
, '--parents'
, { 'credentials' => 1
,'error' => "SvnCreatePackage"
,'process' => \&ProcessRevNo
} );
}
#
# Import data into the package if required
# Import data. Possible cases:
# - Import to trunk - and then tag it
# - Import to branches
# - Import to tags
#
if ( $import_target )
{
Verbose ("Importing directory into new package: $opt{'import'}");
$target = $import_target;
$self->{PRINTDATA} = $opt{'printdata'};
$self->SvnCmd ('import', $opt{'import'}
, $target
, '-m', 'Import by SvnCreatePackage'
, '--force'
, { 'credentials' => 1
,'error' => "Import Incomplete"
,'process' => \&ProcessRevNo
,'printdata' => $opt{'printdata'}
})
}
#
# If imported to the trunk AND a label is provided
# then tag the import as well.
# A simple URL copy
#
if ( $copy_target )
{
Verbose ("Labeling imported trunk: $opt{'label'} ");
$target = $copy_target;
$self->SvnCmd ('copy' , $import_target
, $target
, '-m', 'Import tagged by SvnCreatePackage'
, { 'credentials' => 1
, 'process' => \&ProcessRevNo
, 'error' => "Import Incomplete" } );
}
#
# If we have done very little then we won't know the version
# of the repo. Need to force it
#
unless ( $self->{REVNO} || $self->{WSREVNO} )
{
$self->SvnInfo( $package, 'InfoRepo' );
$self->{REVNO} = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCreatePackage: Bad info for Repository");
}
#
# Pass the updated revision number back to the user
#
$self->CalcRmReference($target);
Message ("Create Package Rm Ref : " . $self->RmRef);
Message ("Create Package Vcs Tag: " . $self->SvnTag);
return $self->{RMREF} ;
}
#-------------------------------------------------------------------------------
# Function : SvnRmView
#
# Description : Remove a Subversion view
# Will run sanity checks and only remove the view if
# all is well
#
# Inputs : A hash of named arguments
# path - Path to local workspace
# modified - Array of files that are allowed to be modified
# force - True: Force deletion
#
# Returns :
#
sub SvnRmView
{
my %opt = @_;
Debug ("SvnRmView");
Error ("Odd number of args to SvnRmView") unless ((@_ % 2) == 0);
#
# Sanity test
#
my $path = $opt{'path'} || '';
my $path_length = length ($path);
Verbose2 ("Delete WorkSpace: $path");
#
# If the path does not exist then assume that its already deleted
#
unless ( $path && -e $path )
{
Verbose2 ("SvnRmView: Path does not exist");
return;
}
#
# Create information about the workspace
# This will also validate the path
#
my $session = NewSessionByWS ( $path, 0, 1 );
#
# Validate the path
#
$session->SvnValidateWs ($path, 'SvnRmView');
#
# Ask subversion if there are any files to be updated
# Prevent deletion of a view that has modified files
#
unless ( $opt{'force'} )
{
$session->SvnWsModified ( 'cmd' => 'SvnRmView', %opt );
}
#
# Now we can delete it
#
Verbose2 ("Remove WorkSpace: $path");
rmtree( $path, IsVerbose(3) );
}
#-------------------------------------------------------------------------------
# Function : SvnCopyWs
#
# Description : Copy a workspace to a new place in the repository
# Effectively 'label' the workspace
#
# It would appear that the 'copy' command is very clever
# If a version-controlled file has been changed
# in the source workspace, then it will automatically be
# copied. This is a trap.
#
# Only allow a 'copy' if there are no modified
# files in the work space (unless overridden)
#
# Only allow a 'copy' if the local workspace is
# up to date with respect with the repo. It possible
# to do a 'commit' and then a 'copy' (tag) and have
# unexpected results as the workspace has not been
# updated. This is a trap.
#
# Only allow a 'copy' if the local workspace NOT a
# mixed workspace. A mixed workspace will have
# unexpected results - files will be added/deleted/moved
# on 'tags' but not appear on the source branch.
# This is a trap.
#
#
# Inputs : $self - Instance data
# A hash of named arguments
# path - Path to local workspace
# target - Location within the repository to copy to
# comment - Commit comment
# modified - Array of files that are allowed to
# be modified in the workspace.
# noswitch - True: Don't switch to the new URL
# replace - True: Delete existing tag if present
# allowLocalMods - True: Allow complex tagging
# noupdatecheck - True: Do not check that the WS is up to date
#
# Returns : Revision of the copy
#
sub SvnCopyWs
{
my $self = shift;
my %opt = @_;
my $rv;
Debug ("SvnCopyWs");
Error ("Odd number of args to SvnCopyWs") unless ((@_ % 2) == 0);
Error ("SvnCopyWs: No Workspace" ) unless ( $self->{WS} );
#
# Insert defaults
#
my $target = $opt{target} || Error ("SvnCopyWs: Target not specified" );
#
# Validate the source path
#
my $path = SvnValidateWs ($self, 'SvnCopyWs');
#
# Validate the target
# Cannot have a 'peg'
#
Error ("SvnCopyWs: Target contains a Peg: ($1)", $target)
if ( $target =~ m~(@\d+)\s*$~ );
#
# Ensure the workspace is not Mixed
# Perform an svn info -R and ensure that all files are at the same 'Revision'
# Note: can't use the --show-item option as not all versions of svn support this
#
unless ( $opt{allowLocalMods} )
{
Verbose "Ensure workspace does not contain Mixed Revisions";
$rv = $self->SvnCmd ( 'info', '-R' , $path
, { 'process' => \&ProcessMixedRev,
'nosavedata' => 1,
'printdata' => 0,
}
);
if ($rv)
{
my @err1 = @{$self->{ERROR_LIST}};
Error ("SvnCopyWs: Check Mixed Versions", @err1);
}
if ($self->{'MixedRev'} )
{
Error ('SvnCopyWs: The Workspace contains mixed revision.',
'This will result in file changes being made on the \'tags\' path and not',
'correctly represented on the branch/trunk.',
'Update the workspace and try again.');
}
}
#
# Ensure the Workspace is up to date
# Determine the state of the Repo and the Workspace
#
unless ( $opt{noupdatecheck} )
{
$self->SvnInfo( $self->{WS} , 'InfoWs' );
$self->SvnInfo( $self->FullWs, 'InfoRepo' );
my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Workspace. No 'Last Changed Rev'");
my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Repository. No 'Last Changed Rev'");
Verbose("WS Rev : $wsLastChangedRev");
Verbose("Repo Rev: $repoLastChangedRev");
Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',
'Possibly caused by a commit without an update.',
'Update the workspace and try again.',
"Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );
}
#
# Examine the workspace and ensure that there are no modified
# files - unless they are expected
#
$self->SvnWsModified ( 'cmd' => 'SvnCopyWs', %opt );
#
# Validate the repository
# Ensure that the target does not exist
# The target may be deleted if it exists and allowed by the user
#
$self->SvnValidateTarget ( 'cmd' => 'SvnCopyWs',
'target' => $target,
'delete' => $opt{replace},
'comment' => 'Deleted by SvnCopyWs'
);
#
# Copy source to destination
# Assuming the WorkSpace is up to date then, even though the source is a
# WorkSpace, the copy does not transfer data from the WorkSpace.
# It appears as though its all done on the server. This is good - and fast.
#
# If the Workspace is not up to date, then files that SVN thinks have not
# been transferred will be transferred - hence the need to update after
# a commit.
#
# Moreover, files that are modified in the local workspace will
# be copied and checked into the target, but this is not nice.
#
$rv = $self->SvnCmd ( 'cp' , $path
, $target
, '--parents'
, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),
, { 'process' => \&ProcessRevNo,
'credentials' => 1,
'printdata' => 0,
}
);
if ($rv)
{
#
# Error in copy
# Attempt to delete the target. Don't worry if we can't do that
#
my @err1 = @{$self->{ERROR_LIST}};
$self->SvnCmd ( 'delete'
, $target
, '-m', 'Deleted by SvnCopyWs after creation failure'
, { 'credentials' => 1, }
);
Error ("SvnCopyWs: Copy Error", @err1);
}
Error ("SvnCopyWs: Cannot determine Revision Number", @{$self->{RESULT_LIST}})
unless ( $self->{REVNO} );
Verbose2 ("Copy committed as revision: " . $self->{REVNO} );
unless ( $opt{'noswitch'} )
{
#
# Switch to the new URL
# This will link the Workspace with the copy that we have just made
#
$self->SvnCmd ( 'switch', $target
, $path
, { 'credentials' => 1,
'error' => "SvnCopyWs: Cannot switch to new URL" }
);
}
#
# Pass the updated revision number back to the user
#
$self->CalcRmReference($target);
#Message ("Tag is: " . $self->{RMREF} );
return $self->{RMREF} ;
}
#-------------------------------------------------------------------------------
# Function : ProcessMixedRev
#
# Description : Process svn output looking for mixed revisions in the workspace
# Just interested in the 'Revision:' of each file
# Really just want to know if there is more than one revision
# workspace.
#
# Inputs : $self - Class Data
# $line - Input data to parse
#
# Returns : 0 - Do not terminate input command
#
sub ProcessMixedRev
{
my ($self, $line ) = @_;
Message ( $line ) if $self->{PRINTDATA};
$line =~ s~\s+$~~;
return 0 unless ( $line );
return 0 unless ($line =~ m~^Revision:\s*(\d+)~);
my $revNo = $1;
my $revNoStash = \%{$self->{revNoStash}};
$revNoStash->{$revNo}++;
if (scalar keys %{$revNoStash} > 1 ) {
$self->{'MixedRev'} = 1;
return 1;
}
return 0;
}
#-------------------------------------------------------------------------------
# Function : SvnWsModified
#
# Description : Test a Workspace for modified files
# Allow some files to be modified
#
# Inputs : $self - Instance data
# A hash of named arguments
# path - Path to local workspace
# modifiedRoot - Alternate base for files
# modified - Files that are allowed to be modified
# Relative to the 'path' or 'modifiedRoot'
# May be a single file or an array of files
# allowLocalMods - Only warn about local mods
# cmd - Command name for error reporting
#
# Returns :
#
sub SvnWsModified
{
my $self = shift;
my %opt = @_;
Debug ("SvnWsModified");
Error ("Odd number of args to SvnWsModified") unless ((@_ % 2) == 0);
my $cmd = $opt{'cmd'} || 'SvnWsModified';
#
# Validate the path
#
SvnValidateWs ($self, $cmd);
my $path = $self->{WS};
my $modifiedRoot = $opt{'modifiedRoot'} || $path;
my $path_length = length ($modifiedRoot);
Verbose2 ("Test Workspace for Modifications: $path");
#
# Ask subversion if there are any files to be updated
#
$self->SvnCmd ('status', $path, {'error' => "Svn status command error"} );
#
# Examine the list of modified files
#
if ( @{$self->{RESULT_LIST}} )
{
#
# Create a hash of files that are allowed to change
# These are files relative to the base of the view
#
# The svn command has the 'path' prepended, so this
# will be removed as we process the commands
#
my %allowed;
my @unexpected;
if ( exists $opt{'modified'} )
{
$allowed{'/' . $_} = 1 foreach ( ref ($opt{'modified'}) ? @{$opt{'modified'}} : $opt{'modified'} );
}
#
# Process the list of modified files
# Do this even if we aren't allowed modified files as we
# still need to examine the status and kill off junk entries
# ie: ?, I, ! and ~
#
# First column: Says if item was added, deleted, or otherwise changed
# ' ' no modifications
# 'A' Added
# 'C' Conflicted
# 'D' Deleted
# 'I' Ignored
# 'M' Modified
# 'R' Replaced
# 'X' item is unversioned, but is used by an externals definition
# '?' item is not under version control
# '!' item is missing (removed by non-svn command) or incomplete
# '~' versioned item obstructed by some item of a different kind
#
foreach my $entry ( @{$self->{RESULT_LIST}} )
{
#
# Extract filename from line
# First 8 chars are status
# Remove WS path too
#
if ( length $entry >= 8 + $path_length)
{
my $file = substr ( $entry, 8 + $path_length );
next if ( $allowed{$file} );
}
# Some (older) instances of SVN compail about externals as they scan them
# Note: Don't happen if we use --xml
#
if ($entry =~ m~^Performing status on external item at~)
{
next;
}
#
# Examine the first char and rule out funny things
#
my $f1 = substr ($entry, 0,1 );
next if ( $f1 =~ m{[?I!~]} );
push @unexpected, $entry;
}
if ( @unexpected )
{
if ( $opt{allowLocalMods} ) {
Message ("Workspace contains locally modified files:", @unexpected);
} else {
Error ("Workspace contains unexpected modified files", @unexpected);
}
}
}
}
#-------------------------------------------------------------------------------
# Function : SvnListPackages
#
# Description : Determine a list of packages within the repo
# This turns out to be a very slow process
# so don't use it unless you really really need to
#
# Inputs : $self - Instance data
# $repo - Name of the repository
# Last argument may be a hash of options.
# Progress - True: Show progress
# Show - >1 : display matched Tags and stats
# >2 : display Packages
# Tag - Enable Tag Matching
# Value is the tag to match
#
# Returns : Ref to an array of all packages
# Ref to an array of all packahes with matched tag
#
sub SvnListPackages
{
#
# Extract arguments and options
# If last argument is a hesh, then its a hash of options
#
my $opt;
$opt = pop @_
if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
my ($self, $repo) = @_;
my @path_list = '';
my @list;
my @mlist;
my $scanned = 0;
Debug ("SvnListPackages");
while ( @path_list )
{
my $path = shift @path_list;
if ( $opt->{Progress} )
{
Message ("Reading: " . ( $path || 'RepoRoot') );
}
$scanned++;
my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Packages', join( '/', $repo, $path) );
#
# If there are Subversion dirs (ttb) in this directory
# then this is a package. Add to list
#
push @list, $path if ( @$ref_svn );
#
# Add subdirs to the list of paths to explore
#
foreach ( @$ref_dirs )
{
chop; # Remove trailing '/'
push @path_list, $path ? join('/', $path , $_) : $_; # Extend the path
}
}
if ( $opt->{Tag} )
{
my $tag = $opt->{Tag};
foreach my $path ( sort @list )
{
Message ("Testing: $path") if ( $opt->{Progress} );
if ( $self->SvnTestPath ( 'Listing Packages', join('/', $repo, $path, 'tags', $tag) ) )
{
push @mlist, $path;
}
}
}
if ( $opt->{Show} )
{
Message ("Found Tags:", @mlist );
Message ("Found Packages:", @list ) if $opt->{Show} > 2;
Message ("Tags Found: " . scalar @mlist );
Message ("Packages Found: " . scalar @list );
Message ("Dirs Scanned: $scanned");
}
return \@list, \@mlist;
}
#-------------------------------------------------------------------------------
# Function : ListLabels
#
# Description : List labels within a given package
#
# Inputs : $self - Instance data
# $path - path to label source
#
# Returns : Ref to an array
#
sub ListLabels
{
my ($self, $path) = @_;
Debug ("ListLabels");
my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Versions', $path );
Error ("List: Path not found: $path") unless ( $found );
#
# Dont report files - just directories
#
return $ref_dirs;
}
#-------------------------------------------------------------------------------
# Function : SvnLocateWsRoot
#
# Description : Given a WorkSpace, determine the root of the work space
# This is not as simple as you might think
#
# Algorithm
# svn ls ..
# Am I in the parent directory
# Repeat
#
# Updates 'WS' and 'WSURL'
#
# Inputs : $self - Instance data
# $test - True: Don't die on error
#
# Returns : Root of workspace as an absolute address
# Will not return if there is an error
#
sub SvnLocateWsRoot
{
my ($self, $test) = @_;
my @path;
my $path = $self->{WS};
my $found;
my $rv;
Debug ("SvnLocateWsRoot");
Error ("SvnLocateWsRoot: No Workspace") unless ( $path );
Verbose2 ("SvnLocateWsRoot($test): Start in $path");
#
# Validate the source path
#
$rv = SvnValidateWs ($self, 'SvnLocateWsRoot', $test);
if ( $test && $rv )
{
Verbose2("SvnLocateWsRoot: Invalid path: $rv");
return undef;
}
#
# Under Subversion 1.7 the process is a lot easier
#
if ( exists $self->{'InfoWs'}{'Working Copy Root Path'} )
{
#
# WS is now known
#
$self->{WS} = $self->{'InfoWs'}{'Working Copy Root Path'};
#
# Calculate WSURL
#
$self->{WSURL} = join('/', $self->{PKGROOT}, $self->{DEVBRANCH})
if ($self->{DEVBRANCH});
$found = 1;
}
else
{
# Preversion 1.7
Warning ("Using svn < 1.7. This is not recommended");
#
# Need to sanitize the users path to ensure that the following
# algorithm works. Need:
# 1) Absolute Path
# 2) Not ending in '/'
#
#
# If we have a relative path then prepend the current directory
# An absolute path is:
# /aaa/aa/aa
# or c:/aaa/aa/aa
#
$path = getcwd() . '/' . $path
unless ( $path =~ m~^/|\w:/~ );
#
# Walk the bits and remove ".." directories
# Done by pushing non-.. elements and poping last entry for .. elements.
# Have a leading "/" which is good.
#
# Create a array of directories in the path
# Split on one or more \ or / separators
#
foreach ( split /[\\\/]+/ , $path )
{
next if ( $_ eq '.' );
unless ( $_ eq '..' )
{
push @path, $_;
}
else
{
Error ("SvnLocateWsRoot: Bad Pathname: $path")
if ( $#path <= 0 );
pop @path;
}
}
#
# Need to adjust the WSURL too
# Break into parts and pop them off as we go
# Add a dummy one to allow for the first iteration
#
my @wsurl = (split (/[\\\/]+/ , $self->{WSURL}), 'Dummy');
Verbose2 ("Clean absolute path elements: @path");
PATH_LOOP:
while ( @path )
{
#
# This directory element. Append / to assist in compare
# Determine parent path
#
my $name = pop (@path) . '/';
my $parent = join ('/', @path );
pop @wsurl;
#
# Examine the parent directory
# Get a list of all elements in the parent
# Need to ensure that this directory is one of them
#
# Ignore any errors - assume that they are because the
# parent is not a part of the work space. This will terminate the
# search.
#
$self->SvnCmd ('list', $parent, '--depth', 'immediates' );
foreach my $entry ( @{$self->{RESULT_LIST}} )
{
next PATH_LOOP
if ( $entry eq $name );
}
#
# Didn't find 'dir' in directory svn listing of parent
# This parent is not a part of the same WorkSpace as 'dir'
# We have a winner.
#
chop $name; # Chop the '/' previously added
$self->{WS} = $parent . '/' . $name;
#
# Reform the WSURL. Elements have been removed as we tested up the
# path
#
$self->{WSURL} = join '/', @wsurl;
$found = 1;
last;
}
}
#
# Shouldn't get this far
#
Error ("SvnLocateWsRoot: Root not found")
unless ( $found );
#
# Refresh Info
# Must kill cached copy
#
delete $self->{'InfoWs'};
$self->SvnInfo($self->{WS}, 'InfoWs');
return $self->{WS};
}
#-------------------------------------------------------------------------------
# Function : SvnValidateWs
#
# Description : Validate the path to a working store
#
# Inputs : $self - Instance data
# $user - Optional prefix for error messages
# $test - True: Just test, Else Error
#
# Returns : Will not return if not a workspace
# Returns the users path
# Populates the hash: $self->{InfoWs}
#
sub SvnValidateWs
{
my ($self, $user, $test) = @_;
Debug ("SvnValidateWs");
$user = "Invalid Subversion Workspace" unless ( $user );
my $path = $self->{WS};
#
# Only validate it once
#
return $path if ( $self->{WS_VALIDATED} );
#
# Validate the source path
# Must exist and must be a directory
#
if ( ! $path ) {
@{$self->{ERROR_LIST}} = "$user: No path specified";
} elsif ( ! -e $path ) {
@{$self->{ERROR_LIST}} = "$user: Path does not exist: $path";
} elsif ( ! -d $path ) {
@{$self->{ERROR_LIST}} = "$user: Path is not a directory";
} else {
#
# Determine the source path is an fact a view
# The info command can do this. Use depth empty to limit the work done
#
$self->SvnInfo($path, 'InfoWs');
#
# Error. Prepend nice message
#
unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"
if ( @{$self->{ERROR_LIST}} );
}
#
# Figure out what to do
#
if ( $test )
{
return @{$self->{ERROR_LIST}};
}
else
{
Error @{$self->{ERROR_LIST}} if @{$self->{ERROR_LIST}};
$self->{WS_VALIDATED} = 1;
return $path;
}
}
#-------------------------------------------------------------------------------
# Function : SvnValidatePackageRoot
#
# Description : Validate a package root
#
# Inputs : $self - Instance data
#
# Returns : Will only return if valid
# Returns a cleaned package root
#
sub SvnValidatePackageRoot
{
my ($self, $warning_only) = @_;
Debug ("SvnValidatePackageRoot");
my $url = $self->Full || Error ("SvnValidatePackageRoot: No URL");
Error ("Package path contains a reserved word ($self->{TAGTYPE})", "Path: $url")
if ( $self->{TAGTYPE} );
Error ("Package name contains a Peg ($self->{PEG})", "Path: $url")
if ( $self->{PEG} );
#
# Ensure that the target path does exist
# Moreover it needs to be a directory and it should have a
# a ttb structure
#
my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Package Base Test', $url );
#
# Only looking for package path
#
if ( !$found && $warning_only )
{
return $url;
}
#
# Examine the results to see if we have a valid package base
#
Error ("Package Base Test: Not a valid package") unless ( $found );
#
# Extra bits found
# Its not the root of a package
#
if ( @$ref_files )
{
Warning ("Package Base Test: Files exists",
"Unexpected files found:", @$ref_files );
}
#
# Need a truck directory
# If we don't have a truck we don't have a package
#
my $trunk_found = grep ( /trunk\//, @$ref_svn );
Error ("Invalid Package Base. Does not contain a 'trunk' directory")
unless ( $trunk_found );
return $url;
}
#-------------------------------------------------------------------------------
# Function : SvnIsaSimpleLabel
#
# Description : Check a label
# Must not contain a PEG
# Must not contain invalid characters (@ or /)
# Must not contain a :: sequence (will confuse other tools)
# Handle special label of TIMESTAMP
# Create a .WIP so that it can be deleted
#
# Inputs : $label - to test
#
# Returns : Will not return on error
# Returns label on success
#
sub SvnIsaSimpleLabel
{
my ($label) = @_;
Debug ("SvnIsaSimpleLabel, $label");
Error ("No label provided") unless ( $label );
Error ("Invalid label. Peg (\@nnn) is not allowed: \"$label\"" ) if ( $label =~ m~@\d+$~ );
Error ("Invalid label. Package Path is not allowed: \"$label\"" ) if ( $label =~ m~/~ );
Error ("Invalid label. Invalid Start Character: \"$label\"" ) unless ( $label =~ m~^[0-9a-zA-Z]~ );
Error ("Invalid label. Invalid End Character: \"$label\"" ) unless ( $label =~ m~[0-9a-zA-Z]$~ );
Error ("Invalid label. Invalid Characters: \"$label\"" ) unless ( $label =~ m~^[-.:0-9a-zA-Z_]+$~ );
Error ("Invalid label. Double :: not allowed: \"$label\"" ) if ( $label =~m~::~ );
#
# Allow for a label of TIMESTAMP and have it expand
# Create a label based on users name and a date-time that can be sorted
#
if ( $label eq 'TIMESTAMP' )
{
::EnvImport ('USER' );
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
$label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u.WIP",
$::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );
}
return $label;
}
#-------------------------------------------------------------------------------
# Function : NewSession
#
# Description : Create a new empty SvnSession Class
#
# Inputs : None
#
# Returns : Class
#
sub NewSession
{
Debug ("NewSession");
my $self = SvnSession();
#
# Document Class Variables
#
$self->{URL} = ''; # Repo URL prefix
$self->{WS} = ''; # Users WorkSpace
$self->{PROTOCOL} = ''; # Named Access Protocol
$self->{PKGROOT} = ''; # Package root
#
# Create a class
# Bless my self
#
bless ($self, __PACKAGE__);
return $self;
}
#-------------------------------------------------------------------------------
# Function : NewSessionByWS
#
# Description : Establish a new SVN Session based on a Workspace
# Given a workspace path determine the SvnServer and other
# relevent information.
#
# Requires some rules
# * The package is rooted within a 'ttb'
#
# Inputs : $path - Path to WorkSpace
# $test - No Error on no WS
# $slack - Less stringent
#
# Returns : Ref to Session Information
#
sub NewSessionByWS
{
my ($path, $test, $slack) = @_;
Debug ("NewSessionByWS", @_);
#
# Create a basic Session
# Populate it with information that is known
#
my $self = NewSession();
$self->{WS} = $path;
#
# Validate the path provided
# In the process populate $self->{InfoWs} with info about the workspace.
#
if ($self->SvnValidateWs ( undef, 1) )
{
return $self if ( $test );
Error ( @{$self->{ERROR_LIST}} );
}
#
# Extract useful info
# URL: svn://auperaws996vm21/test/MixedView/trunk
# Repository Root: svn://auperaws996vm21/test
#
my $url = $self->{'InfoWs'}{'URL'};
my $reporoot = $self->{'InfoWs'}{'Repository Root'};
my $repoVersion = $self->{'InfoWs'}{'Revision'};
my $devBranch;
Error ("JatsSvn Internal error. Can't parse info")
unless ( $url && $reporoot );
#
# Need the length of the path to the repository
# but not the name of the repostory itself.
#
# Remove that from the head of the URL to give a
# path within the repository, that includes the repos name
#
$reporoot = (fileparse( $reporoot ))[1];
$url = substr ($url, length ($reporoot));
$self->{WSURL} = $url;
chop $reporoot;
Verbose2 ("SvnLocatePackageRoot: $reporoot, $url" );
#
# Remove anything after a ttb ( truck, tags, branch ) element
# This will be the root of the package within the repo
#
if ( $url =~ m~(.+)/((tags|branches|trunk)(/|$).*)~ )
{
$url = $1;
$self->{WSTYPE} = $3;
if ( $3 eq 'trunk' ) {
$devBranch = $3;
} elsif ( $3 eq 'branches' ) {
my @bits = split('/', $2);
$devBranch = join('/', @bits[0 .. 1]);
}
}
else
{
#
# If we are being slack (ie deleting the workspace)
# Then generate a warning, not an error
#
my $fnc = $slack ? \&Warning : \&Error;
$fnc->("SvnLocatePackageRoot. Non standard repository format",
"Url must contain 'tags' or 'branches' or 'trunk'",
"Url: $url");
$self->{WSTYPE} = 'trunk';
}
#
# Insert known information
#
$self->{URL} = $reporoot . '/';
$self->{PKGROOT} = $url;
$self->{WSREVNO} = $repoVersion;
$self->{DEVBRANCH} = $devBranch;
#
# Create useful information
#
SplitPackageUrl($self);
return $self;
}
#-------------------------------------------------------------------------------
# Function : NewSessionByUrl
#
# Description : Establish a new SVN Session based on a user URL
#
# Inputs : $uurl - Users URL
# $ttb_test - Test and warn for TTB structure
# $session - Optional: Existing session
#
# Returns : Ref to Session Information
#
sub NewSessionByUrl
{
my ($uurl, $ttb_test, $self ) = @_;
Debug ("NewSessionByUrl", @_);
Error ("No Repostory Path specified") unless ( $uurl );
#
# Create a basic Session
# Populate it with information that is known
#
$self = NewSession() unless ( $self );
#
# Examine the URL and convert a Repository Path into a URL
# as provided by configuration information within the environment
#
($self->{URL}, $self->{PKGROOT} ) = SvnPath2Url ($uurl);
#
# Create useful information
#
SplitPackageUrl($self);
#
# Warn of non-standard URLs
# These may create problems latter
#
if ( $ttb_test )
{
Warning("Non standard repository format",
"Url should contain 'tags' or 'branches' or 'trunk'",
"Url: $self->{PKGROOT}") unless $self->{TAGTYPE};
}
return $self;
}
#-------------------------------------------------------------------------------
# Function : SvnPath2Url
#
# Description : Convert a repository path to a Full Url
# Also handles Full Url
#
# Inputs : $rpath - Repository Path
# May be a full URL
#
# Returns : List context
# Two items that can be joined
# URL - URL
# PKG_ROOT - Package Root
#
# Scalar context: Joined URL and Package Root
# Fully formed URL
#
sub SvnPath2Url
{
my ($rpath) = @_;
my $processed = 0;
my $url;
my $pkgroot;
#
# Examine the argument and convert a Repository Path into a URL
# as provided by configuration information within the environment
#
$rpath =~ m~(.+?)/(.*)~;
my $fe = $1 || $rpath;
my $rest = $2 || '';
if ( $SVN_URLS{$fe} )
{
$url = $SVN_URLS{$fe};
$pkgroot = $rest;
$processed = 1;
}
if ( ! $processed )
{
#
# Examine the URL and determine if we have a FULL Url or
# a path within the 'default' server
#
foreach my $key ( @SVN_URLS_LIST )
{
if ( $rpath =~ m~^$SVN_URLS{$key}(.*)~ )
{
$url = $SVN_URLS{$key};
$pkgroot = $1;
$processed = 1;
last;
}
}
}
#
# Last attempt
# Treat as a raw URL - some operations won't be allowed
#
if ( ! $processed )
{
if ( $rpath =~ m~^((file|http|https|svn):///?([^/]+)/)(.+)~ )
{
# http://server/
# https://server/
# svn://server/
# file://This/Isa/Bad/Guess
#
$url = $1;
$pkgroot = $4;
}
elsif ($SVN_URLS{''} )
{
if ( exists $ENV{'GBE_ABT'} && $ENV{'GBE_ABT'})
{
Error ("Attempt to use default repository within automated build", "Path: " . $rpath);
}
$url = $SVN_URLS{''};
$pkgroot = $rpath;
}
else
{
#
# User default (site configured) Repo Root
#
Error ("No site repository configured for : $fe",
"Configure GBE_SVN_URL_" . uc($fe) );
}
}
#
# May want two elements, may want one
#
return $url, $pkgroot if ( wantarray );
return $url . $pkgroot;
}
#-------------------------------------------------------------------------------
# Function : SvnPaths
#
# Description : Extract SVN path conversion information
#
# Inputs : Nothing
#
# Returns : Two refs
# Hash of SVN URLS
# Array for search order
#
sub SvnPaths
{
return \%SVN_URLS, \@SVN_URLS_LIST;
}
#-------------------------------------------------------------------------------
# Function : SplitPackageUrl
#
# Description : Split the package URL into a few useful bits
#
# Inputs : $self - Instance data
#
# Returns : Nothing
#
sub SplitPackageUrl
{
my ($self) = @_;
Debug ("SplitPackageUrl", $self->{URL}, $self->{PKGROOT});
#
# Remove any protocol that may be present
# http://server/
# https://server/
# svn://server/
# file://This/Isa/Bad/Guess
#
if ( $self->{URL} =~ m~^(file|http|https|svn)://([^/]+)~ )
{
$self->{PROTOCOL} = $1;
$self->{SERVER} = $2;
}
if ( $self->{PKGROOT} =~ m~(.*)(@\d+)$~ )
{
$self->{PEG} = $2;
}
#
# Determine TTB type
# Need to handle
# .../trunk
# .../trunk@nnnnn
# .../tags/version@nnnnn
# .../branches/version@nnnnn
#
#
if ( $self->{PKGROOT} =~ m~/?(.*)/(tags|branches|trunk)(/|$|@)(.*)$~ )
{
$self->{PATH} = $1;
$self->{TAGTYPE} = $2;
$self->{VERSION} = $4;
}
else
{
$self->{PATH} = $self->{PKGROOT};
}
DebugDumpData ('SplitPackageUrl', $self ) if ( IsDebug(2) );
}
#-------------------------------------------------------------------------------
# Function : Full
# FullWs
# Repo
# Peg
# Type
# WsType
# Path
# Version
# RmRef
# RmPath
#
# Description : Accessor functions
#
# Inputs : $self - Instance data
# self (is $_[0])
#
# Returns : Data Item
#
sub Full { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }
sub FullWs { return $_[0]->{URL} . $_[0]->{WSURL} ; }
sub FullWsRev { return $_[0]->{URL} . $_[0]->{WSURL} . '@' . $_[0]->{WSREVNO} ; }
sub FullPath { return $_[0]->{URL} . $_[0]->{PATH} ; }
sub Peg { return $_[0]->{PEG} ; }
sub DevBranch { return $_[0]->{DEVBRANCH} || '' ; }
sub Type { return $_[0]->{TAGTYPE} || '' ; }
sub WsType { return $_[0]->{WSTYPE} || '' ; }
sub Path { return $_[0]->{PATH} ; }
sub Version { return $_[0]->{VERSION} ; }
sub RmRef { return $_[0]->{RMREF} ; }
sub RmPath { my $path = $_[0]->{RMREF}; $path =~ s~@.*?$~~ ;return $path; }
sub SvnTag { return $_[0]->{SVNTAG} || '' ; }
#-------------------------------------------------------------------------------
# Function : Print
#
# Description : Debug display the URL
#
# Inputs : $self - Instance data
# $header
# $indent
#
# Returns : Nothing
#
sub Print
{
my ($self, $header, $indent) = @_;
print "$header\n" if $header;
$indent = 4 unless ( defined $indent );
$indent = ' ' x $indent;
print $indent . "PROTOCOL :" . $self->{PROTOCOL} . "\n";
print $indent . "SERVER :" . $self->{SERVER} . "\n";
print $indent . "URL :" . $self->{URL} . "\n";
print $indent . "PKGROOT :" . $self->{PKGROOT} . "\n";
print $indent . "PATH :" . $self->{PATH} . "\n";
print $indent . "TAGTYPE :" . ($self->{TAGTYPE} || '') . "\n";
print $indent . "VERSION :" . ($self->{VERSION} || '') . "\n";
print $indent . "PEG :" . ($self->{PEG} || '') . "\n";
print $indent . "DEVBRANCH:" . ($self->{DEVBRANCH} || '') . "\n";
print $indent . "SVNTAG :" . ($self->{SVNTAG} || '') . "\n";
# print $indent . "FULL :" . $self->Full . "\n";
print $indent . "Full :" . $self->Full . "\n";
print $indent . "FullWs :" . $self->FullWs . "\n";
# print $indent . "FullWsRev :" . $self->FullWsRev . "\n";
print $indent . "FullPath :" . $self->FullPath . "\n";
print $indent . "Peg :" . $self->Peg . "\n";
print $indent . "DevBranch :" . $self->DevBranch . "\n";
print $indent . "Type :" . $self->Type . "\n";
print $indent . "WsType :" . $self->WsType . "\n";
print $indent . "Path :" . $self->Path . "\n";
print $indent . "Version :" . $self->Version . "\n";
print $indent . "RmRef :" . ($self->RmRef || '') . "\n";
# print $indent . "RmPath :" . ($self->RmPath|| '') . "\n";
}
#-------------------------------------------------------------------------------
# Function : BranchName
#
# Description : Create a full URL to a branch or tag based on the
# current entry
#
# URL must have a TTB format
#
# Inputs : $self - Instance data
# $branch - Name of the branch
# $type - Optional branch type
#
# Returns : Full URL name to the new branch
#
sub BranchName
{
my ($self, $branch, $type ) = @_;
Debug ( "BranchName", $branch );
$type = 'branches' unless ( $type );
my $root = $self->{PKGROOT};
$root =~ s~/(tags|branches|trunk)(/|$|@).*~~;
return $self->{URL} . $root . '/' . $type . '/' . $branch;
}
#-------------------------------------------------------------------------------
# Function : setRepoProperty
#
# Description : Sets a Repository property
# This may well fail unless the Repo is setup to allow such
# changes and the user is allowed to make such changes
#
# Inputs : $name
# $value
# $allowError - Support for bad repositories
#
# Returns : 0 - Change made
# Will not return on error
#
sub setRepoProperty
{
my ($self, $name, $value, $allowError ) = @_;
my $retval = 0;
my $rv;
Debug ( "setRepoProperty", $name, $value );
#
# Ensure that the Repo version is known
# This should be set by a previous operation
#
unless ( defined $self->{REVNO} )
{
Error ("setRepoProperty. Release Revision Number not known");
}
#
# Execute the command
# Appears tp fail random;y - so try a few times
#
#Debug ( "setRepoProperty", $name, $value, $self->{REVNO});
for (my $ii = 0; $ii < 3; $ii++ )
{
$rv = $self->SvnCmd ( 'propset' , $name, '--revprop', '-r', $self->{REVNO}, $value, $self->Full,
{
'credentials' => 1,
'nosavedata' => 1,
}
);
last unless ( $rv );
Warning("setRepoProperty: Failure attempt: $ii");
DebugDumpData('setRepoProperty Failure', $self );
sleep (1);
}
if ($rv)
{
#
# Property NOT set
#
if ( $allowError )
{
Warning ("setRepoProperty: $name - FAILED");
$retval = 1;
}
else
{
Error ("setRepoProperty: $name - FAILED");
}
}
return $retval;
}
#-------------------------------------------------------------------------------
# Function : backTrackSvnLabel
#
# Description : Examine a Svn Tag and backtrack until we find the branch
# that was used to create the label
#
# Inputs : $self - Instance Data
# $src_label - Label to process
# Label within the current instance
# A hash of named arguments
# data - Scalar ref. Hash of good stuff returned
# printdata - Print RAW svn data
# onlysimple - Do not do exhaustive scan
# savedevbranch - Save Dev Branch in session
# Used in label clone
#
# Returns : Branch from which the label was taken
# or the label prefixed with 'tags'.
#
sub backTrackSvnLabel
{
my $self = shift;
my $src_label = shift;
my %opt = @_;
my $branch;
Debug ("backTrackSvnLabel");
Error ("backTrackSvnLabel: Odd number of args") unless ((@_ % 2) == 0);
#
# May need to read and process data twice
# First - stop on copy. May it fast
# Second - all the log.
#
# extract data
#
foreach my $mode ( '--stop-on-copy', '' )
{
# Init stored data
# Used to communicate with callback function(s)
#
Information ("backTrackSvnLabel: Performing exhaustive search") unless $mode;
$self->{btData} = ();
$self->{btData}{results}{base} = $self->FullPath();
$self->{btData}{results}{label} = $src_label;
$self->{btData}{results}{changeSets} = 0;
$self->{btData}{results}{distance} = 0;
#
# Linux does not handle empty arguments in the same
# manner as windows. Solution: pass an array
#
my @mode;
push @mode, $mode if ( $mode);
my $spath = $self->FullPath() . '/' . $src_label;
Verbose2("backTrackSvnLabel. Log from $spath");
$self->SvnCmd ( 'log', '-v', '--xml', '-q'
, @mode
, $spath
, { 'credentials' => 1,
'process' => \&ProcessBackTrack,
'printdata' => $opt{printdata},
'nosavedata' => 1,
}
);
last if ( $self->{btData}{good} );
last if ( $opt{onlysimple} );
}
#
# Did not backtrack to a branch (or trunk)
# Return the users label
#
unless ( $self->{btData}{good} )
{
$branch = $src_label;
}
else
{
$branch = $self->{btData}{results}{devBranch};
if ( $opt{savedevbranch} )
{
$self->{btData}{results}{devBranch} =~ m~^(.*?)(@|$)~;
$self->{DEVBRANCH} = $1;
}
}
#
# Return data to the user
#
if ( my $refData = $opt{data} )
{
Error ('Internal: backTrackSvnLabel. Arg to "data" must be ref to a scalar')
unless ( ref($refData) eq 'SCALAR' );
$$refData = $self->{btData}{results};
}
#
# Clean up the data
#
delete $self->{btData};
return $branch;
}
#-------------------------------------------------------------------------------
# Function : ProcessBackTrack
#
# Description :
# Parse
#
# bivey
# 2005-07-25T15:45:35.000000Z
#
# /enqdef/tags/enqdef_24.0.1.sls
#
# COTS/enqdef: Tagged by Jats Svn Import
#
#
#
# Uses: $self->{btData} - Scratch Data
#
# Inputs : $self - Class Data
# $line - Input data to parse
#
# Returns : 0 - Do not terminate input command
#
sub ProcessBackTrack
{
my ($self, $line ) = @_;
Message ( $line ) if $self->{PRINTDATA};
$line =~ s~\s+$~~;
next unless ( $line );
# Debug0('', $line);
my $workSpace = \%{$self->{btData}};
if ( $line =~ m~{mode} = 'l';
$workSpace->{rev} = 0;
$workSpace->{changesSeen} = 0;
} elsif ( $line =~ m~$~ ) {
$workSpace->{mode} = '';
#
# End of a
# See if we have a result - a dev branch not copied from a tag
#
if ( exists $workSpace->{devBranch} )
{
$workSpace->{results}{distance}++;
$workSpace->{devBranch} =~ m~/((tags|branches|trunk)(/|\@).*)~;
my $devBranch = $1;
push @{$workSpace->{results}{paths}}, $devBranch;
unless ( $devBranch =~ m ~^tags~ )
{
$workSpace->{results}{devBranch} = $devBranch;
$workSpace->{results}{isaBranch} = 1;
$workSpace->{good} = 1;
return 1;
}
}
} elsif ( $line =~ m~{mode} = 'p';
Error ('Path without Rev') unless ( $workSpace->{rev} );
} elsif ( $line =~ m~$~ ) {
$workSpace->{mode} = '';
}
return 0 unless ( $workSpace->{mode} );
if ( $workSpace->{mode} eq 'l' )
{
#
# Processing logentry data
# Only need the revision
#
$workSpace->{rev} = $1
if ( $line =~ m~revision=\"(\d+)\"~ );
} elsif ( $workSpace->{mode} eq 'p' ) {
#
# Processing Paths
# Entries appear to be in a random order
# Not always the same order
#
my $end = 0;
if ( $line =~ s~\s*(.+?)="(.*)">(.*)$~~ )
{
#
# Last entry has two items
# Attribute
# Data Item
#
$end = 1;
$workSpace->{path}{$1} = $2;
$workSpace->{path}{DATA} = $3;
}
elsif ($line =~ m~\s*(.*?)="(.*)"~ )
{
#
# Attribute
#
$workSpace->{path}{$1} = $2;
}
# else
# {
# Warning ("Cannot decode XML log: $line");
# }
if ( $end )
{
#DebugDumpData("AtEnd",$workSpace->{path});
#
# If the Repo is created by a pre 1.6 SVN, then kind will be
# empty. Have a guess.
#
if ( $workSpace->{path}{'kind'} eq '' )
{
if ( exists $workSpace->{path}{'copyfrom-path'} ) {
$workSpace->{path}{'kind'} = 'dir';
} else {
$workSpace->{path}{'kind'} = 'file';
}
}
if ( $workSpace->{path}{'kind'} eq 'dir' && exists $workSpace->{path}{'copyfrom-path'} )
{
my $srev = $workSpace->{path}{'copyfrom-rev'};
my $from = $workSpace->{path}{'copyfrom-path'};
if ( $from =~ m~/trunk$~ || $from =~ m~/branches/[^/]+~ )
{
$workSpace->{devBranch} = $from . '@' . $srev;
}
}
elsif ( $workSpace->{path}{'kind'} eq 'file' )
{
#
# Track files that have been changed between tag and branch
# The log is presented as newest first
# The files have a tag-name component.
# Remove the tag name - so that we can compare files
# Save the first instance of changed files
# Others will be in older versions
# and thus of no interest
#
# Count the change sets that have changes
# Having changes in multiple change sets indicates
# development on a /tags/ - which is BAD
#
$workSpace->{path}{'DATA'} =~ m~(.+)/((tags|branches|trunk)(/|$).*)~;
my $file = $2;
my $full = $file;
$file =~ s~^tags/(.+?)/~~;
if ( ! exists $workSpace->{files}{$file} )
{
push @{$workSpace->{results}{files}}, join($;, $full . '@' . $workSpace->{rev}, $workSpace->{path}{'action'});
}
$workSpace->{files}{$file}++;
$workSpace->{firstFile} = $file unless ( defined $workSpace->{firstFile} );
unless ( $workSpace->{changesSeen} )
{
unless( $workSpace->{firstFile} eq $file )
{
$workSpace->{results}{changeSets}++;
$workSpace->{changesSeen}++;
}
}
if ( scalar keys %{$workSpace->{files}} > 1 )
{
$workSpace->{results}{multipleChanges} = 1;
Verbose ("backTrackSvnLabel: Changes in multiple versions");
}
}
delete $workSpace->{path};
}
}
#
# Return 0 to keep on going
return 0;
}
#-------------------------------------------------------------------------------
# Function :
#
# Description : Examine the current workspace and exact information about its
# parent.
#
# Does not extract the entire log history - just the last copyfrom
#
# Inputs : $self
#
# Returns : Nothing
# Will add {InfoWsExtra} to the session handle
#
sub getWsExtraInfo
{
my $self = shift;
#DebugDumpData("getWsExtraInfo", $self);
my $path;
if (exists $self->{InfoWs}{Path}) {
$path = $self->{InfoWs}{Path};
} else {
$path = $self->Full();
}
#
# Determine the source of the merge
# Create a hash entry to store working data
#
$self->{btData} = {};
$self->SvnCmd ( 'log', '-v', '--xml', '--stop-on-copy', '--limit', '1', '-r0:HEAD', $path
, { 'process' => \&ProcessWsExtraInfo,
'credentials' => 1
}
);
# Grab the first entry of the log array - should only be one
#
$self->{InfoWsExtra} = $self->{btData}{Data}[0];
delete $self->{btData};
}
#-------------------------------------------------------------------------------
# Function : ProcessWsExtraInfo
#
# Description :
# Parse
#
# bivey
# 2005-07-25T15:45:35.000000Z
#
# /enqdef/tags/enqdef_24.0.1.sls
#
# COTS/enqdef: Tagged by Jats Svn Import
#
#
# Inputs :
#
# Returns :
#
sub ProcessWsExtraInfo
{
my ($self, $line ) = @_;
my $data = $self->{btData};
$data->{Mode} = '' unless ( defined $data->{Mode} );
return unless ( $line );
#print "----- ($data->{Mode}) $line\n";
if ( $line =~ m~^{Item} = ();
$data->{Mode} = 'A';
} elsif ( ($line =~ s~\s*(.+?)="(.*)">(.*)$~~) && ($data->{Mode} eq 'A') ) {
#
# Last entry has two items
# Attribute
# Data Item
#
$data->{Item}->{$1} = $2;
$data->{Item}->{target} = $3;
} elsif ( ($line =~ m~\s*(.*?)="(.*)"~) && ($data->{Mode} eq 'A') ) {
#
# Attribute
#
$data->{Item}->{$1} = $2;
} elsif ( $line =~ m~{Mode} = '';
if ( exists $data->{Item}->{'copyfrom-path'} )
{
#DebugDumpData("Data", $data->{Item});
push @{$data->{Data}}, $data->{Item};
}
}
#
# Return 0 to keep on going
return 0;
}
#------------------------------------------------------------------------------
1;