WebSVN – DevTools – Blame – /core_devl/branches/dpurdie_devl/TOOLS/LIB/JatsSvn.pm

Rev	Author	Line No.	Line
267	dpurdie	1	`########################################################################`
		2	`# Copyright (C) 2008 ERG Limited, All rights reserved`
		3	`#`
		4	`# Module name : jats.sh`
		5	`# Module type : Makefile system`
		6	`# Compiler(s) : n/a`
		7	`# Environment(s): jats`
		8	`#`
		9	`# Description : JATS Subversion Interface Functions`
		10	`#`
		11	`# Requires a subversion client to be present on the machine`
		12	`# Does require at least SubVersion 1.5`
		13	`# Uses features not available in 1.4`
		14	`#`
		15	`# The package currently implements a set of functions`
		16	`# There are some intentional limitations:`
		17	`# 1) Non recursive`
		18	`# 2) Errors terminate operation`
		19	`#`
		20	`# This package contains experimental argument passing`
		21	`# processes. Sometimes use a hash of arguments`
		22	`#`
		23	`#......................................................................#`
		24
		25	`require 5.008_002;`
		26	`use strict;`
		27	`use warnings;`
341	dpurdie	28	`our $USER;`
267	dpurdie	29	`use JatsEnv;`
		30
		31	`package JatsSvn;`
		32
		33	`use JatsError;`
		34	`use JatsSystem;`
		35	`use JatsSvnCore qw(:All);`
		36
		37	`use File::Path; # Instead of FileUtils`
		38	`use File::Basename;`
		39	`use Cwd;`
		40
		41
		42	`# automatically export what we need into namespace of caller.`
		43	`use Exporter();`
		44	`our (@ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK);`
		45	`@ISA = qw(Exporter JatsSvnCore);`
		46
		47	`@EXPORT = qw(`
		48	`NewSession`
		49	`NewSessionByWS`
		50	`NewSessionByUrl`
		51
		52	`SvnRmView`
		53	`SvnIsaSimpleLabel`
		54	`SvnComment`
		55
		56	`SvnUserCmd`
361	dpurdie	57
		58	`SvnPath2Url`
369	dpurdie	59	`SvnPaths`
267	dpurdie	60	`);`
		61	`@EXPORT_OK = qw(`
		62	`);`
		63
		64	`%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);`
		65
		66	`#`
		67	`# Global Variables`
		68	`#`
		69
		70	`#-------------------------------------------------------------------------------`
		71	`# Function : SvnCo`
		72	`#`
		73	`# Description : Create a workspace`
		74	`# Can be used to extract files, without creating the`
		75	`# subversion control files.`
		76	`#`
		77	`# Inputs : $self - Instance data`
		78	`# $RepoPath - Within the repository`
		79	`# $Path - Local path`
		80	`# Options - Options`
		81	`# --Export - Export Only`
1270	dpurdie	82	`# --NoPrint - Don't print files exported`
1343	dpurdie	83	`# --Force - Force export to overwrite`
267	dpurdie	84	`#`
		85	`# Returns : Nothing`
		86	`#`
		87	`sub SvnCo`
		88	`{`
		89	`my ($self, $RepoPath, $path, @opts) = @_;`
		90	`my $export = grep (/^--Export/, @opts );`
1343	dpurdie	91	`my $force = grep (/^--Force/, @opts );`
1270	dpurdie	92	`$self->{PRINTDATA} = ! grep (/^--NoPrint/, @opts );`
341	dpurdie	93	`Debug ("SvnCo", $RepoPath, $path);`
267	dpurdie	94
		95	`#`
		96	`# Ensure that the output path does not exist`
		97	`# Do not allow the user to create a local work space`
		98	`# where one already exists`
		99	`#`
		100	`Error ("SvnCo: No PATH specified" ) unless ( $path );`
1343	dpurdie	101	`Error ("SvnCo: Target path already exists", "Path: " . $path ) if ( ! $force && -e $path );`
267	dpurdie	102
		103	`#`
		104	`# Build up the command line`
		105	`#`
		106	`my @args = $export ? 'export' : 'checkout';`
		107	`push @args, qw( --ignore-externals );`
1343	dpurdie	108	`push @args, qw( --force ) if ( $force );`
267	dpurdie	109	`push @args, $RepoPath, $path;`
		110
		111	`my @co_list;`
		112	`if ( $self->SvnCmd ( @args,`
		113	`{`
		114	`'process' => \&ProcessCo,`
		115	`'data' => \@co_list,`
		116	`'credentials' => 1,`
		117	`'nosavedata' => 1,`
		118	`}`
		119	`) \|\| @co_list )`
		120	`{`
		121	`#`
		122	`# We have a checkout limitation`
		123	`# Delete the workspace and then report the error`
		124	`#`
385	dpurdie	125	`# Note: For some reason a simple rmtree doesn't work`
		126	`# Nor does glob show all the directories`
		127	`#`
267	dpurdie	128	`Verbose2 ("Remove WorkSpace: $path");`
		129	`rmtree( $path, IsVerbose(3) );`
385	dpurdie	130	`rmtree( $path, IsVerbose(3) );`
267	dpurdie	131	`Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );`
		132	`}`
1270	dpurdie	133	`$self->{PRINTDATA} = 0;`
267	dpurdie	134	`return;`
		135
		136	`#`
		137	`# Internal routine to scan each the checkout`
		138	`#`
		139	`# Due to the structure of a SubVersion repository it would be`
		140	`# possible for a user to extract the entire repository. This is`
		141	`# not good as the repo could be very very large`
		142	`#`
		143	`# Assume that the structure of the repo is such that our`
		144	`# user is not allowed to extract a directory tree that contains`
		145	`# key paths - such as /tags/ as this would indicate that they are`
		146	`# attempting to extract something that is not a package`
		147	`#`
		148	`#`
		149	`sub ProcessCo`
		150	`{`
		151	`my $self = shift;`
1270	dpurdie	152	`my $data = shift;`
		153
		154	`if ( $self->{PRINTDATA} )`
267	dpurdie	155	`{`
1270	dpurdie	156	`#`
		157	`# Pretty display for user`
		158	`#`
		159	`Information1 ("Extracting: $data");`
		160	`}`
		161
		162	`if ( $data =~ m~((/)(tags\|branches\|trunk)(/\|$))~ )`
		163	`{`
267	dpurdie	164	`my $bad_dir = $1;`
		165	`push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";`
		166	`return 1;`
		167	`}`
		168
		169	`##`
		170	`## Limit the size of the WorkSpace`
		171	`## This limit is a bit artificial, but does attempt to`
		172	`## limit views that encompass too much.`
		173	`##`
		174	`#if ( $#{$self->{RESULT_LIST}} > 100 )`
		175	`#{`
		176	`# Warning ("View is too large - DEBUG USE ONLY. WILL BE REMOVED" );`
		177	`# push @{$self->{ERROR_LIST}}, "View too large";`
		178	`# return 1;`
		179	`#}`
		180	`}`
		181	`}`
		182
		183	`#-------------------------------------------------------------------------------`
1343	dpurdie	184	`# Function : SvnSwitch`
		185	`#`
		186	`# Description : Switches files and directories`
		187	`#`
		188	`# Inputs : $self - Instance data`
		189	`# $RepoPath - Within the repository`
		190	`# $Path - Local path`
		191	`# Options - Options`
		192	`# --NoPrint - Don't print files exported`
		193	`#`
		194	`# Returns : Nothing`
		195	`#`
		196	`sub SvnSwitch`
		197	`{`
		198	`my ($self, $RepoPath, $path, @opts) = @_;`
		199	`$self->{PRINTDATA} = ! grep (/^--NoPrint/, @opts );`
		200	`Debug ("SvnSwitch", $RepoPath, $path);`
		201
		202	`#`
		203	`# Build up the command line`
		204	`#`
		205	`my @sw_list;`
		206	`if ( $self->SvnCmd ( 'switch', $RepoPath, $path,`
		207	`{`
		208	`'process' => \&ProcessSwitch,`
		209	`'data' => \@sw_list,`
		210	`'credentials' => 1,`
		211	`'nosavedata' => 1,`
		212	`}`
		213	`) \|\| @sw_list )`
		214	`{`
		215	`#`
		216	`# We have a switch problem`
		217	`# Delete the workspace and then report the error`
		218	`#`
		219	`# Note: For some reason a simple rmtree doesn't work`
		220	`# Nor does glob show all the directories`
		221	`#`
		222	`Verbose2 ("Remove WorkSpace: $path");`
		223	`rmtree( $path, IsVerbose(3) );`
		224	`rmtree( $path, IsVerbose(3) );`
		225	`Error ("Switch elements", @{$self->{ERROR_LIST}}, @sw_list );`
		226	`}`
		227	`$self->{PRINTDATA} = 0;`
		228	`return;`
		229
		230	`#`
		231	`# Internal routine to scan each line of the Switch output`
		232	`# Use to provide a nice display`
		233	`#`
		234	`sub ProcessSwitch`
		235	`{`
		236	`my $self = shift;`
		237	`my $data = shift;`
		238
		239	`if ( $self->{PRINTDATA} )`
		240	`{`
		241	`#`
		242	`# Pretty display for user`
		243	`#`
		244	`Information1 ("Switching : $data");`
		245	`}`
		246	`}`
		247	`}`
		248
		249	`#-------------------------------------------------------------------------------`
267	dpurdie	250	`# Function : SvnCi`
		251	`#`
		252	`# Description : Check in the specified WorkSpace`
		253	`#`
		254	`# Inputs : $self - Instance data`
		255	`# A hash of named arguments`
		256	`# comment - Commit comment`
379	dpurdie	257	`# allowSame - Allow no change to the workspace`
267	dpurdie	258	`#`
		259	`# Returns : Tag of the checkin`
		260	`#`
		261	`sub SvnCi`
		262	`{`
		263	`my $self = shift;`
		264	`my %opt = @_;`
		265	`my $status_url;`
