Subversion Repositories DevTools

########################################################################

# 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 $USER;

use JatsEnv;

package JatsSvn;

use JatsError;

use JatsSystem;

use JatsSvnCore qw(:All);

use File::Path;             # Instead of FileUtils

use 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(

                    NewSession

                    NewSessionByWS

                    NewSessionByUrl

                    SvnRmView

                    SvnIsaSimpleLabel

                    SvnComment

                    SvnUserCmd

                    SvnPath2Url

                    SvnPaths

                );

@EXPORT_OK =  qw(

                );

%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);

#

#   Global Variables

#

#-------------------------------------------------------------------------------

# 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

#                           --NoPrint   - Don't print files exported

#

# Returns         : Nothing

#

sub SvnCo

{

    my ($self, $RepoPath, $path, @opts) = @_;

    my $export = grep (/^--Export/, @opts );

    $self->{PRINTDATA} = ! grep (/^--NoPrint/, @opts );

    Debug ("SvnCo", $RepoPath, $path);

    #

    #   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

        #

        #   Note: For some reason a simple rmtree doesn't work

        #         Nor does glob show all the directories

        #

        Verbose2 ("Remove WorkSpace: $path");

        rmtree( $path, IsVerbose(3) );

        rmtree( $path, IsVerbose(3) );

        Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );

    }

    $self->{PRINTDATA} = 0;

    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;

        my $data = shift;

        if ( $self->{PRINTDATA} )

        {

            #

            #   Pretty display for user

            #

            Information1 ("Extracting: $data");

        }

        if (  $data =~ 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

#                       allowSame   - Allow no change to the workspace

#

# Returns         : Tag of the checkin

#

sub SvnCi

{

    my $self = shift;

    my %opt = @_;

    my $status_url;

    my $ws_rev;

    Debug ("SvnCi");

    Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);

    #

    #   Validate the source path

    #   Note: populates %{$self->{InfoWs}} with 'info' data

    #

    my $path = SvnValidateWs ($self, 'SvnCi');

    #

    #   Examine %{$self->{InfoWs}}, 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

    #

    $status_url = $self->{InfoWs}{URL};

    $ws_rev = $self->{InfoWs}{Revision};

    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

    #   Will modify Repo, so kill the cached Info

    #   Will only be a real issue if we tag in the same session

    #

    delete $self->{'InfoWs'};

    delete $self->{'InfoRepo'};

    $self->SvnCmd ( 'commit', $path

                    , '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),

                    , { 'credentials' => 1,

                        'process' => \&ProcessRevNo,

                        'error' => "SvnCi: Copy Error",

                         }

                        );

    #

    #   No error and no commit

    #   Workspace was not changed, may be allowed

    #

    if ( ! $self->{REVNO} && $opt{allowSame} )

    {

        Warning ("SvnCi: Workspace matches Repository. No commit");

        $self->{REVNO} = $ws_rev;

    }

    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 ("Commit 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', $self->Path() . ': Created by SvnCreatePackage'

                       , '--parents'

                       , { 'credentials' => 1

                           ,'error' => "SvnCreatePackage"

                           ,'process' => \&ProcessRevNo

                         } );

    }

    #

    #   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 ("Create Package 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, 0, 1 );

    #

    #   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)

#

#                   Only allow a 'copy' if the local workspace is

#                   up to date with respect with the repo. It possible

#                   to do a 'commit' and then a 'copy' (tag) and have

#                   unexpected results as the workspace has not been

#                   updated. This is a trap.

#

#

# 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

#                       allowLocalMods  - True: Allow complex tagging

#

# Returns         : Revision of the copy

#

sub SvnCopyWs

{

    my $self = shift;

    my %opt = @_;

    my $rv;

    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*$~ );

    #

    #   Ensure the Workspace is up to date

    #       Determine the state of the Repo and the Workspace

    #

    $self->SvnInfo( $self->{WS} , 'InfoWs' );

    $self->SvnInfo( $self->FullWs, 'InfoRepo' );

    my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Workspace");

    my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Repository");

    Verbose("WS Rev  : $wsLastChangedRev");

    Verbose("Repo Rev: $repoLastChangedRev");

    Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',

           'Possibly caused by a commit without an update.',

           'Update the workspace and try again.',

           "Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );

    #

    #   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

    #   Assuming the WorkSpace is up to date then, 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.

    #

    #   If the Workspace is not up to date, then files that SVN thinks have not

    #   been transferred will be transferred - hence the need to update after

    #   a commit.

    #

    #   Moreover, files that are modified in the local workspace will

    #   be copied and checked into the target, but this is not nice.

    #

    $self->{PRINTDATA} = 1;

    $rv = $self->SvnCmd ( 'cp'  , $path

                        , $target

                        , '--parents'

                        , '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),

                        , { 'process' => \&ProcessRevNo,

                            'credentials' => 1, }

                        );

    $self->{PRINTDATA} = 0;

    if ($rv)

    {

        #

        #   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

#                       allowLocalMods - Only warn about local mods

#                       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 files 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 8 chars are status

            #       Remove WS path too

            #

            if ( length $entry >= 8 + $path_length)

            {

                my $file = substr ( $entry, 8 + $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;

        }

        if ( @unexpected )

        {

            if ( $opt{allowLocalMods} ) {

                Message ("Workspace contains locally modified files:", @unexpected);

            } else {

                Error ("Workspace contains unexpected modified files", @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

#

#                   Updates 'WS' and 'WSURL'

#

# 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() . '/' . $path

        unless ( $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;

        }

    }

    #

    #   Need to adjust the WSURL too

    #   Break into parts and pop them off as we go

    #   Add a dummy one to allow for the first iteration

    #

    my @wsurl = (split (/[\\\/]+/ , $self->{WSURL}), 'Dummy');

    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 );

        pop @wsurl;

        #

        #   Examine the parent directory

        #   Get a list of all elements in the parent

        #   Need to ensure that this directory is one of them

        #