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

Subversion Repositories DevTools

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