379	dpurdie	266	`my $ws_rev;`
267	dpurdie	267
		268	`Debug ("SvnCi");`
		269	`Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);`
		270
		271	`#`
		272	`# Validate the source path`
1328	dpurdie	273	`# Note: populates %{$self->{InfoWs}} with 'info' data`
267	dpurdie	274	`#`
		275	`my $path = SvnValidateWs ($self, 'SvnCi');`
		276
		277	`#`
1328	dpurdie	278	`# Examine %{$self->{InfoWs}}, which has the results of an 'info'`
267	dpurdie	279	`# command the locate the URL.`
		280	`#`
		281	`# This contains the target view space`
		282	`# Sanity test. Don't allow Checkin to a /tags/ area`
		283	`#`
1328	dpurdie	284	`$status_url = $self->{InfoWs}{URL};`
		285	`$ws_rev = $self->{InfoWs}{Revision};`
379	dpurdie	286
267	dpurdie	287	`Error ("SvnCi: Cannot determine Repositoty URL")`
		288	`unless ( $status_url );`
		289
		290	`Error ("SvnCi: Not allowed to commit to a 'tags' area", "URL: $status_url")`
		291	`if ( $status_url =~ m~/tags(/\|$)~ );`
		292
		293	`#`
		294	`# Commit`
1328	dpurdie	295	`# Will modify Repo, so kill the cached Info`
		296	`# Will only be a real issue if we tag in the same session`
267	dpurdie	297	`#`
1328	dpurdie	298	`delete $self->{'InfoWs'};`
		299	`delete $self->{'InfoRepo'};`
		300
267	dpurdie	301	`$self->SvnCmd ( 'commit', $path`
		302	`, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),`
		303	`, { 'credentials' => 1,`
		304	`'process' => \&ProcessRevNo,`
379	dpurdie	305	`'error' => "SvnCi: Copy Error",`
		306	`}`
267	dpurdie	307	`);`
379	dpurdie	308
		309	`#`
		310	`# No error and no commit`
		311	`# Workspace was not changed, may be allowed`
		312	`#`
		313	`if ( ! $self->{REVNO} && $opt{allowSame} )`
		314	`{`
		315	`Warning ("SvnCi: Workspace matches Repository. No commit");`
		316	`$self->{REVNO} = $ws_rev;`
		317	`}`
		318
267	dpurdie	319	`Error ("SvnCi: Cannot determine Revision Number", @{$self->{RESULT_LIST}})`
		320	`unless ( $self->{REVNO} );`
		321
		322	`#`
		323	`# Update the view`
		324	`# Doing this so that the local view contains an up to date`
		325	`# revision number. If not done, and a 'copy' is done based`
		326	`# on this view then the branch information will indicate that`
		327	`# the copy is based on an incorrect version.`
		328	`# This can be confusing!`
		329	`#`
		330	`$self->SvnCmd ( 'update' , $path`
		331	`, '--ignore-externals'`
		332	`, { 'credentials' => 1,`
		333	`'error' => "SvnCi: Updating WorkSpace" }`
		334	`);`
		335	`#`
		336	`# Pass the updated revision number back to the user`
		337	`#`
		338	`$self->CalcRmReference($status_url);`
379	dpurdie	339	`Message ("Commit Tag is: " . $self->{RMREF} );`
267	dpurdie	340	`return $self->{RMREF} ;`
		341	`}`
		342
		343	`#-------------------------------------------------------------------------------`
		344	`# Function : SvnCreatePackage`
		345	`#`
		346	`# Description : Create a package and any associated files`
		347	`#`
		348	`# Inputs : $self - Instance data`
		349	`# A hash of named arguments`
		350	`# package - Name of the package`
		351	`# May include subdirs`
		352	`# new - True: Must not already exist`
		353	`# replace - True: Replace targets`
		354	`# import - DirTree to import`
		355	`# label - Tag for imported DirTree`
		356	`# type - Import TTB target`
		357	`#`
		358	`# Returns : Revision of the copy`
		359	`#`
		360	`sub SvnCreatePackage`
		361	`{`
		362	`my $self = shift;`
		363	`my %opt = @_;`
		364	`my $target;`
		365
		366	`Debug ("SvnCreatePackage", @_);`
		367	`Error ("Odd number of args to SvnCreatePackage") unless ((@_ % 2) == 0);`
		368	`my %dirs = ( 'trunk/' => 0,`
		369	`'tags/' => 0,`
		370	`'branches/' => 0 );`
		371
		372	`#`
		373	`# Sanity Tests`
		374	`#`
		375	`my $package = $self->Full \|\| Error ("SvnCreatePackage: No package name provided");`
		376	`Error ("SvnCreatePackage: Invalid import path") if ( $opt{'import'} && ! -d $opt{'import'} );`
		377	`Error ("SvnCreatePackage: Tag without Import") if ( $opt{'label'} && ! $opt{'import'} );`
		378	`$opt{'label'} = SvnIsaSimpleLabel( $opt{'label'} ) if ( $opt{'label'} );`
		379
		380	`#`
		381	`# Package path cannot contain any of the keyword paths tags,trunk,branches`
		382	`# as this would place a package with a package`
		383	`#`
		384	`Error ("Package path contains a reserved word ($1)", "Path: $package")`
		385	`if ( $package =~ m~/(tags\|branches\|trunk)(/\|$)~ );`
		386
		387	`#`
		388	`# Package path cannot be pegged, or look like one`
		389	`#`
		390	`Error ("Package name contains a Peg ($1)", "Path: $package")`
		391	`if ( $package =~ m~.*(@\d+)$~ );`
		392
		393	`#`
		394	`# Determine TTB target`
		395	`#`
		396	`$opt{'type'} = 'trunk' unless ( $opt{'type'} );`
		397	`Error ("Invalid TTB type") unless ( $opt{'type'} =~ m{^(tags\|branches\|trunk)$} );`
		398	`Error ("Import without label") if ( $opt{'type'} ne 'trunk' && ! $opt{'label'} );`
		399
		400	`#`
		401	`# Before we import data we must ensure that the targets do not exist`
		402	`# Determine the import target(s)`
		403	`#`
		404	`my $import_target;`
		405	`my $copy_target;`
		406
		407	`if ( $opt{'import'} )`
		408	`{`
		409	`#`
		410	`# Primary target`
		411	`# trunk, branck or tag`
		412	`#`
		413	`$import_target = $package . '/' . $opt{'type'};`
		414	`$import_target .= '/' .$opt{'label'} if ( $opt{'type'} ne 'trunk');`
		415
		416	`$self->SvnValidateTarget( 'target' => $import_target,`
		417	`'delete' => $opt{'replace'},`
		418	`'available' => 1 );`
		419
		420	`#`
		421	`# Secondary target`
		422	`# If primary is a trunk and a label is provided`
		423	`#`
		424	`if ( $opt{'type'} eq 'trunk' && $opt{'label'} )`
		425	`{`
		426	`$copy_target = $package . '/tags/' . $opt{'label'};`
		427	`$self->SvnValidateTarget( 'target' => $copy_target,`
		428	`'delete' => $opt{'replace'},`
		429	`'available' => 1 );`
		430	`}`
		431	`}`
		432
		433	`#`
		434	`# Probe to see if the package exists`
		435	`#`
		436	`my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'SvnCreatePackage', $package );`
379	dpurdie	437
267	dpurdie	438	`if ( @$ref_dirs )`
		439	`{`
		440	`Error ("SvnCreatePackage: Package directory exists",`
		441	`"Cannot create a package here. Unexpected subdirectories:", @$ref_dirs);`
		442	`}`
		443
		444	`if ( @$ref_files )`
		445	`{`
		446	`Warning ("SvnCreatePackage: Unexpected files found",`
		447	`"Path: $package",`
		448	`"Unexpected files found: @$ref_files");`
		449	`}`
		450
		451	`if ( @$ref_svn )`
		452	`{`
		453	`#`
		454	`# Do we need a new one`
		455	`#`
		456	`Error ("SvnCreatePackage: Package exists: $package") if $opt{'new'};`
		457
		458	`#`
		459	`# Some subversion files have been found here`
		460	`# Create the rest`
		461	`# Assume that the directory tree is good`
		462	`#`
		463	`#`
		464	`# Some, or all, of the required package subdirectories exist`
		465	`# Determine the new ones to created so that it can be done`
		466	`# in an atomic step`
		467	`#`
		468	`delete $dirs{$_} foreach ( @$ref_svn );`
		469	`if ( keys %dirs )`
		470	`{`
		471	`Warning ("SvnCreatePackage: Not all package subdirs present",`
		472	`"Remaining dirs will be created",`
		473	`"Found: @$ref_svn") if @$ref_svn;`
		474	`}`
		475	`else`
		476	`{`
		477	`Warning ("SvnCreatePackage: Package already present");`
		478	`}`
		479	`}`
		480
		481	`#`
		482	`# Create package directories that have not been discovered`
		483	`# trunk`
		484	`# branches`
		485	`# tags`
		486	`#`
		487	`my @dirs;`
		488	`push @dirs, $package . '/' . $_ foreach ( keys %dirs );`
		489	`$target = $package . '/trunk';`
		490
		491	`#`
		492	`# Create missing directories - if any`
		493	`#`
		494	`if ( @dirs )`
		495	`{`
		496	`$self->SvnCmd ('mkdir', @dirs`
379	dpurdie	497	`, '-m', $self->Path() . ': Created by SvnCreatePackage'`
267	dpurdie	498	`, '--parents'`
385	dpurdie	499	`, { 'credentials' => 1`
		500	`,'error' => "SvnCreatePackage"`
		501	`,'process' => \&ProcessRevNo`
		502	`} );`
