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

Subversion Repositories DevTools

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