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

Subversion Repositories DevTools

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