267	dpurdie	503	`}`
		504
		505	`#`
		506	`# Import data into the package if required`
		507	`# Import data. Possible cases:`
		508	`# - Import to trunk - and then tag it`
		509	`# - Import to branches`
		510	`# - Import to tags`
		511	`#`
		512	`if ( $import_target )`
		513	`{`
		514	`Verbose ("Importing directory into new package: $opt{'import'}");`
		515
		516	`$target = $import_target;`
		517	`$self->{PRINTDATA} = 1;`
		518	`$self->SvnCmd ('import', $opt{'import'}`
		519	`, $target`
		520	`, '-m', 'Import by SvnCreatePackage'`
		521	`, '--force'`
		522	`, { 'credentials' => 1`
		523	`,'error' => "Import Incomplete"`
		524	`,'process' => \&ProcessRevNo`
		525	`})`
		526	`}`
		527
		528	`#`
		529	`# If imported to the trunk AND a label is provided`
		530	`# then tag the import as well.`
		531	`# A simple URL copy`
		532	`#`
		533	`if ( $copy_target )`
		534	`{`
		535	`Verbose ("Labeling imported trunk: $opt{'label'} ");`
		536	`$target = $copy_target;`
		537	`$self->SvnCmd ('copy' , $import_target`
		538	`, $target`
		539	`, '-m', 'Import tagged by SvnCreatePackage'`
		540	`, { 'credentials' => 1`
		541	`, 'process' => \&ProcessRevNo`
		542	`, 'error' => "Import Incomplete" } );`
		543	`}`
		544
		545	`#`
		546	`# Pass the updated revision number back to the user`
		547	`#`
		548	`$self->CalcRmReference($target);`
379	dpurdie	549	`Message ("Create Package Tag is: " . $self->{RMREF} );`
267	dpurdie	550	`return $self->{RMREF} ;`
		551	`}`
		552
		553	`#-------------------------------------------------------------------------------`
		554	`# Function : SvnRmView`
		555	`#`
		556	`# Description : Remove a Subversion view`
		557	`# Will run sanity checks and only remove the view if`
		558	`# all is well`
		559	`#`
		560	`# Inputs : A hash of named arguments`
		561	`# path - Path to local workspace`
		562	`# modified - Array of files that are allowed to be modified`
		563	`# force - True: Force deletion`
		564	`#`
		565	`# Returns :`
		566	`#`
		567	`sub SvnRmView`
		568	`{`
		569	`my %opt = @_;`
		570	`Debug ("SvnRmView");`
		571	`Error ("Odd number of args to SvnRmView") unless ((@_ % 2) == 0);`
		572
		573	`#`
		574	`# Sanity test`
		575	`#`
		576	`my $path = $opt{'path'} \|\| '';`
		577	`my $path_length = length ($path);`
		578	`Verbose2 ("Delete WorkSpace: $path");`
		579
		580	`#`
		581	`# If the path does not exist then assume that its already deleted`
		582	`#`
		583	`unless ( $path && -e $path )`
		584	`{`
		585	`Verbose2 ("SvnRmView: Path does not exist");`
		586	`return;`
		587	`}`
		588
		589	`#`
		590	`# Create information about the workspace`
		591	`# This will also validate the path`
		592	`#`
361	dpurdie	593	`my $session = NewSessionByWS ( $path, 0, 1 );`
267	dpurdie	594
		595	`#`
		596	`# Validate the path`
		597	`#`
		598	`$session->SvnValidateWs ($path, 'SvnRmView');`
		599
		600	`#`
		601	`# Ask subversion if there are any files to be updated`
		602	`# Prevent deletion of a view that has modified files`
		603	`#`
		604	`unless ( $opt{'force'} )`
		605	`{`
		606	`$session->SvnWsModified ( 'cmd' => 'SvnRmView', %opt );`
		607	`}`
		608
		609	`#`
		610	`# Now we can delete it`
		611	`#`
		612	`Verbose2 ("Remove WorkSpace: $path");`
		613	`rmtree( $path, IsVerbose(3) );`
		614	`}`
		615
		616
		617	`#-------------------------------------------------------------------------------`
		618	`# Function : SvnCopyWs`
		619	`#`
		620	`# Description : Copy a workspace to a new place in the repository`
		621	`# Effectively 'label' the workspace`
		622	`#`
		623	`# It would appear that the 'copy' command is very clever`
		624	`# If a version-controlled file has been changed`
		625	`# in the source workspace, then it will automatically be`
		626	`# copied. This is a trap.`
		627	`#`
		628	`# Only allow a 'copy' if there are no modified`
		629	`# files in the work space (unless overridden)`
		630	`#`
1328	dpurdie	631	`# Only allow a 'copy' if the local workspace is`
		632	`# up to date with respect with the repo. It possible`
		633	`# to do a 'commit' and then a 'copy' (tag) and have`
		634	`# unexpected results as the workspace has not been`
		635	`# updated. This is a trap.`
267	dpurdie	636	`#`
1328	dpurdie	637	`#`
267	dpurdie	638	`# Inputs : $self - Instance data`
		639	`# A hash of named arguments`
		640	`# path - Path to local workspace`
		641	`# target - Location within the repository to copy to`
		642	`# comment - Commit comment`
		643	`# modified - Array of files that are allowed to`
		644	`# be modified in the workspace.`
385	dpurdie	645	`# noswitch - True: Don't switch to the new URL`
		646	`# replace - True: Delete existing tag if present`
		647	`# allowLocalMods - True: Allow complex tagging`
1343	dpurdie	648	`# noupdatecheck - True: Do not check that the WS is up to date`
267	dpurdie	649	`#`
		650	`# Returns : Revision of the copy`
		651	`#`
		652	`sub SvnCopyWs`
		653	`{`
		654	`my $self = shift;`
		655	`my %opt = @_;`
385	dpurdie	656	`my $rv;`
267	dpurdie	657	`Debug ("SvnCopyWs");`
		658	`Error ("Odd number of args to SvnCopyWs") unless ((@_ % 2) == 0);`
		659	`Error ("SvnCopyWs: No Workspace" ) unless ( $self->{WS} );`
		660
		661	`#`
		662	`# Insert defaults`
		663	`#`
		664	`my $target = $opt{target} \|\| Error ("SvnCopyWs: Target not specified" );`
		665
		666	`#`
		667	`# Validate the source path`
		668	`#`
		669	`my $path = SvnValidateWs ($self, 'SvnCopyWs');`
		670
		671	`#`
		672	`# Validate the target`
		673	`# Cannot have a 'peg'`
		674	`#`
		675	`Error ("SvnCopyWs: Target contains a Peg: ($1)", $target)`
		676	`if ( $target =~ m~(@\d+)\s*$~ );`
		677
		678	`#`
1328	dpurdie	679	`# Ensure the Workspace is up to date`
		680	`# Determine the state of the Repo and the Workspace`
		681	`#`
1343	dpurdie	682	`unless ( $opt{noupdatecheck} )`
		683	`{`
		684	`$self->SvnInfo( $self->{WS} , 'InfoWs' );`
		685	`$self->SvnInfo( $self->FullWs, 'InfoRepo' );`
1328	dpurdie	686
1343	dpurdie	687	`my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} \|\| Error ("SvnCopyWs: Bad info for Workspace");`
		688	`my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} \|\| Error ("SvnCopyWs: Bad info for Repository");`
1328	dpurdie	689
1343	dpurdie	690	`Verbose("WS Rev : $wsLastChangedRev");`
		691	`Verbose("Repo Rev: $repoLastChangedRev");`
1328	dpurdie	692
1343	dpurdie	693	`Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',`
		694	`'Possibly caused by a commit without an update.',`
		695	`'Update the workspace and try again.',`
		696	`"Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );`
		697	`}`
1328	dpurdie	698
		699	`#`
267	dpurdie	700	`# Examine the workspace and ensure that there are no modified`
		701	`# files - unless they are expected`
		702	`#`
		703	`$self->SvnWsModified ( 'cmd' => 'SvnCopyWs', %opt );`
385	dpurdie	704
267	dpurdie	705	`#`
		706	`# Validate the repository`
		707	`# Ensure that the target does not exist`
		708	`# The target may be deleted if it exists and allowed by the user`
		709	`#`
		710	`$self->SvnValidateTarget ( 'cmd' => 'SvnCopyWs',`
		711	`'target' => $target,`
		712	`'delete' => $opt{replace},`
		713	`'comment' => 'Deleted by SvnCopyWs'`
		714	`);`
369	dpurdie	715
267	dpurdie	716	`#`
		717	`# Copy source to destination`
1328	dpurdie	718	`# Assuming the WorkSpace is up to date then, even though the source is a`
		719	`# WorkSpace, the copy does not transfer data from the WorkSpace.`
		720	`# It appears as though its all done on the server. This is good - and fast.`
267	dpurdie	721	`#`
1328	dpurdie	722	`# If the Workspace is not up to date, then files that SVN thinks have not`
		723	`# been transferred will be transferred - hence the need to update after`
		724	`# a commit.`
		725	`#`
385	dpurdie	726	`# Moreover, files that are modified in the local workspace will`
		727	`# be copied and checked into the target, but this is not nice.`
267	dpurdie	728	`#`
385	dpurdie	729	`$self->{PRINTDATA} = 1;`
		730	`$rv = $self->SvnCmd ( 'cp' , $path`
267	dpurdie	731	`, $target`
		732	`, '--parents'`
		733	`, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),`
		734	`, { 'process' => \&ProcessRevNo,`
		735	`'credentials' => 1, }`
385	dpurdie	736	`);`
		737	`$self->{PRINTDATA} = 0;`
		738	`if ($rv)`
267	dpurdie	739	`{`
		740	`#`
		741	`# Error in copy`
		742	`# Attempt to delete the target. Don't worry if we can't do that`
		743	`#`
		744	`my @err1 = @{$self->{ERROR_LIST}};`
		745	`$self->SvnCmd ( 'delete'`
		746	`, $target`
		747	`, '-m', 'Deleted by SvnCopyWs after creation failure'`
		748	`, { 'credentials' => 1, }`
		749	`);`
		750	`Error ("SvnCopyWs: Copy Error", @err1);`
		751	`}`
		752
		753	`Error ("SvnCopyWs: Cannot determine Revision Number", @{$self->{RESULT_LIST}})`
		754	`unless ( $self->{REVNO} );`
		755
		756	`Verbose2 ("Copy committed as revision: " . $self->{REVNO} );`
		757
		758	`unless ( $opt{'noswitch'} )`
		759	`{`
		760	`#`
		761	`# Switch to the new URL`
		762	`# This will link the Workspace with the copy that we have just made`
		763	`#`
		764	`$self->SvnCmd ( 'switch', $target`
		765	`, $path`
		766	`, { 'credentials' => 1,`
		767	`'error' => "SvnCopyWs: Cannot switch to new URL" }`
		768	`);`
		769	`}`
		770
		771	`#`
		772	`# Pass the updated revision number back to the user`
		773	`#`
		774	`$self->CalcRmReference($target );`
