Rev 7272 | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### 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 FileUtilsuse 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(NewSessionNewSessionByWSNewSessionByUrlSvnRmViewSvnIsaSimpleLabelSvnCommentSvnUserCmdSvnPath2UrlSvnPaths);@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.7Warning ("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() . '/' . $pathunless ( $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_LOOPif ( $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# <logentry# revision="24272"># <author>bivey</author># <date>2005-07-25T15:45:35.000000Z</date># <paths># <path# prop-mods="false"# text-mods="false"# kind="dir"# copyfrom-path="/enqdef/branches/Stockholm"# copyfrom-rev="24271"# action="A">/enqdef/tags/enqdef_24.0.1.sls</path># </path># <msg>COTS/enqdef: Tagged by Jats Svn Import</msg># </logentry>### 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~<logentry$~ ) {## Start of a logentry#$workSpace->{mode} = 'l';$workSpace->{rev} = 0;$workSpace->{changesSeen} = 0;} elsif ( $line =~ m~</logentry>$~ ) {$workSpace->{mode} = '';## End of a <logenty># 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~<path$~ ) {$workSpace->{mode} = 'p';Error ('Path without Rev') unless ( $workSpace->{rev} );} elsif ( $line =~ m~</paths>$~ ) {$workSpace->{mode} = '';}return 0 unless ( $workSpace->{mode} );if ( $workSpace->{mode} eq 'l' ){## Processing logentry data# Only need the revision#$workSpace->{rev} = $1if ( $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*(.+?)="(.*)">(.*)</path>$~~ ){## 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 goingreturn 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# <logentry# revision="24272"># <author>bivey</author># <date>2005-07-25T15:45:35.000000Z</date># <paths># <path# prop-mods="false"# text-mods="false"# kind="dir"# copyfrom-path="/enqdef/branches/Stockholm"# copyfrom-rev="24271"# action="A">/enqdef/tags/enqdef_24.0.1.sls</path># </paths># <msg>COTS/enqdef: Tagged by Jats Svn Import</msg># </logentry>## 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~^<logentry~ ) {$data->{Item} = ();$data->{Mode} = 'A';} elsif ( ($line =~ s~\s*(.+?)="(.*)">(.*)</path>$~~) && ($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~</logentry~ ) {$data->{Mode} = '';if ( exists $data->{Item}->{'copyfrom-path'} ){#DebugDumpData("Data", $data->{Item});push @{$data->{Data}}, $data->{Item};}}## Return 0 to keep on goingreturn 0;}#------------------------------------------------------------------------------1;