Rev 351 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed
######################################################################### Copyright (C) 2008 ERG Limited, All rights reserved## Module name : jats.sh# Module type : Makefile system# Compiler(s) : n/a# Environment(s): jats## Description : JATS Subversion Interface Functions## Requires a subversion client to be present on the machine# Does require at least SubVersion 1.5# Uses features not available in 1.4## The package currently implements a set of functions# There are some intentional limitations:# 1) Non recursive# 2) Errors terminate operation## This package contains experimental argument passing# processes. Sometimes use a hash of arguments##......................................................................#require 5.008_002;use strict;use warnings;our $GBE_SVN_URL;use JatsEnv;package JatsSvn;use JatsError;use JatsSystem;use JatsSvnCore qw(:All);use File::Path; # Instead of FileUtilsuse File::Basename;use Cwd;# automatically export what we need into namespace of caller.use Exporter();our (@ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK);@ISA = qw(Exporter JatsSvnCore);@EXPORT = qw(NewSessionNewSessionByWSNewSessionByUrlSvnRmViewSvnIsaSimpleLabelSvnCommentSvnUserCmd);@EXPORT_OK = qw();%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);## Global Variables##-------------------------------------------------------------------------------# Function : BEGIN## Description : Module Initialization# Invoked by Perl as soon as possible# Setup environment variables# Calculate globals## Inputs : None## Returns : Nothing#sub BEGIN{## Need to have a configured Repository#::EnvImport ('GBE_SVN_URL' );## Remove trailing /s#$::GBE_SVN_URL =~ s~/*$~~;## Ensure that it is in valid format# Three forms are supported#if ( $::GBE_SVN_URL =~ m{^svn://[^/]+$} ) {## Type is SVN server# Protocol + server name#} elsif ( $::GBE_SVN_URL =~ m{^http://.+} ) {## Type is HTTP server# Protocol + server name + path on server#} elsif ( $::GBE_SVN_URL =~ m{^file:///+[A-Z]:/} ) {## Type is local Repo (file)# Windows absolute pathname# file:///I:/path/...#} elsif ( $::GBE_SVN_URL =~ m{^file:///+[^/]} ) {## Type is local Repo (file)# Unix absolute pathname# file:///path/...#} else {Error ("GBE_SVN_URL format not understood","GBE_SVN_URL: $::GBE_SVN_URL");}## Add a trailing '/'# This will make it easier to use#$::GBE_SVN_URL .= '/';}#-------------------------------------------------------------------------------# Function : SvnCo## Description : Create a workspace# Can be used to extract files, without creating the# subversion control files.## Inputs : $self - Instance data# $RepoPath - Within the repository# $Path - Local path# Options - Options# --Export - Export Only## Returns : Nothing#sub SvnCo{my ($self, $RepoPath, $path, @opts) = @_;my $export = grep (/^--Export/, @opts );Debug ("SvnCo");## Ensure that the output path does not exist# Do not allow the user to create a local work space# where one already exists#Error ("SvnCo: No PATH specified" ) unless ( $path );Error ("SvnCo: Target path already exists", "Path: " . $path ) if ( -e $path );## Build up the command line#my @args = $export ? 'export' : 'checkout';push @args, qw( --ignore-externals );push @args, $RepoPath, $path;my @co_list;if ( $self->SvnCmd ( @args,{'process' => \&ProcessCo,'data' => \@co_list,'credentials' => 1,'nosavedata' => 1,}) || @co_list ){## We have a checkout limitation# Delete the workspace and then report the error#Verbose2 ("Remove WorkSpace: $path");rmtree( $path, IsVerbose(3) );Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );}return;## Internal routine to scan each the checkout## Due to the structure of a SubVersion repository it would be# possible for a user to extract the entire repository. This is# not good as the repo could be very very large## Assume that the structure of the repo is such that our# user is not allowed to extract a directory tree that contains# key paths - such as /tags/ as this would indicate that they are# attempting to extract something that is not a package##sub ProcessCo{my $self = shift;if ( m~((/)(tags|branches|trunk)(/|$))~ ){my $bad_dir = $1;push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";return 1;}#### Limit the size of the WorkSpace## This limit is a bit artificial, but does attempt to## limit views that encompass too much.###if ( $#{$self->{RESULT_LIST}} > 100 )#{# Warning ("View is too large - DEBUG USE ONLY. WILL BE REMOVED" );# push @{$self->{ERROR_LIST}}, "View too large";# return 1;#}}}#-------------------------------------------------------------------------------# Function : SvnCi## Description : Check in the specified WorkSpace## Inputs : $self - Instance data# A hash of named arguments# comment - Commit comment## Returns : Tag of the checkin#sub SvnCi{my $self = shift;my %opt = @_;my $status_url;Debug ("SvnCi");Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);## Validate the source path# Note: populates @{$self->{RESULT_LIST}} with 'info' commands#my $path = SvnValidateWs ($self, 'SvnCi');## Scan the @{$self->{RESULT_LIST}}, which has the results of an 'info'# command the locate the URL.## This contains the target view space# Sanity test. Don't allow Checkin to a /tags/ area#foreach ( @{$self->{RESULT_LIST}}){if ( m~^URL:\s+(.+)~ ){$status_url = $1;last;}}Error ("SvnCi: Cannot determine Repositoty URL")unless ( $status_url );Error ("SvnCi: Not allowed to commit to a 'tags' area", "URL: $status_url")if ( $status_url =~ m~/tags(/|$)~ );## Commit#$self->SvnCmd ( 'commit', $path, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),, { 'credentials' => 1,'process' => \&ProcessRevNo,'error' => "SvnCi: Copy Error" });Error ("SvnCi: Cannot determine Revision Number", @{$self->{RESULT_LIST}})unless ( $self->{REVNO} );## Update the view# Doing this so that the local view contains an up to date# revision number. If not done, and a 'copy' is done based# on this view then the branch information will indicate that# the copy is based on an incorrect version.# This can be confusing!#$self->SvnCmd ( 'update' , $path, '--ignore-externals', { 'credentials' => 1,'error' => "SvnCi: Updating WorkSpace" });## Pass the updated revision number back to the user#$self->CalcRmReference($status_url);Message ("Tag is: " . $self->{RMREF} );return $self->{RMREF} ;}#-------------------------------------------------------------------------------# Function : SvnCreatePackage## Description : Create a package and any associated files## Inputs : $self - Instance data# A hash of named arguments# package - Name of the package# May include subdirs# new - True: Must not already exist# replace - True: Replace targets# import - DirTree to import# label - Tag for imported DirTree# type - Import TTB target## Returns : Revision of the copy#sub SvnCreatePackage{my $self = shift;my %opt = @_;my $target;Debug ("SvnCreatePackage", @_);Error ("Odd number of args to SvnCreatePackage") unless ((@_ % 2) == 0);my %dirs = ( 'trunk/' => 0,'tags/' => 0,'branches/' => 0 );## Sanity Tests#my $package = $self->Full || Error ("SvnCreatePackage: No package name provided");Error ("SvnCreatePackage: Invalid import path") if ( $opt{'import'} && ! -d $opt{'import'} );Error ("SvnCreatePackage: Tag without Import") if ( $opt{'label'} && ! $opt{'import'} );$opt{'label'} = SvnIsaSimpleLabel( $opt{'label'} ) if ( $opt{'label'} );## Package path cannot contain any of the keyword paths tags,trunk,branches# as this would place a package with a package#Error ("Package path contains a reserved word ($1)", "Path: $package")if ( $package =~ m~/(tags|branches|trunk)(/|$)~ );## Package path cannot be pegged, or look like one#Error ("Package name contains a Peg ($1)", "Path: $package")if ( $package =~ m~.*(@\d+)$~ );## Determine TTB target#$opt{'type'} = 'trunk' unless ( $opt{'type'} );Error ("Invalid TTB type") unless ( $opt{'type'} =~ m{^(tags|branches|trunk)$} );Error ("Import without label") if ( $opt{'type'} ne 'trunk' && ! $opt{'label'} );## Before we import data we must ensure that the targets do not exist# Determine the import target(s)#my $import_target;my $copy_target;if ( $opt{'import'} ){## Primary target# trunk, branck or tag#$import_target = $package . '/' . $opt{'type'};$import_target .= '/' .$opt{'label'} if ( $opt{'type'} ne 'trunk');$self->SvnValidateTarget( 'target' => $import_target,'delete' => $opt{'replace'},'available' => 1 );## Secondary target# If primary is a trunk and a label is provided#if ( $opt{'type'} eq 'trunk' && $opt{'label'} ){$copy_target = $package . '/tags/' . $opt{'label'};$self->SvnValidateTarget( 'target' => $copy_target,'delete' => $opt{'replace'},'available' => 1 );}}## Probe to see if the package exists#my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'SvnCreatePackage', $package );if ( @$ref_dirs ){Error ("SvnCreatePackage: Package directory exists","Cannot create a package here. Unexpected subdirectories:", @$ref_dirs);}if ( @$ref_files ){Warning ("SvnCreatePackage: Unexpected files found","Path: $package","Unexpected files found: @$ref_files");}if ( @$ref_svn ){## Do we need a new one#Error ("SvnCreatePackage: Package exists: $package") if $opt{'new'};## Some subversion files have been found here# Create the rest# Assume that the directory tree is good### Some, or all, of the required package subdirectories exist# Determine the new ones to created so that it can be done# in an atomic step#delete $dirs{$_} foreach ( @$ref_svn );if ( keys %dirs ){Warning ("SvnCreatePackage: Not all package subdirs present","Remaining dirs will be created","Found: @$ref_svn") if @$ref_svn;}else{Warning ("SvnCreatePackage: Package already present");}}## Create package directories that have not been discovered# trunk# branches# tags#my @dirs;push @dirs, $package . '/' . $_ foreach ( keys %dirs );$target = $package . '/trunk';## Create missing directories - if any#if ( @dirs ){$self->SvnCmd ('mkdir', @dirs, '-m', 'Created by SvnCreatePackage', '--parents', { 'credentials' => 1,'error' => "SvnCreatePackage" } );}## Import data into the package if required# Import data. Possible cases:# - Import to trunk - and then tag it# - Import to branches# - Import to tags#if ( $import_target ){Verbose ("Importing directory into new package: $opt{'import'}");$target = $import_target;$self->{PRINTDATA} = 1;$self->SvnCmd ('import', $opt{'import'}, $target, '-m', 'Import by SvnCreatePackage', '--force', { 'credentials' => 1,'error' => "Import Incomplete",'process' => \&ProcessRevNo})}## If imported to the trunk AND a label is provided# then tag the import as well.# A simple URL copy#if ( $copy_target ){Verbose ("Labeling imported trunk: $opt{'label'} ");$target = $copy_target;$self->SvnCmd ('copy' , $import_target, $target, '-m', 'Import tagged by SvnCreatePackage', { 'credentials' => 1, 'process' => \&ProcessRevNo, 'error' => "Import Incomplete" } );}## Pass the updated revision number back to the user#$self->CalcRmReference($target);Message ("Tag is: " . $self->{RMREF} );return $self->{RMREF} ;}#-------------------------------------------------------------------------------# Function : SvnRmView## Description : Remove a Subversion view# Will run sanity checks and only remove the view if# all is well## Inputs : A hash of named arguments# path - Path to local workspace# modified - Array of files that are allowed to be modified# force - True: Force deletion## Returns :#sub SvnRmView{my %opt = @_;Debug ("SvnRmView");Error ("Odd number of args to SvnRmView") unless ((@_ % 2) == 0);## Sanity test#my $path = $opt{'path'} || '';my $path_length = length ($path);Verbose2 ("Delete WorkSpace: $path");## If the path does not exist then assume that its already deleted#unless ( $path && -e $path ){Verbose2 ("SvnRmView: Path does not exist");return;}## Create information about the workspace# This will also validate the path#my $session = NewSessionByWS ( $path );## Validate the path#$session->SvnValidateWs ($path, 'SvnRmView');## Ask subversion if there are any files to be updated# Prevent deletion of a view that has modified files#unless ( $opt{'force'} ){$session->SvnWsModified ( 'cmd' => 'SvnRmView', %opt );}## Now we can delete it#Verbose2 ("Remove WorkSpace: $path");rmtree( $path, IsVerbose(3) );}#-------------------------------------------------------------------------------# Function : SvnCopyWs## Description : Copy a workspace to a new place in the repository# Effectively 'label' the workspace## It would appear that the 'copy' command is very clever# If a version-controlled file has been changed# in the source workspace, then it will automatically be# copied. This is a trap.## Only allow a 'copy' if there are no modified# files in the work space (unless overridden)### Inputs : $self - Instance data# A hash of named arguments# path - Path to local workspace# target - Location within the repository to copy to# comment - Commit comment# modified - Array of files that are allowed to# be modified in the workspace.# noswitch - True: Don't switch to the new URL# replace - True: Delete existing tag if present## Returns : Revision of the copy#sub SvnCopyWs{my $self = shift;my %opt = @_;Debug ("SvnCopyWs");Error ("Odd number of args to SvnCopyWs") unless ((@_ % 2) == 0);Error ("SvnCopyWs: No Workspace" ) unless ( $self->{WS} );## Insert defaults#my $target = $opt{target} || Error ("SvnCopyWs: Target not specified" );## Validate the source path#my $path = SvnValidateWs ($self, 'SvnCopyWs');## Validate the target# Cannot have a 'peg'#Error ("SvnCopyWs: Target contains a Peg: ($1)", $target)if ( $target =~ m~(@\d+)\s*$~ );## Examine the workspace and ensure that there are no modified# files - unless they are expected#$self->SvnWsModified ( 'cmd' => 'SvnCopyWs', %opt );## Validate the repository# Ensure that the target does not exist# The target may be deleted if it exists and allowed by the user#$self->SvnValidateTarget ( 'cmd' => 'SvnCopyWs','target' => $target,'delete' => $opt{replace},'comment' => 'Deleted by SvnCopyWs');## Copy source to destination# It would appear that even though the source is a WorkSpace, the copy# does not transfer data from the WorkSpace. It appears as though its all# done on the server. This is good - and fast.## More over files that are modified in the local workspace will# be copied and checked into the target.#if ( $self->SvnCmd ( 'cp' , $path, $target, '--parents', '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),, { 'process' => \&ProcessRevNo,'credentials' => 1, }) ){## Error in copy# Attempt to delete the target. Don't worry if we can't do that#my @err1 = @{$self->{ERROR_LIST}};$self->SvnCmd ( 'delete', $target, '-m', 'Deleted by SvnCopyWs after creation failure', { 'credentials' => 1, });Error ("SvnCopyWs: Copy Error", @err1);}Error ("SvnCopyWs: Cannot determine Revision Number", @{$self->{RESULT_LIST}})unless ( $self->{REVNO} );Verbose2 ("Copy committed as revision: " . $self->{REVNO} );unless ( $opt{'noswitch'} ){## Switch to the new URL# This will link the Workspace with the copy that we have just made#$self->SvnCmd ( 'switch', $target, $path, { 'credentials' => 1,'error' => "SvnCopyWs: Cannot switch to new URL" });}## Pass the updated revision number back to the user#$self->CalcRmReference($target );Message ("Tag is: " . $self->{RMREF} );return $self->{RMREF} ;}#-------------------------------------------------------------------------------# Function : SvnWsModified## Description : Test a Workspace for modified files# Allow some files to be modified## Inputs : $self - Instance data# A hash of named arguments# path - Path to local workspace# modified - Files that are allowed to be modified# Relative to the 'path'# May be a single file or an array of files# cmd - Command name for error reporting## Returns :#sub SvnWsModified{my $self = shift;my %opt = @_;Debug ("SvnWsModified");Error ("Odd number of args to SvnWsModified") unless ((@_ % 2) == 0);my $cmd = $opt{'cmd'} || 'SvnWsModified';## Validate the path#SvnValidateWs ($self, $cmd);my $path = $self->{WS};my $path_length = length ($path);Verbose2 ("Test Workspace for Modifications: $path");## Ask subversion if there are any files to be updated#$self->SvnCmd ('status', $path, {'error' => "Svn status command error"} );## Examine the list of modified files#if ( @{$self->{RESULT_LIST}} ){## Create a hash of file that are allowed to change# These are files relative to the base of the view## The svn command has the 'path' prepended, so this# will be removed as we process the commands#my %allowed;my @unexpected;if ( exists $opt{'modified'} ){$allowed{'/' . $_} = 1 foreach ( ref ($opt{'modified'}) ? @{$opt{'modified'}} : $opt{'modified'} );}## Process the list of modified files# Do this even if we aren't allowed modified files as we# still need to examine the status and kill off junk entries# ie: ?, I, ! and ~## First column: Says if item was added, deleted, or otherwise changed# ' ' no modifications# 'A' Added# 'C' Conflicted# 'D' Deleted# 'I' Ignored# 'M' Modified# 'R' Replaced# 'X' item is unversioned, but is used by an externals definition# '?' item is not under version control# '!' item is missing (removed by non-svn command) or incomplete# '~' versioned item obstructed by some item of a different kind#foreach my $entry ( @{$self->{RESULT_LIST}} ){## Extract filename from line# First 7 chars are status# Remove WS path too#my $file = substr ( $entry, 7 + $path_length );next if ( $allowed{$file} );## Examine the first char and rule out funny things#my $f1 = substr ($entry, 0,1 );next if ( $f1 =~ m{[?I!~]} );push @unexpected, $entry;}Error ("Workspace contains unexpected modified files", @unexpected)if ( @unexpected );}}#-------------------------------------------------------------------------------# Function : SvnListPackages## Description : Determine a list of packages within the repo# This turns out to be a very slow process# so don't use it unless you really really need to## Inputs : $repo - Name of the repository## Returns :#sub SvnListPackages{my ($repo) = @_;my @path_list = $repo;my @list;my $scanned = 0;Debug ("SvnListPackages");while ( @path_list ){my $path = shift @path_list;$scanned++;print "Reading: $path\n";my ( $ref_files, $ref_dirs, $ref_svn, $found ) = SvnScanPath ( 'Listing Packages', $path );## If there are Subversion dirs (ttb) in this directory# then this is a package. Add to list#push @list, $path if ( @$ref_svn );## Add subdirs to the list of paths to explore#foreach ( @$ref_dirs ){chop; # Remove trailing '/'push @path_list, $path . '/' . $_; # Extend the path}}Message ("Found:", @list );Message ("Dirs Scanned: $scanned");Message ("Packages Found: $#list");}#-------------------------------------------------------------------------------# Function : ListLabels## Description : List labels within a given package## Inputs : $self - Instance data# $path - path to label source## Returns : Ref to an array#sub ListLabels{my ($self, $path) = @_;Debug ("ListLabels");my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Versions', $path );Error ("List: Path not found: $path") unless ( $found );## Dont report files - just directories#return $ref_dirs;}#-------------------------------------------------------------------------------# Function : SvnLocateWsRoot## Description : Given a WorkSpace, determine the root of the work space# This is not as simple as you might think## Algorithm# svn ls ..# Am I in the parent directory# Repeat## Inputs : $self - Instance data# $test - True: Don't die on error## Returns : Root of workspace as an absolute address# Will not return if there is an error#sub SvnLocateWsRoot{my ($self, $test) = @_;my @path;my $path = $self->{WS};Debug ("SvnLocateWsRoot");Error ("SvnLocateWsRoot: No Workspace") unless ( $path );Verbose2 ("SvnLocateWsRoot: Start in $path");## Validate the source path#if ( SvnValidateWs ($self, 'SvnLocateWsRoot', $test) ){return undef;}## Need to sanitize the users path to ensure that the following# algorithm works. Need:# 1) Absolute Path# 2) Not ending in '/'### If we have a relative path then prepend the current directory# An absolute path is:# /aaa/aa/aa# or c:/aaa/aa/aa#$path = getcwd() . '/' . $pathunless ( $path =~ m~^/|\w:/~ );## Walk the bits and remove ".." directories# Done by pushing non-.. elements and poping last entry for .. elements.# Have a leading "/" which is good.## Create a array of directories in the path# Split on one or more \ or / separators#foreach ( split /[\\\/]+/ , $path ){next if ( $_ eq '.' );unless ( $_ eq '..' ){push @path, $_;}else{Error ("SvnLocateWsRoot: Bad Pathname: $path")if ( $#path <= 0 );pop @path;}}Verbose2 ("Clean absolute path elements: @path");PATH_LOOP:while ( @path ){## This directory element. Append / to assist in compare# Determine parent path#my $name = pop (@path) . '/';my $parent = join ('/', @path );## Examine the parent directory# Get a list of all elements in the parent# Need to ensure that this directory is one of them## Ignore any errors - assume that they are because the# parent is not a part of the work space. This will terminate the# search.#$self->SvnCmd ('list', $parent, '--depth', 'immediates' );foreach my $entry ( @{$self->{RESULT_LIST}} ){next PATH_LOOPif ( $entry eq $name );}## Didn't find 'dir' in directory svn listing of parent# This parent is not a part of the same WorkSpace as 'dir'# We have a winner.#chop $name; # Chop the '/' previously added$self->{WS} = $parent . '/' . $name;return $self->{WS};}## Shouldn't get this far#Error ("SvnLocateWsRoot: Root not found");}#-------------------------------------------------------------------------------# Function : SvnValidateWs## Description : Validate the path to a working store## Inputs : $self - Instance data# $user - Optional prefix for error messages# $test - True: Just test, Else Error## Returns : Will not return if not a workspace# Returns the users path# @{$self->{RESULT_LIST}} will be populated with info about the# item requested as per an 'info' call#sub SvnValidateWs{my ($self, $user, $test) = @_;Debug ("SvnValidateWs");$user = "Invalid Subversion Workspace" unless ( $user );my $path = $self->{WS} ;## Only validate it one#return $path if ( $self->{WS_VALIDATED} );## Validate the source path# Must exist and must be a directory#if ( ! $path ) {@{$self->{ERROR_LIST}} = "$user: No path specified";} elsif ( ! -e $path ) {@{$self->{ERROR_LIST}} = "$user: Path does not exist: $path";} elsif ( ! -d $path ) {@{$self->{ERROR_LIST}} = "$user: Path is not a directory";} else {## Determine the source path is an fact a view# The info command can do this. Use depth empty to limit the work done#$self->SvnCmd ('info', $path, '--depth', 'empty' );## Error. Prepend nice message#unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"if ( @{$self->{ERROR_LIST}} );}## Figure out what to do#if ( $test ){return @{$self->{ERROR_LIST}};}else{Error @{$self->{ERROR_LIST}} if @{$self->{ERROR_LIST}};$self->{WS_VALIDATED} = 1;return $path;}}#-------------------------------------------------------------------------------# Function : SvnValidatePackageRoot## Description : Validate a package root## Inputs : $self - Instance data## Returns : Will only return if valid# Returns a cleaned package root#sub SvnValidatePackageRoot{my ($self) = @_;Debug ("SvnValidatePackageRoot");my $url = $self->Full || Error ("SvnValidatePackageRoot: No URL");Error ("Package path contains a reserved word ($self->{TAGTYPE})", "Path: $url")if ( $self->{TAGTYPE} );Error ("Package name contains a Peg ($self->{PEG})", "Path: $url")if ( $self->{PEG} );## Ensure that the target path does exist# Moreover it needs to be a directory and it should have a# a ttb structure#my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Package Base Test', $url );## Examine the results to see if we have a valid package base#Error ("Package Base Test: Not a valid package") unless ( $found );## Extra bits found# Its not the root of a package#if ( @$ref_files ){Warning ("Package Base Test: Files exists","Unexpected files found:", @$ref_files );}## Need a truck directory# If we don't have a truck we don't have a package#my $trunk_found = grep ( /trunk\//, @$ref_svn );Error ("Invalid Package Base. Does not contain a 'trunk' directory")unless ( $trunk_found );return $url;}#-------------------------------------------------------------------------------# Function : SvnIsaSimpleLabel## Description : Check a label# Must not contain a PEG# Must not contain invalid characters (@ or /)# Must not contain a :: sequence (will confuse other tools)# Handle special label of TIMESTAMP## Inputs : $label - to test## Returns : Will not return on error# Returns label on success#sub SvnIsaSimpleLabel{my ($label) = @_;Debug ("SvnIsaSimpleLabel, $label");Error ("No label provided") unless ( $label );Error ("Invalid label. Peg (\@nnn) is not allowed: \"$label\"" ) if ( $label =~ m~@\d+$~ );Error ("Invalid label. Package Path is not allowed: \"$label\"" ) if ( $label =~ m~/~ );Error ("Invalid label. Invalid Characters: \"$label\"" ) unless ( $label =~ m~^[-.:0-9a-zA-Z_]+$~ );Error ("Invalid label. Double :: not allowed: \"$label\"" ) if ( $label =~m~::~ );## Allow for a label of TIMESTAMP and have it expand#if ( $label eq 'TIMESTAMP' ){$label = localtime();$label =~ s~\s+~_~g;}return $label;}#-------------------------------------------------------------------------------# Function : NewSession## Description : Create a new empty SvnSession Class## Inputs : None## Returns : Class#sub NewSession{Debug ("NewSession");my $self = SvnSession();## Document Class Variables#$self->{URL} = ''; # Repo URL prefix$self->{WS} = ''; # Users WorkSpace$self->{NAMEDSERVER} = ''; # User specified server$self->{PROTOCOL} = ''; # Named Access Protocol$self->{PKGROOT} = ''; # Package root## Create a class# Bless my self#bless ($self, __PACKAGE__);return $self;}#-------------------------------------------------------------------------------# Function : NewSessionByWS## Description : Establish a new SVN Session based on a Workspace# Given a workspace path determine the SvnServer and other# relevent information.## Requires some rules# * The package is rooted within a 'ttb'## Inputs : $path - Path to WorkSpace# $test - No Error on no WS## Returns : Ref to Session Information#sub NewSessionByWS{my ($path, $test) = @_;Debug ("NewSessionByWS", @_);## Create a basic Session# Populate it with information that is known#my $self = NewSession();$self->{WS} = $path;## Validate the path provided# In the process populate the @{$self->{RESULT_LIST}} with information# about the workspace.#if ($self->SvnValidateWs ( undef, 1) ){return $self if ( $test );Error ( @{$self->{ERROR_LIST}} );}## Extract useful info# URL: svn://auperaws996vm21/test/MixedView/trunk# Repository Root: svn://auperaws996vm21/test#my $url;my $reporoot;foreach ( @{$self->{RESULT_LIST}} ){$url = $1 if ( m~^URL:\s+(.+)~ );$reporoot = $1 if ( m~^Repository Root:\s+(.+)~ );last if ( $url && $reporoot );}Error ("JatsSvn Internal error. Can't parse info")unless ( $url && $reporoot );## Need the length of the path to the repository# but not the name of the repostory itself.## Remove that from the head of the URL to give a# path within the repository, that includes the repos name#$reporoot = (fileparse( $reporoot ))[1];$url = substr ($url, length ($reporoot));$self->{WSURL} = $url;chop $reporoot;Verbose2 ("SvnLocatePackageRoot: $reporoot, $url" );## Remove anything after a ttb ( truck, tags, branch ) element# This will be the root of the package within the repo#if ( $url =~ m~(.+)/((tags|branches|trunk)(/|$).*)~ ){$url = $1;$self->{WSTYPE} = $3;}else{Error ("SvnLocatePackageRoot. Non standard repository format","Url: $url");}## Insert known information#$self->{URL} = $reporoot . '/';$self->{PKGROOT} = $url;## Create useful information#SplitPackageUrl($self);return $self;}#-------------------------------------------------------------------------------# Function : NewSessionByUrl## Description : Establish a new SVN Session based on a user URL## Inputs : $uurl - Users URL# $session - Optional: Existing session## Returns : Ref to Session Information#sub NewSessionByUrl{my ($uurl, $self ) = @_;Debug ("NewSessionByUrl", @_);Error ("No Repostory Path specified") unless ( $uurl );## Create a basic Session# Populate it with information that is known#$self = NewSession() unless ( $self );## Examine the URL and determine if we have a FULL Url or# a path within the 'default' server#if ( $uurl =~ m~^((file|http|svn):///?([^/]+)/)(.+)~ ){# http://server/# svn://server/# file://This/Isa/Bad/Guess#$self->{NAMEDSERVER} = 1;$self->{PROTOCOL} = $2;$self->{URL} = $1;$self->{PKGROOT} = $4;}else{## User default (site configured) Repo Root#Error ("No site repository configured","Configure GBE_SVN_URL" ) unless ( $::GBE_SVN_URL );$self->{URL} = $::GBE_SVN_URL;$self->{PKGROOT} = $uurl;}## Create useful information#SplitPackageUrl($self);return $self;}#-------------------------------------------------------------------------------# Function : SplitPackageUrl## Description : Slip the package URL into a few useful bits## Inputs : $self - Instance data## Returns : Nothing#sub SplitPackageUrl{my ($self) = @_;Debug ("SplitPackageUrl", @_);## Remove any protocol that may be present# http://server/# svn://server/# file://This/Isa/Bad/Guess#if ( $self->{URL} =~ m~^(file|http|svn)://([^/]+)~ ){$self->{PROTOCOL} = $1;$self->{SERVER} = $2;}if ( $self->{PROTOCOL} eq 'svn' && $self->{PKGROOT} =~ m~([^/]+)/~ ){$self->{REPO} = $1;}if ( $self->{PKGROOT} =~ m~(.*)(@\d+)$~ ){$self->{PEG} = $2;}## Determine TTB type# Need to handle# .../trunk# .../trunk@nnnnn# .../tags/version@nnnnn# .../branches/version@nnnnn##if ( $self->{PKGROOT} =~ m~/?(.*)/(tags|branches|trunk)(/|$|@)(.*)$~ ){$self->{PATH} = $1;$self->{TAGTYPE} = $2;$self->{VERSION} = $4;my $package = $self->{PATH};$package =~ s~.*/~~;$self->{PACKAGE} = $package}else{$self->{PATH} = $self->{PKGROOT};}DebugDumpData ('SplitPackageUrl', $self ) if ( IsDebug(2) );}#-------------------------------------------------------------------------------# Function : Full# FullWs# Repo# Peg# Type# WsType# Package# Path# Version# RmRef# Url## Description : Accessor functions## Inputs : $self - Instance data# self (is $_[0])## Returns : Data Item#sub Url { return $_[0]->{URL} . ($_[1] || '') ; }sub Full { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }sub FullWs { return $_[0]->{URL} . $_[0]->{WSURL} ; }sub Peg { return $_[0]->{PEG} ; }sub Type { return $_[0]->{TAGTYPE} || '' ; }sub WsType { return $_[0]->{WSTYPE} || '' ; }sub Package { return $_[0]->{PACKAGE} ; }sub Path { return $_[0]->{PATH} ; }sub Version { return $_[0]->{VERSION} ; }sub RmRef { return $_[0]->{RMREF} ; }#-------------------------------------------------------------------------------# Function : Print## Description : Debug display the URL## Inputs : $self - Instance data# $header# $indent## Returns : Nothing#sub Print{my ($self, $header, $indent) = @_;print "$header\n" if $header;$indent = 4 unless ( defined $indent );$indent = ' ' x $indent;print $indent . "PROTOCOL:" . $self->{PROTOCOL} . "\n";print $indent . "SERVER :" . $self->{SERVER} . "\n";print $indent . "URL :" . $self->{URL} . "\n";print $indent . "PKGROOT :" . $self->{PKGROOT} . "\n";print $indent . "PATH :" . $self->{PATH} . "\n";print $indent . "PACKAGE :" . $self->{PACKAGE} . "\n";print $indent . "TAGTYPE :" . $self->{TAGTYPE} . "\n";print $indent . "VERSION :" . $self->{VERSION} . "\n";print $indent . "PEG :" . $self->{PEG} . "\n";print $indent . "FULL :" . $self->Full . "\n";}#-------------------------------------------------------------------------------# Function : BranchName## Description : Create a full URL to a branch or tag based on the# current entry## URL must have a TTB format## Inputs : $self - Instance data# $branch - Name of the branch# $type - Optional branch type## Returns : Full URL name to the new branch#sub BranchName{my ($self, $branch, $type ) = @_;Debug ( "BranchName", $branch );$type = 'branches' unless ( $type );my $root = $self->{PKGROOT};$root =~ s~/(tags|branches|trunk)(/|$|@).*~~;return $self->{URL} . $root . '/' . $type . '/' . $branch;}#------------------------------------------------------------------------------1;