353	dpurdie	775	`#Message ("Tag is: " . $self->{RMREF} );`
267	dpurdie	776	`return $self->{RMREF} ;`
		777	`}`
		778
		779	`#-------------------------------------------------------------------------------`
		780	`# Function : SvnWsModified`
		781	`#`
		782	`# Description : Test a Workspace for modified files`
		783	`# Allow some files to be modified`
		784	`#`
		785	`# Inputs : $self - Instance data`
		786	`# A hash of named arguments`
		787	`# path - Path to local workspace`
		788	`# modified - Files that are allowed to be modified`
		789	`# Relative to the 'path'`
		790	`# May be a single file or an array of files`
385	dpurdie	791	`# allowLocalMods - Only warn about local mods`
267	dpurdie	792	`# cmd - Command name for error reporting`
		793	`#`
		794	`# Returns :`
		795	`#`
		796	`sub SvnWsModified`
		797	`{`
		798	`my $self = shift;`
		799	`my %opt = @_;`
		800	`Debug ("SvnWsModified");`
		801	`Error ("Odd number of args to SvnWsModified") unless ((@_ % 2) == 0);`
		802
		803	`my $cmd = $opt{'cmd'} \|\| 'SvnWsModified';`
		804
		805	`#`
		806	`# Validate the path`
		807	`#`
		808	`SvnValidateWs ($self, $cmd);`
		809	`my $path = $self->{WS};`
		810	`my $path_length = length ($path);`
		811	`Verbose2 ("Test Workspace for Modifications: $path");`
		812
		813	`#`
		814	`# Ask subversion if there are any files to be updated`
		815	`#`
		816	`$self->SvnCmd ('status', $path, {'error' => "Svn status command error"} );`
		817
		818	`#`
		819	`# Examine the list of modified files`
		820	`#`
		821	`if ( @{$self->{RESULT_LIST}} )`
		822	`{`
		823	`#`
351	dpurdie	824	`# Create a hash of files that are allowed to change`
267	dpurdie	825	`# These are files relative to the base of the view`
		826	`#`
		827	`# The svn command has the 'path' prepended, so this`
		828	`# will be removed as we process the commands`
		829	`#`
		830	`my %allowed;`
		831	`my @unexpected;`
		832
		833	`if ( exists $opt{'modified'} )`
		834	`{`
		835	`$allowed{'/' . $_} = 1 foreach ( ref ($opt{'modified'}) ? @{$opt{'modified'}} : $opt{'modified'} );`
		836	`}`
		837
		838	`#`
		839	`# Process the list of modified files`
		840	`# Do this even if we aren't allowed modified files as we`
		841	`# still need to examine the status and kill off junk entries`
		842	`# ie: ?, I, ! and ~`
		843	`#`
		844	`# First column: Says if item was added, deleted, or otherwise changed`
		845	`# ' ' no modifications`
		846	`# 'A' Added`
		847	`# 'C' Conflicted`
		848	`# 'D' Deleted`
		849	`# 'I' Ignored`
		850	`# 'M' Modified`
		851	`# 'R' Replaced`
		852	`# 'X' item is unversioned, but is used by an externals definition`
		853	`# '?' item is not under version control`
		854	`# '!' item is missing (removed by non-svn command) or incomplete`
		855	`# '~' versioned item obstructed by some item of a different kind`
		856	`#`
		857	`foreach my $entry ( @{$self->{RESULT_LIST}} )`
		858	`{`
		859	`#`
		860	`# Extract filename from line`
351	dpurdie	861	`# First 8 chars are status`
267	dpurdie	862	`# Remove WS path too`
		863	`#`
1328	dpurdie	864	`if ( length $entry >= 8 + $path_length)`
		865	`{`
		866	`my $file = substr ( $entry, 8 + $path_length );`
		867	`next if ( $allowed{$file} );`
		868	`}`
267	dpurdie	869
		870	`#`
		871	`# Examine the first char and rule out funny things`
		872	`#`
		873	`my $f1 = substr ($entry, 0,1 );`
		874	`next if ( $f1 =~ m{[?I!~]} );`
		875	`push @unexpected, $entry;`
		876	`}`
385	dpurdie	877
		878	`if ( @unexpected )`
		879	`{`
		880	`if ( $opt{allowLocalMods} ) {`
		881	`Message ("Workspace contains locally modified files:", @unexpected);`
		882	`} else {`
		883	`Error ("Workspace contains unexpected modified files", @unexpected);`
		884	`}`
		885	`}`
267	dpurdie	886	`}`
		887	`}`
		888
		889	`#-------------------------------------------------------------------------------`
		890	`# Function : SvnListPackages`
		891	`#`
		892	`# Description : Determine a list of packages within the repo`
		893	`# This turns out to be a very slow process`
		894	`# so don't use it unless you really really need to`
		895	`#`
1341	dpurdie	896	`# Inputs : $self - Instance data`
		897	`# $repo - Name of the repository`
		898	`# Last argument may be a hash of options.`
		899	`# Progress - True: Show progress`
		900	`# Show - >1 : display matched Tags and stats`
		901	`# >2 : display Packages`
		902	`# Tag - Enable Tag Matching`
		903	`# Value is the tag to match`
267	dpurdie	904	`#`
1341	dpurdie	905	`# Returns : Ref to an array of all packages`
		906	`# Ref to an array of all packahes with matched tag`
267	dpurdie	907	`#`
		908	`sub SvnListPackages`
		909	`{`
1341	dpurdie	910	`#`
		911	`# Extract arguments and options`
		912	`# If last argument is a hesh, then its a hash of options`
		913	`#`
		914	`my $opt;`
		915	`$opt = pop @_`
		916	`if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));`
267	dpurdie	917
1341	dpurdie	918	`my ($self, $repo) = @_;`
		919
		920	`my @path_list = '';`
267	dpurdie	921	`my @list;`
1341	dpurdie	922	`my @mlist;`
267	dpurdie	923	`my $scanned = 0;`
		924	`Debug ("SvnListPackages");`
		925	`while ( @path_list )`
		926	`{`
		927	`my $path = shift @path_list;`
1341	dpurdie	928	`if ( $opt->{Progress} )`
		929	`{`
		930	`Message ("Reading: " . ( $path \|\| 'RepoRoot') );`
		931	`}`
267	dpurdie	932	`$scanned++;`
1341	dpurdie	933	`my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Packages', join( '/', $repo, $path) );`
267	dpurdie	934
		935	`#`
		936	`# If there are Subversion dirs (ttb) in this directory`
		937	`# then this is a package. Add to list`
		938	`#`
		939	`push @list, $path if ( @$ref_svn );`
		940
		941	`#`
		942	`# Add subdirs to the list of paths to explore`
		943	`#`
		944	`foreach ( @$ref_dirs )`
		945	`{`
1341	dpurdie	946	`chop; # Remove trailing '/'`
		947	`push @path_list, $path ? join('/', $path , $_) : $_; # Extend the path`
267	dpurdie	948	`}`
		949	`}`
		950
1341	dpurdie	951	`if ( $opt->{Tag} )`
		952	`{`
		953	`my $tag = $opt->{Tag};`
		954	`foreach my $path ( sort @list )`
		955	`{`
		956	`Message ("Testing: $path") if ( $opt->{Progress} );`
		957	`if ( $self->SvnTestPath ( 'Listing Packages', join('/', $repo, $path, 'tags', $tag) ) )`
		958	`{`
		959	`push @mlist, $path;`
		960	`}`
		961	`}`
		962	`}`
		963
		964	`if ( $opt->{Show} )`
		965	`{`
		966	`Message ("Found Tags:", @mlist );`
		967	`Message ("Found Packages:", @list ) if $opt->{Show} > 2;`
		968	`Message ("Tags Found: " . scalar @mlist );`
		969	`Message ("Packages Found: " . scalar @list );`
		970	`Message ("Dirs Scanned: $scanned");`
		971	`}`
		972
		973	`return \@list, \@mlist;`
267	dpurdie	974	`}`
		975
		976	`#-------------------------------------------------------------------------------`
		977	`# Function : ListLabels`
		978	`#`
		979	`# Description : List labels within a given package`
		980	`#`
		981	`# Inputs : $self - Instance data`
		982	`# $path - path to label source`
		983	`#`
		984	`# Returns : Ref to an array`
		985	`#`
		986	`sub ListLabels`
		987	`{`
		988	`my ($self, $path) = @_;`
		989	`Debug ("ListLabels");`
		990
		991	`my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Versions', $path );`
		992
		993	`Error ("List: Path not found: $path") unless ( $found );`
		994
		995	`#`
		996	`# Dont report files - just directories`
		997	`#`
		998	`return $ref_dirs;`
		999	`}`
		1000
		1001
		1002	`#-------------------------------------------------------------------------------`
		1003	`# Function : SvnLocateWsRoot`
		1004	`#`
		1005	`# Description : Given a WorkSpace, determine the root of the work space`
		1006	`# This is not as simple as you might think`
		1007	`#`
		1008	`# Algorithm`
		1009	`# svn ls ..`
		1010	`# Am I in the parent directory`
		1011	`# Repeat`
		1012	`#`
369	dpurdie	1013	`# Updates 'WS' and 'WSURL'`
		1014	`#`
267	dpurdie	1015	`# Inputs : $self - Instance data`
		1016	`# $test - True: Don't die on error`
		1017	`#`
		1018	`# Returns : Root of workspace as an absolute address`
		1019	`# Will not return if there is an error`
		1020	`#`
		1021	`sub SvnLocateWsRoot`
		1022	`{`
		1023	`my ($self, $test) = @_;`
		1024	`my @path;`
		1025	`my $path = $self->{WS};`
		1026
		1027	`Debug ("SvnLocateWsRoot");`
		1028	`Error ("SvnLocateWsRoot: No Workspace") unless ( $path );`
		1029	`Verbose2 ("SvnLocateWsRoot: Start in $path");`
		1030
		1031	`#`
		1032	`# Validate the source path`
		1033	`#`
		1034	`if ( SvnValidateWs ($self, 'SvnLocateWsRoot', $test) )`
		1035	`{`
		1036	`return undef;`
		1037	`}`
		1038
		1039	`#`
		1040	`# Need to sanitize the users path to ensure that the following`
		1041	`# algorithm works. Need:`
		1042	`# 1) Absolute Path`
		1043	`# 2) Not ending in '/'`
		1044	`#`
		1045
		1046	`#`
		1047	`# If we have a relative path then prepend the current directory`
		1048	`# An absolute path is:`
		1049	`# /aaa/aa/aa`
		1050	`# or c:/aaa/aa/aa`
		1051	`#`
		1052	`$path = getcwd() . '/' . $path`
		1053	`unless ( $path =~ m~^/\|\w:/~ );`
		1054
		1055	`#`
		1056	`# Walk the bits and remove ".." directories`
		1057	`# Done by pushing non-.. elements and poping last entry for .. elements.`
		1058	`# Have a leading "/" which is good.`
		1059	`#`
		1060	`# Create a array of directories in the path`
		1061	`# Split on one or more \ or / separators`
		1062	`#`
		1063	`foreach ( split /[\\\/]+/ , $path )`
		1064	`{`
		1065	`next if ( $_ eq '.' );`
		1066	`unless ( $_ eq '..' )`
		1067	`{`
		1068	`push @path, $_;`
		1069	`}`
		1070	`else`
		1071	`{`
		1072	`Error ("SvnLocateWsRoot: Bad Pathname: $path")`
		1073	`if ( $#path <= 0 );`
		1074	`pop @path;`
		1075	`}`
		1076	`}`
		1077
369	dpurdie	1078	`#`
		1079	`# Need to adjust the WSURL too`
		1080	`# Break into parts and pop them off as we go`
		1081	`# Add a dummy one to allow for the first iteration`
		1082	`#`
		1083	`my @wsurl = (split (/[\\\/]+/ , $self->{WSURL}), 'Dummy');`
		1084
267	dpurdie	1085	`Verbose2 ("Clean absolute path elements: @path");`
		1086	`PATH_LOOP:`
		1087	`while ( @path )`
		1088	`{`
		1089	`#`
		1090	`# This directory element. Append / to assist in compare`
		1091	`# Determine parent path`
		1092	`#`
		1093	`my $name = pop (@path) . '/';`
		1094	`my $parent = join ('/', @path );`
369	dpurdie	1095	`pop @wsurl;`
267	dpurdie	1096
		1097	`#`
		1098	`# Examine the parent directory`
		1099	`# Get a list of all elements in the parent`
		1100	`# Need to ensure that this directory is one of them`
		1101	`#`
		1102	`# Ignore any errors - assume that they are because the`
		1103	`# parent is not a part of the work space. This will terminate the`
		1104	`# search.`
		1105	`#`
		1106	`$self->SvnCmd ('list', $parent, '--depth', 'immediates' );`
		1107	`foreach my $entry ( @{$self->{RESULT_LIST}} )`
		1108	`{`
		1109	`next PATH_LOOP`
		1110	`if ( $entry eq $name );`
		1111	`}`
		1112
		1113	`#`
		1114	`# Didn't find 'dir' in directory svn listing of parent`
		1115	`# This parent is not a part of the same WorkSpace as 'dir'`
		1116	`# We have a winner.`
		1117	`#`
		1118	`chop $name; # Chop the '/' previously added`
		1119	`$self->{WS} = $parent . '/' . $name;`
369	dpurdie	1120
		1121	`#`
		1122	`# Reform the WSURL. Elements have been removed as we tested up the`
		1123	`# path`
		1124	`#`
		1125	`$self->{WSURL} = join '/', @wsurl;`
		1126
267	dpurdie	1127	`return $self->{WS};`
		1128	`}`
		1129
		1130	`#`
		1131	`# Shouldn't get this far`
		1132	`#`
		1133	`Error ("SvnLocateWsRoot: Root not found");`
		1134	`}`
		1135
		1136	`#-------------------------------------------------------------------------------`
		1137	`# Function : SvnValidateWs`
		1138	`#`
		1139	`# Description : Validate the path to a working store`
		1140	`#`
		1141	`# Inputs : $self - Instance data`
		1142	`# $user - Optional prefix for error messages`
		1143	`# $test - True: Just test, Else Error`
		1144	`#`
		1145	`# Returns : Will not return if not a workspace`
		1146	`# Returns the users path`
1328	dpurdie	1147	`# Populates the hash: $self->{InfoWs}`
267	dpurdie	1148	`#`
		1149	`sub SvnValidateWs`
		1150	`{`
		1151	`my ($self, $user, $test) = @_;`
		1152	`Debug ("SvnValidateWs");`
		1153
		1154	`$user = "Invalid Subversion Workspace" unless ( $user );`
1328	dpurdie	1155	`my $path = $self->{WS};`
267	dpurdie	1156
		1157	`#`
1328	dpurdie	1158	`# Only validate it once`
267	dpurdie	1159	`#`
		1160	`return $path if ( $self->{WS_VALIDATED} );`
		1161
		1162	`#`
		1163	`# Validate the source path`
		1164	`# Must exist and must be a directory`
		1165	`#`
		1166	`if ( ! $path ) {`
		1167	`@{$self->{ERROR_LIST}} = "$user: No path specified";`
		1168
		1169	`} elsif ( ! -e $path ) {`
		1170	`@{$self->{ERROR_LIST}} = "$user: Path does not exist: $path";`
		1171
		1172	`} elsif ( ! -d $path ) {`
		1173	`@{$self->{ERROR_LIST}} = "$user: Path is not a directory";`
		1174	`} else {`
		1175	`#`
		1176	`# Determine the source path is an fact a view`
		1177	`# The info command can do this. Use depth empty to limit the work done`
		1178	`#`
1328	dpurdie	1179	`$self->SvnInfo($path, 'InfoWs');`
267	dpurdie	1180
		1181	`#`
		1182	`# Error. Prepend nice message`
		1183	`#`
		1184	`unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"`
		1185	`if ( @{$self->{ERROR_LIST}} );`
		1186	`}`
		1187
		1188	`#`
		1189	`# Figure out what to do`
		1190	`#`
		1191	`if ( $test )`
		1192	`{`
		1193	`return @{$self->{ERROR_LIST}};`
		1194	`}`
		1195	`else`
		1196	`{`
		1197	`Error @{$self->{ERROR_LIST}} if @{$self->{ERROR_LIST}};`
		1198	`$self->{WS_VALIDATED} = 1;`
		1199	`return $path;`
		1200	`}`
		1201	`}`
		1202
		1203	`#-------------------------------------------------------------------------------`
		1204	`# Function : SvnValidatePackageRoot`
		1205	`#`
		1206	`# Description : Validate a package root`
		1207	`#`
		1208	`# Inputs : $self - Instance data`
		1209	`#`
		1210	`# Returns : Will only return if valid`
		1211	`# Returns a cleaned package root`
		1212	`#`
		1213	`sub SvnValidatePackageRoot`
		1214	`{`
379	dpurdie	1215	`my ($self, $warning_only) = @_;`
267	dpurdie	1216	`Debug ("SvnValidatePackageRoot");`
		1217	`my $url = $self->Full \|\| Error ("SvnValidatePackageRoot: No URL");`
		1218
		1219	`Error ("Package path contains a reserved word ($self->{TAGTYPE})", "Path: $url")`
		1220	`if ( $self->{TAGTYPE} );`
		1221
		1222	`Error ("Package name contains a Peg ($self->{PEG})", "Path: $url")`
		1223	`if ( $self->{PEG} );`
		1224
		1225	`#`
		1226	`# Ensure that the target path does exist`
		1227	`# Moreover it needs to be a directory and it should have a`
		1228	`# a ttb structure`
		1229	`#`
		1230	`my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Package Base Test', $url );`
		1231
		1232	`#`
379	dpurdie	1233	`# Only looking for package path`
		1234	`#`
		1235	`if ( !$found && $warning_only )`
		1236	`{`
		1237	`return $url;`
		1238	`}`
		1239
		1240	`#`
267	dpurdie	1241	`# Examine the results to see if we have a valid package base`
		1242	`#`
		1243	`Error ("Package Base Test: Not a valid package") unless ( $found );`
		1244
		1245	`#`
		1246	`# Extra bits found`
		1247	`# Its not the root of a package`
		1248	`#`
		1249	`if ( @$ref_files )`
		1250	`{`
		1251	`Warning ("Package Base Test: Files exists",`
		1252	`"Unexpected files found:", @$ref_files );`
		1253	`}`
		1254
		1255	`#`
		1256	`# Need a truck directory`
		1257	`# If we don't have a truck we don't have a package`
		1258	`#`
		1259	`my $trunk_found = grep ( /trunk\//, @$ref_svn );`
		1260	`Error ("Invalid Package Base. Does not contain a 'trunk' directory")`
		1261	`unless ( $trunk_found );`
		1262
		1263	`return $url;`
		1264	`}`
		1265
		1266
		1267	`#-------------------------------------------------------------------------------`
		1268	`# Function : SvnIsaSimpleLabel`
		1269	`#`
		1270	`# Description : Check a label`
		1271	`# Must not contain a PEG`
		1272	`# Must not contain invalid characters (@ or /)`
		1273	`# Must not contain a :: sequence (will confuse other tools)`
		1274	`# Handle special label of TIMESTAMP`
		1275	`#`
		1276	`# Inputs : $label - to test`
		1277	`#`
		1278	`# Returns : Will not return on error`
		1279	`# Returns label on success`
		1280	`#`
		1281	`sub SvnIsaSimpleLabel`
		1282	`{`
		1283	`my ($label) = @_;`
		1284	`Debug ("SvnIsaSimpleLabel, $label");`
		1285
		1286	`Error ("No label provided") unless ( $label );`
		1287	`Error ("Invalid label. Peg (\@nnn) is not allowed: \"$label\"" ) if ( $label =~ m~@\d+$~ );`
		1288	`Error ("Invalid label. Package Path is not allowed: \"$label\"" ) if ( $label =~ m~/~ );`
383	dpurdie	1289	`Error ("Invalid label. Invalid Start Character: \"$label\"" ) unless ( $label =~ m~^[0-9a-zA-Z]~ );`
		1290	`Error ("Invalid label. Invalid End Character: \"$label\"" ) unless ( $label =~ m~[0-9a-zA-Z]$~ );`
267	dpurdie	1291	`Error ("Invalid label. Invalid Characters: \"$label\"" ) unless ( $label =~ m~^[-.:0-9a-zA-Z_]+$~ );`
		1292	`Error ("Invalid label. Double :: not allowed: \"$label\"" ) if ( $label =~m~::~ );`
		1293
		1294	`#`
		1295	`# Allow for a label of TIMESTAMP and have it expand`
383	dpurdie	1296	`# Create a label based on users name and a date-time that can be sorted`
267	dpurdie	1297	`#`
		1298	`if ( $label eq 'TIMESTAMP' )`
		1299	`{`
341	dpurdie	1300	`::EnvImport ('USER' );`
		1301	`my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);`
		1302	`$label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u",`
		1303	`$::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );`
267	dpurdie	1304	`}`
		1305	`return $label;`
		1306	`}`
		1307
		1308	`#-------------------------------------------------------------------------------`
		1309	`# Function : NewSession`
		1310	`#`
		1311	`# Description : Create a new empty SvnSession Class`
		1312	`#`
		1313	`# Inputs : None`
		1314	`#`
		1315	`# Returns : Class`
		1316	`#`
		1317	`sub NewSession`
		1318	`{`
		1319	`Debug ("NewSession");`
		1320	`my $self = SvnSession();`
		1321
		1322	`#`
		1323	`# Document Class Variables`
		1324	`#`
		1325	`$self->{URL} = ''; # Repo URL prefix`
		1326	`$self->{WS} = ''; # Users WorkSpace`
		1327	`$self->{PROTOCOL} = ''; # Named Access Protocol`
		1328	`$self->{PKGROOT} = ''; # Package root`
		1329
		1330	`#`
		1331	`# Create a class`
		1332	`# Bless my self`
		1333	`#`
		1334	`bless ($self, __PACKAGE__);`
		1335	`return $self;`
		1336	`}`
		1337
		1338	`#-------------------------------------------------------------------------------`
		1339	`# Function : NewSessionByWS`
		1340	`#`
		1341	`# Description : Establish a new SVN Session based on a Workspace`
		1342	`# Given a workspace path determine the SvnServer and other`
		1343	`# relevent information.`
		1344	`#`
		1345	`# Requires some rules`
		1346	`# * The package is rooted within a 'ttb'`
		1347	`#`
		1348	`# Inputs : $path - Path to WorkSpace`
		1349	`# $test - No Error on no WS`
361	dpurdie	1350	`# $slack - Less stringent`
267	dpurdie	1351	`#`
		1352	`# Returns : Ref to Session Information`
		1353	`#`
		1354	`sub NewSessionByWS`
		1355	`{`
361	dpurdie	1356	`my ($path, $test, $slack) = @_;`
267	dpurdie	1357	`Debug ("NewSessionByWS", @_);`
		1358
		1359	`#`
		1360	`# Create a basic Session`
		1361	`# Populate it with information that is known`
		1362	`#`
		1363	`my $self = NewSession();`
		1364	`$self->{WS} = $path;`
		1365
		1366	`#`
		1367	`# Validate the path provided`
1328	dpurdie	1368	`# In the process populate $self->{InfoWs} with info about the workspace.`
267	dpurdie	1369	`#`
		1370	`if ($self->SvnValidateWs ( undef, 1) )`
		1371	`{`
		1372	`return $self if ( $test );`
		1373	`Error ( @{$self->{ERROR_LIST}} );`
		1374	`}`
		1375
		1376	`#`
		1377	`# Extract useful info`
		1378	`# URL: svn://auperaws996vm21/test/MixedView/trunk`
		1379	`# Repository Root: svn://auperaws996vm21/test`
		1380	`#`
1328	dpurdie	1381	`my $url = $self->{'InfoWs'}{'URL'};`
		1382	`my $reporoot = $self->{'InfoWs'}{'Repository Root'};`
		1383	`my $repoVersion = $self->{'InfoWs'}{'Revision'};`
267	dpurdie	1384
		1385	`Error ("JatsSvn Internal error. Can't parse info")`
		1386	`unless ( $url && $reporoot );`
		1387
		1388	`#`
		1389	`# Need the length of the path to the repository`
		1390	`# but not the name of the repostory itself.`
		1391	`#`
		1392	`# Remove that from the head of the URL to give a`
		1393	`# path within the repository, that includes the repos name`
		1394	`#`
		1395	`$reporoot = (fileparse( $reporoot ))[1];`
		1396	`$url = substr ($url, length ($reporoot));`
		1397	`$self->{WSURL} = $url;`
		1398	`chop $reporoot;`
		1399
		1400	`Verbose2 ("SvnLocatePackageRoot: $reporoot, $url" );`
		1401
		1402	`#`
		1403	`# Remove anything after a ttb ( truck, tags, branch ) element`
		1404	`# This will be the root of the package within the repo`
		1405	`#`
		1406	`if ( $url =~ m~(.+)/((tags\|branches\|trunk)(/\|$).*)~ )`
		1407	`{`
		1408	`$url = $1;`
		1409	`$self->{WSTYPE} = $3;`
		1410	`}`
		1411	`else`
		1412	`{`
361	dpurdie	1413	`#`
		1414	`# If we are being slack (ie deleting the workspace)`
		1415	`# Then generate a warning, not an error`
		1416	`#`
		1417	`my $fnc = $slack ? \&Warning : \&Error;`
		1418	`$fnc->("SvnLocatePackageRoot. Non standard repository format",`
		1419	`"Url must contain 'tags' or 'branches' or 'trunk'",`
267	dpurdie	1420	`"Url: $url");`
361	dpurdie	1421	`$self->{WSTYPE} = 'trunk';`
267	dpurdie	1422	`}`
		1423
		1424	`#`
		1425	`# Insert known information`
		1426	`#`
		1427	`$self->{URL} = $reporoot . '/';`
		1428	`$self->{PKGROOT} = $url;`
369	dpurdie	1429	`$self->{WSREVNO} = $repoVersion;`
267	dpurdie	1430
		1431	`#`
		1432	`# Create useful information`
		1433	`#`
		1434	`SplitPackageUrl($self);`
		1435	`return $self;`
		1436	`}`
		1437
		1438	`#-------------------------------------------------------------------------------`
		1439	`# Function : NewSessionByUrl`
		1440	`#`
		1441	`# Description : Establish a new SVN Session based on a user URL`
		1442	`#`
		1443	`# Inputs : $uurl - Users URL`
361	dpurdie	1444	`# $ttb_test - Test and warn for TTB structure`
267	dpurdie	1445	`# $session - Optional: Existing session`
		1446	`#`
		1447	`# Returns : Ref to Session Information`
		1448	`#`
		1449	`sub NewSessionByUrl`
		1450	`{`
361	dpurdie	1451	`my ($uurl, $ttb_test, $self ) = @_;`
267	dpurdie	1452	`Debug ("NewSessionByUrl", @_);`
		1453	`Error ("No Repostory Path specified") unless ( $uurl );`
		1454
		1455	`#`
		1456	`# Create a basic Session`
		1457	`# Populate it with information that is known`
		1458	`#`
		1459	`$self = NewSession() unless ( $self );`
		1460
		1461	`#`
369	dpurdie	1462	`# Examine the URL and convert a Repository Path into a URL`
353	dpurdie	1463	`# as provided by configuration information within the environment`
267	dpurdie	1464	`#`
361	dpurdie	1465	`($self->{URL}, $self->{PKGROOT} ) = SvnPath2Url ($uurl);`
		1466
		1467	`#`
		1468	`# Create useful information`
		1469	`#`
		1470	`SplitPackageUrl($self);`
		1471
		1472	`#`
		1473	`# Warn of non-standard URLs`
		1474	`# These may create problems latter`
		1475	`#`
		1476	`if ( $ttb_test )`
		1477	`{`
		1478	`Warning("Non standard repository format",`
		1479	`"Url should contain 'tags' or 'branches' or 'trunk'",`
		1480	`"Url: $self->{PKGROOT}") unless $self->{TAGTYPE};`
		1481	`}`
		1482
		1483	`return $self;`
		1484	`}`
		1485
		1486	`#-------------------------------------------------------------------------------`
		1487	`# Function : SvnPath2Url`
		1488	`#`
		1489	`# Description : Convert a repository path to a Full Url`
		1490	`# Also handles Full Url`
		1491	`#`
		1492	`# Inputs : $rpath - Repository Path`
		1493	`# May be a full URL`
		1494	`#`
		1495	`# Returns : List context`
		1496	`# Two items that can be joined`
		1497	`# URL - URL`
		1498	`# PKG_ROOT - Package Root`
		1499	`#`
		1500	`# Scalar context: Joined URL and Package Root`
		1501	`# Fully formed URL`
		1502	`#`
		1503	`sub SvnPath2Url`
		1504	`{`
		1505	`my ($rpath) = @_;`
		1506	`my $processed = 0;`
		1507	`my $url;`
		1508	`my $pkgroot;`
		1509
		1510	`#`
		1511	`# Examine the argument and convert a Repository Path into a URL`
		1512	`# as provided by configuration information within the environment`
		1513	`#`
		1514	`$rpath =~ m~(.+?)/(.*)~;`
		1515	`my $fe = $1 \|\| $rpath;`
353	dpurdie	1516	`my $rest = $2 \|\| '';`
		1517	`if ( $SVN_URLS{$fe} )`
267	dpurdie	1518	`{`
361	dpurdie	1519	`$url = $SVN_URLS{$fe};`
		1520	`$pkgroot = $rest;`
353	dpurdie	1521	`$processed = 1;`
341	dpurdie	1522	`}`
		1523
353	dpurdie	1524	`if ( ! $processed )`
341	dpurdie	1525	`{`
267	dpurdie	1526	`#`
353	dpurdie	1527	`# Examine the URL and determine if we have a FULL Url or`
		1528	`# a path within the 'default' server`
		1529	`#`
		1530	`foreach my $key ( @SVN_URLS_LIST )`
		1531	`{`
361	dpurdie	1532	`if ( $rpath =~ m~^$SVN_URLS{$key}(.*)~ )`
353	dpurdie	1533	`{`
361	dpurdie	1534	`$url = $SVN_URLS{$key};`
		1535	`$pkgroot = $1;`
353	dpurdie	1536	`$processed = 1;`
		1537	`last;`
		1538	`}`
		1539	`}`
		1540	`}`
267	dpurdie	1541
353	dpurdie	1542	`#`
		1543	`# Last attempt`
		1544	`# Treat as a raw URL - some operations won't be allowed`
		1545	`#`
		1546	`if ( ! $processed )`
267	dpurdie	1547	`{`
361	dpurdie	1548	`if ( $rpath =~ m~^((file\|http\|https\|svn):///?([^/]+)/)(.+)~ )`
353	dpurdie	1549	`{`
		1550	`# http://server/`
		1551	`# https://server/`
		1552	`# svn://server/`
		1553	`# file://This/Isa/Bad/Guess`
		1554	`#`
361	dpurdie	1555	`$url = $1;`
		1556	`$pkgroot = $4;`
353	dpurdie	1557	`}`
369	dpurdie	1558	`elsif ($SVN_URLS{''} )`
353	dpurdie	1559	`{`
1270	dpurdie	1560	`if ( exists $ENV{'GBE_ABT'} && $ENV{'GBE_ABT'})`
		1561	`{`
		1562	`Error ("Attempt to use default repository within automated build", "Path: " . $rpath);`
		1563	`}`
361	dpurdie	1564	`$url = $SVN_URLS{''};`
		1565	`$pkgroot = $rpath;`
353	dpurdie	1566	`}`
		1567	`else`
		1568	`{`
		1569	`#`
		1570	`# User default (site configured) Repo Root`
		1571	`#`
		1572	`Error ("No site repository configured for : $fe",`
		1573	`"Configure GBE_SVN_URL_" . uc($fe) );`
		1574	`}`
267	dpurdie	1575	`}`
		1576
		1577	`#`
361	dpurdie	1578	`# May want two elements, may want one`
267	dpurdie	1579	`#`
361	dpurdie	1580	`return $url, $pkgroot if ( wantarray );`
		1581	`return $url . $pkgroot;`
267	dpurdie	1582	`}`
		1583
369	dpurdie	1584	`#-------------------------------------------------------------------------------`
		1585	`# Function : SvnPaths`
		1586	`#`
		1587	`# Description : Extract SVN path conversion information`
		1588	`#`
		1589	`# Inputs : Nothing`
		1590	`#`
		1591	`# Returns : Two refs`
		1592	`# Hash of SVN URLS`
		1593	`# Array for search order`
		1594	`#`
		1595	`sub SvnPaths`
		1596	`{`
		1597	`return \%SVN_URLS, \@SVN_URLS_LIST;`
		1598	`}`
361	dpurdie	1599
267	dpurdie	1600	`#-------------------------------------------------------------------------------`
		1601	`# Function : SplitPackageUrl`
		1602	`#`
		1603	`# Description : Slip the package URL into a few useful bits`
		1604	`#`
		1605	`# Inputs : $self - Instance data`
		1606	`#`
		1607	`# Returns : Nothing`
		1608	`#`
		1609	`sub SplitPackageUrl`
		1610	`{`
		1611	`my ($self) = @_;`
353	dpurdie	1612	`Debug ("SplitPackageUrl", $self->{URL}, $self->{PKGROOT});`
267	dpurdie	1613
		1614	`#`
		1615	`# Remove any protocol that may be present`
		1616	`# http://server/`
341	dpurdie	1617	`# https://server/`
267	dpurdie	1618	`# svn://server/`
		1619	`# file://This/Isa/Bad/Guess`
		1620	`#`
341	dpurdie	1621	`if ( $self->{URL} =~ m~^(file\|http\|https\|svn)://([^/]+)~ )`
267	dpurdie	1622	`{`
		1623	`$self->{PROTOCOL} = $1;`
		1624	`$self->{SERVER} = $2;`
		1625	`}`
		1626
		1627	`if ( $self->{PKGROOT} =~ m~(.*)(@\d+)$~ )`
		1628	`{`
		1629	`$self->{PEG} = $2;`
		1630	`}`
		1631
		1632	`#`
		1633	`# Determine TTB type`
		1634	`# Need to handle`
		1635	`# .../trunk`
		1636	`# .../trunk@nnnnn`
		1637	`# .../tags/version@nnnnn`
		1638	`# .../branches/version@nnnnn`
		1639	`#`
		1640	`#`
		1641	`if ( $self->{PKGROOT} =~ m~/?(.)/(tags\|branches\|trunk)(/\|$\|@)(.)$~ )`
		1642	`{`
		1643	`$self->{PATH} = $1;`
		1644	`$self->{TAGTYPE} = $2;`
		1645	`$self->{VERSION} = $4;`
		1646	`}`
		1647	`else`
		1648	`{`
		1649	`$self->{PATH} = $self->{PKGROOT};`
		1650	`}`
		1651
		1652	`DebugDumpData ('SplitPackageUrl', $self ) if ( IsDebug(2) );`
		1653	`}`
		1654
		1655	`#-------------------------------------------------------------------------------`
		1656	`# Function : Full`
		1657	`# FullWs`
		1658	`# Repo`
		1659	`# Peg`
		1660	`# Type`
		1661	`# WsType`
		1662	`# Path`
		1663	`# Version`
		1664	`# RmRef`
385	dpurdie	1665	`# RmPath`
267	dpurdie	1666	`#`
		1667	`# Description : Accessor functions`
		1668	`#`
		1669	`# Inputs : $self - Instance data`
		1670	`# self (is $_[0])`
		1671	`#`
		1672	`# Returns : Data Item`
		1673	`#`
369	dpurdie	1674	`sub Full { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }`
		1675	`sub FullWs { return $_[0]->{URL} . $_[0]->{WSURL} ; }`
		1676	`sub FullWsRev { return $_[0]->{URL} . $_[0]->{WSURL} . '@' . $_[0]->{WSREVNO} ; }`
1343	dpurdie	1677	`sub FullPath { return $_[0]->{URL} . $_[0]->{PATH} ; }`
369	dpurdie	1678	`sub Peg { return $_[0]->{PEG} ; }`
		1679	`sub Type { return $_[0]->{TAGTYPE} \|\| '' ; }`
		1680	`sub WsType { return $_[0]->{WSTYPE} \|\| '' ; }`
		1681	`sub Path { return $_[0]->{PATH} ; }`
		1682	`sub Version { return $_[0]->{VERSION} ; }`
		1683	`sub RmRef { return $_[0]->{RMREF} ; }`
385	dpurdie	1684	`sub RmPath { my $path = $_[0]->{RMREF}; $path =~ s~@.*?$~~ ;return $path; }`
267	dpurdie	1685
		1686	`#-------------------------------------------------------------------------------`
		1687	`# Function : Print`
		1688	`#`
		1689	`# Description : Debug display the URL`
		1690	`#`
		1691	`# Inputs : $self - Instance data`
		1692	`# $header`
		1693	`# $indent`
		1694	`#`
		1695	`# Returns : Nothing`
		1696	`#`
		1697	`sub Print`
		1698	`{`
		1699	`my ($self, $header, $indent) = @_;`
		1700	`print "$header\n" if $header;`
		1701	`$indent = 4 unless ( defined $indent );`
		1702	`$indent = ' ' x $indent;`
		1703
		1704
		1705	`print $indent . "PROTOCOL:" . $self->{PROTOCOL} . "\n";`
		1706	`print $indent . "SERVER :" . $self->{SERVER} . "\n";`
		1707	`print $indent . "URL :" . $self->{URL} . "\n";`
		1708	`print $indent . "PKGROOT :" . $self->{PKGROOT} . "\n";`
		1709	`print $indent . "PATH :" . $self->{PATH} . "\n";`
353	dpurdie	1710	`print $indent . "TAGTYPE :" . ($self->{TAGTYPE} \|\| '') . "\n";`
		1711	`print $indent . "VERSION :" . ($self->{VERSION} \|\| '') . "\n";`
		1712	`print $indent . "PEG :" . ($self->{PEG} \|\| '') . "\n";`
1343	dpurdie	1713	`# print $indent . "FULL :" . $self->Full . "\n";`
		1714
		1715	`print $indent . "Full :" . $self->Full . "\n";`
		1716	`# print $indent . "FullWs :" . $self->FullWs . "\n";`
		1717	`# print $indent . "FullWsRev :" . $self->FullWsRev . "\n";`
		1718	`print $indent . "FullPath :" . $self->FullPath . "\n";`
		1719	`print $indent . "Peg :" . $self->Peg . "\n";`
		1720	`print $indent . "Type :" . $self->Type . "\n";`
		1721	`print $indent . "WsType :" . $self->WsType . "\n";`
		1722	`print $indent . "Path :" . $self->Path . "\n";`
		1723	`print $indent . "Version :" . $self->Version . "\n";`
		1724	`print $indent . "RmRef :" . ($self->RmRef \|\| '') . "\n";`
		1725	`# print $indent . "RmPath :" . ($self->RmPath\|\| '') . "\n";`
267	dpurdie	1726	`}`
		1727
		1728	`#-------------------------------------------------------------------------------`
		1729	`# Function : BranchName`
		1730	`#`
		1731	`# Description : Create a full URL to a branch or tag based on the`
		1732	`# current entry`
		1733	`#`
		1734	`# URL must have a TTB format`
		1735	`#`
		1736	`# Inputs : $self - Instance data`
		1737	`# $branch - Name of the branch`
		1738	`# $type - Optional branch type`
		1739	`#`
		1740	`# Returns : Full URL name to the new branch`
		1741	`#`
		1742	`sub BranchName`
		1743	`{`
		1744	`my ($self, $branch, $type ) = @_;`
		1745	`Debug ( "BranchName", $branch );`
		1746
		1747	`$type = 'branches' unless ( $type );`
		1748	`my $root = $self->{PKGROOT};`
		1749
		1750	`$root =~ s~/(tags\|branches\|trunk)(/\|$\|@).*~~;`
		1751
		1752	`return $self->{URL} . $root . '/' . $type . '/' . $branch;`
		1753	`}`
		1754
379	dpurdie	1755	`#-------------------------------------------------------------------------------`
		1756	`# Function : setRepoProperty`
		1757	`#`
		1758	`# Description : Sets a Repository property`
		1759	`# This may well fail unless the Repo is setup to allow such`
		1760	`# chnages and the user is allowed to make such changes`
		1761	`#`
		1762	`# Inputs : $name`
		1763	`# $value`
1341	dpurdie	1764	`# $allowError - Support for bad repositories`
379	dpurdie	1765	`#`
1341	dpurdie	1766	`# Returns : 0 - Change made`
		1767	`# Will not return on error`
379	dpurdie	1768	`#`
		1769	`sub setRepoProperty`
		1770	`{`
1341	dpurdie	1771	`my ($self, $name, $value, $allowError ) = @_;`
		1772	`my $retval = 0;`
		1773
379	dpurdie	1774	`Debug ( "setRepoProperty", $name, $value );`
		1775	`#`
		1776	`# Ensure that the Repo version is known`
		1777	`# This should be set by a previous operation`
		1778	`#`
		1779	`unless ( defined $self->{REVNO} )`
		1780	`{`
		1781	`Error ("setRepoProperty. Release Revision Number not known");`
		1782	`}`
		1783
		1784	`#`
		1785	`# Execute the command`
		1786	`#`
		1787	`if ( $self->SvnCmd ( 'propset' , $name, '--revprop', '-r', $self->{REVNO}, $value, $self->Full,`
		1788	`{`
		1789	`'credentials' => 1,`
		1790	`'nosavedata' => 1,`
		1791	`}`
		1792	`) )`
		1793	`{`
		1794	`#`
		1795	`# Property NOT set`
		1796	`#`
1341	dpurdie	1797	`if ( $allowError )`
		1798	`{`
		1799	`Warning ("setRepoProperty: $name - FAILED");`
		1800	`$retval = 1;`
		1801	`}`
		1802	`else`
		1803	`{`
		1804	`Error ("setRepoProperty: $name - FAILED");`
		1805	`}`
379	dpurdie	1806	`}`
1341	dpurdie	1807
		1808	`return $retval;`
379	dpurdie	1809	`}`
		1810
1341	dpurdie	1811
		1812	`#-------------------------------------------------------------------------------`
		1813	`# Function : backTrackSvnLabel`
		1814	`#`
		1815	`# Description : Examine a Svn Tag and backtrack until we find the branch`
		1816	`# that was used to create the label`
		1817	`#`
		1818	`# Inputs : $self - Instance Data`
		1819	`# $src_label - Label to process`
		1820	`# Label within the current instance`
1343	dpurdie	1821	`# $refData - Optional Ref.`
		1822	`# If present will pass back data`
1341	dpurdie	1823	`#`
		1824	`# Returns : Branch from which the label was taken`
		1825	`# or the label prefixed with 'tags'.`
		1826	`#`
		1827	`sub backTrackSvnLabel`
		1828	`{`
1343	dpurdie	1829	`my ($self, $src_label, $refData) = @_;`
1341	dpurdie	1830
1343	dpurdie	1831	`if ( $refData && ref($refData) ne 'SCALAR' )`
		1832	`{`
		1833	`Error ('Internal: backTrackSvnLabel. 3rd arg must be ref to a scalar');`
		1834	`}`
		1835
1341	dpurdie	1836	`#`
		1837	`# Init stored data`
		1838	`#`
		1839	`$self->{btData} = ();`
		1840
		1841	`#`
		1842	`# extract data`
		1843	`#`
1343	dpurdie	1844	`#DebugDumpData("SVN", $svn );`
1341	dpurdie	1845	`#$self->{PRINTDATA} = 1;`
		1846	`$src_label =~ s~^tags/~~;`
1343	dpurdie	1847	`$self->SvnCmd ( 'log', '-v', '--xml', '-q', '--stop-on-copy', $self->FullPath() . '/tags/' . $src_label`
1341	dpurdie	1848	`, { 'credentials' => 1,`
		1849	`'process' => \&ProcessBackTrack,`
		1850	`}`
		1851	`);`
		1852
		1853	`#`
		1854	`# Process data`
		1855	`# $self->{btData}{entry} - temp stuff`
		1856	`# @{$self->{btData}{data}} - Array of entries`
		1857	`#`
		1858	`#`
		1859	`# DebugDumpData("btData", $self->{btData} );`
		1860
		1861	`my $peglessLabel = $src_label;`
		1862	`$peglessLabel =~ s~@\d+$~~;`
		1863	`my $branch;`
		1864	`foreach my $entry ( @{$self->{btData}{data}} )`
		1865	`{`
		1866	`my $name;`
		1867	`my $isaBranch;`
		1868	`my $target = $entry->{target};`
		1869
		1870	`if ( $target =~ m~/tags/$peglessLabel$~ )`
		1871	`{`
		1872	`my $parent = $entry->{fromPath};`
		1873	`if ( $parent =~ m~(.+)/((tags\|branches\|trunk)(/\|$).*)~ )`
		1874	`{`
		1875	`$branch = $2 . '@' . $entry->{fromRev};`
		1876	`last;`
		1877	`}`
		1878	`}`
		1879	`}`
1343	dpurdie	1880
		1881	`$$refData = $self->{btData}{data}`
		1882	`if ( $refData );`
1341	dpurdie	1883	`delete $self->{btData};`
		1884
		1885	`#`
		1886	`# Return nice value or original value`
		1887	`#`
		1888	`unless ( $branch )`
		1889	`{`
		1890	`$branch = 'tags/' . $src_label;`
		1891	`}`
		1892
		1893	`Verbose( "backTrackSvnLabel: $src_label -> $branch");`
		1894	`return $branch;`
		1895	`}`
		1896
		1897	`#-------------------------------------------------------------------------------`
		1898	`# Function : ProcessBackTrack`
		1899	`#`
		1900	`# Description :`
		1901	`# Parse`
		1902	`# <logentry`
		1903	`# revision="24272">`
		1904	`# <author>bivey</author>`
		1905	`# <date>2005-07-25T15:45:35.000000Z</date>`
		1906	`# <paths>`
		1907	`# <path`
		1908	`# prop-mods="false"`
		1909	`# text-mods="false"`
		1910	`# kind="dir"`
		1911	`# copyfrom-path="/enqdef/branches/Stockholm"`
		1912	`# copyfrom-rev="24271"`
		1913	`# action="A">/enqdef/tags/enqdef_24.0.1.sls</path>`
		1914	`# </paths>`
		1915	`# <msg>COTS/enqdef: Tagged by Jats Svn Import</msg>`
		1916	`# </logentry>`
		1917	`#`
		1918	`#`
		1919	`# Uses: $self->{btData} - Scratch Data`
		1920	`#`
		1921	`# Inputs : $self - Class Data`
		1922	`# $line - Input data to parse`
		1923	`#`
		1924	`# Returns : 0 - Do not terminate input command`
		1925	`#`
		1926	`sub ProcessBackTrack`
		1927	`{`
		1928	`my ($self, $line ) = @_;`
		1929	`Message ( $line ) if $self->{PRINTDATA};`
		1930
1343	dpurdie	1931	`if ( $line =~ m~^<path$~ ) {`
		1932	`delete $self->{btData}{entry};`
		1933	`} elsif ( $line =~ m~^\s*kind="(.+)"~ ) {`
		1934	`$self->{btData}{entry}{kind} = $1;`
1341	dpurdie	1935	`} elsif ( $line =~ m~^\s+revision="(\d+)"~ ) {`
		1936	`$self->{btData}{entry}{Rev} = $1;`
		1937	`} elsif ( $line =~ m~^\s+copyfrom-path="(.*)"~ ) {`
		1938	`$self->{btData}{entry}{fromPath} = $1;`
		1939	`} elsif ( $line =~ m~^\s+copyfrom-rev="(\d+)"~ ) {`
		1940	`$self->{btData}{entry}{fromRev} = $1;`
1343	dpurdie	1941	`} elsif ( $line =~ m~^\saction="(.+)">(.)</path>~ ) {`
		1942	`$self->{btData}{entry}{action} = $1;`
		1943	`$self->{btData}{entry}{target} = $2;`
		1944	`push @{$self->{btData}{data}}, $self->{btData}{entry};`
		1945	`delete $self->{btData}{entry};`
1341	dpurdie	1946	`}`
		1947
		1948	`#`
		1949	`# Return 0 to keep on going`
		1950	`return 0;`
		1951	`}`
		1952
		1953
		1954
267	dpurdie	1955	`#------------------------------------------------------------------------------`
		1956	`1;`

Subversion Repositories DevTools

(root)/core_devl/branches/dpurdie_devl/TOOLS/LIB/JatsSvn.pm – Rev 1343