Subversion Repositories DevTools

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

# Copyright (C) 2008 ERG Limited, All rights reserved

#

# Module name   : JatsSvnCore.pm

# Module type   : Jats Support Module

# Compiler(s)   : Perl

# Environment(s): jats

#

# Description   : JATS LowLevel 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;

use JatsEnv;

#

#   Global Variables

#   Configuration variables imported from environment

#   Must be 'our' to work with EnvImport

#

our $GBE_SVN_PATH;                      # Optional: SVN bin directory

our $GBE_SVN_USERNAME;                  # Optional: User name

our $GBE_SVN_PASSWORD;                  # Optional: User passwrd

package JatsSvnCore;

use JatsError;

use JatsSystem;

use IPC::Open3;

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

@EXPORT      = qw(

                    SvnSession

                    SvnUserCmd

                    SvnComment

                );

@EXPORT_OK =  qw(

                    ProcessRevNo

                );

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

#

#   Package Global

#

my $svn;                                # Abs path to 'svn' utility

my $stdmux;                             # Abs path to stdmux utlity

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

# Function        : BEGIN

#

# Description     : Module Initialization

#                   Invoked by Perl as soon as possible

#                       Setup environment variables

#                       Calculate globals

#

# Inputs          : None

#

# Returns         : Nothing

#

sub BEGIN

{

    #

    #   Determine authentication information

    #   If not present then assume that the user is already athenticated

    #

    ::EnvImportOptional('GBE_SVN_USERNAME');

    ::EnvImportOptional('GBE_SVN_PASSWORD');

    #

    #   User can provide a path to the svn utility

    #   It will be used if its present

    #

    ::EnvImportOptional('GBE_SVN_PATH', '');

    $stdmux = LocateProgInPath ( 'stdmux');

    Error ("The JATS stdmux utility cannot be found" ) unless ( $stdmux );

    $svn = LocateProgInPath ( 'svn', '--All', '--Path=' . $::GBE_SVN_PATH );

    Error ("The svn utility cannot be found", "Configured Path: $GBE_SVN_PATH") unless ( $svn );

}

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

# Function        : SvnSession

#

# Description     : Create a new SvnSession

#                   Simply used to contain information about the operations

#

# Inputs          : Nothing

#

# Returns         : A blessed ref

#

sub SvnSession

{

    my $self = {};

    #

    #   Documented instance variables

    #

    $self->{REVNO} = undef;         # Revision of last Repository operation

    $self->{ERROR_LIST} = [];       # Last SVN operation errors

    $self->{RESULT_LIST} = [];      # Last SVN operation results

    $self->{PRINTDATA} = 0;         # Global control of ProcessRevNo

    bless ($self, __PACKAGE__);

}

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

# Function        : SvnDelete

#

# Description     : Delete a directory within a repostory

#                   Intended to be used to remove tags and branches

#

# Inputs          : $self       - Instance data

#                   A hash of named arguments

#                       target     - Path to remove

#                       comment    - User comment

#                       noerror    - Don't panic on failure

#

#

# Returns         : True - delete failed and 'noerror' was present

#

sub SvnDelete

{

    my $self = shift;

    my %opt = @_;

    Debug ("SvnDelete");

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

    Error ("SvnDelete: No target specified" ) unless ( $opt{'target'} );

    my $error =  $opt{'noerror'} ? '' : "SvnDelete: Target not deleted";

    my $rv = SvnCmd ($self, 'delete'

                    , $opt{'target'}

                    , '-m', SvnComment( $opt{'comment'}, 'Deleted by SvnDelete' ),

                    , { 'credentials' => 1,

                        'error' => $error } );

    return $rv;

}

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

# Function        : SvnRename

#

# Description     : Rename something within a repository

#                   Intended to be used to rename tags and branches

#

#                   A few tricks

#                   - Rename is the same as a copy-delete

#                     but it doesn't work if the source is pegged

#                     so we just use a copy.

#                   - Need to ensure the target does not exist

#                     because if it does then we may create a subdir

#                     within it.

#

# Inputs          : $self           - Instance data

#                   A hash of named arguments

#                       old      - Location within the repository to copy from

#                       new      - Location within the repository to copy to

#                       comment  - Commit comment

#                       revision - ref to returned revision tag

#                       tag      - ref to URL of the Check In

#                       replace  - True: Delete existing tag if present

#

# Returns         : Revision of the copy

#

sub SvnRename

{

    my $self = shift;

    my %opt = @_;

    Debug ("SvnRename");

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

    #

    #   Insert defaults

    #

    my $old = $opt{old} || Error ("SvnRename: Source not specified" );

    my $new = $opt{new} || Error ("SvnRename: Target not specified" );

    #

    #   Validate the source

    #   Must do this in case the target-delete fails

    #

    SvnValidateTarget ( $self,

                        'cmd'    => 'SvnRename',

                        'target' => $old,

                        'require' => 1,

                        );

    #

    #   Validate the target

    #   Repo needs to be valid, but we may be able

    #   to delete the target if it does exist

    #

    SvnValidateTarget ( $self,

                        'target' => $new,

                        'delete' => $opt{replace},

                        );

    #

    #   The 'rename' command does not handle a pegged source

    #   Detect this and use a 'copy' command

    #   We don't need to delete the source - as its pegged.

    #

    my $cmd = ($old =~ m~@\d+$~) ? 'copy' : 'rename';

    SvnCmd ($self, $cmd

                    , $old

                    , $new

                    , '-m', SvnComment($opt{'comment'},'Renamed by SvnRename'),

                    , { 'credentials' => 1,

                        'process' => \&ProcessRevNo

                      , 'error' => "SvnRename: Target not renamed" } );

    CalcRmReference($self, $new );

    Message ("Tag is: " . $self->{RMREF} );

    return $self->{RMREF} ;

}

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

# Function        : SvnCopy

#

# Description     : Copy something within a repository

#                   Intended to be used to copy tags and branches

#

#                   A few tricks

#                   - Need to ensure the target does not exist

#                     because if it does then we may create a subdir

#                     within it.

#

# Inputs          : $self           - Instance data

#                   A hash of named arguments

#                       old         - Location within the repository to copy from

#                       new         - Location within the repository to copy to

#                       comment     - Commit comment

#                       revision    - ref to returned revision tag

#                       tag         - ref to URL of the Check In

#                       replace     - True: Delete existing tag if present

#                       cmd         - Error Prefix

#                       validated   - Locations already validated

#

# Returns         : Revision of the copy

#

sub SvnCopy

{

    my $self = shift;

    my %opt = @_;

    Debug ("SvnCopy");

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

    #

    #   Insert defaults

    #

    my $cmd = $opt{'cmd'} || 'SvnCopy';

    my $old = $opt{old} || Error ("$cmd: Source not specified" );

    my $new = $opt{new} || Error ("$cmd: Target not specified" );

    #

    #   Validate the source

    #   Must do this in case the target-delete fails

    #

    SvnValidateTarget ( $self,

                        'cmd'    => $cmd,

                        'target' => $old,

                        'require' => 1,

                        );

    #

    #   Validate the target

    #   Repo needs to be valid, but we may be able

    #   to delete the target if it does exist

    #

    SvnValidateTarget ( $self,

                        'cmd'    => $cmd,

                        'target' => $new,

                        'delete' => $opt{replace},

                        );

    #

    #   Copy the URLs

    #

    SvnCmd ($self   , 'copy'

                    , $old

                    , $new

                    , '-m', SvnComment($opt{'comment'},"Copied by $cmd"),

                    , { 'credentials' => 1

                      , 'process' => \&ProcessRevNo

                      , 'error' => "$cmd: Source not copied" } );

    CalcRmReference($self, $new );

    Message ("Tag is: " . $self->{RMREF} );

    return $self->{RMREF} ;

}

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

# Function        : SvnValidateTarget

#

# Description     : Validate a target within the repository

#                   Optional allow the target to be deleted

#                   Mostly used internally

#

# Inputs          : $self           - Instance data

#                   A hash of named arguments

#                       target      - Location within the repository to test

#                       cmd         - Name of command to use in messages

#                       delete      - Delete if it exists

#                       require     - Target must exist

#                       available   - Target must NOT exist

#                       comment     - Deletion comment

#                       test        - Just test existance

#

# Returns         : May not return

#                   True : Exists

#                   False: Not exist (any more)

#

sub SvnValidateTarget

{

    my $self = shift;

    my %opt = @_;

    Debug ("SvnValidateTarget", $opt{target});

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

    #

    #   Validate options

    #

    Error ("SvnValidateTarget: No target specified") unless ( $opt{target} );

    $opt{cmd} = "SvnValidateTarget" unless ( $opt{cmd} );

    my $cmd = $opt{cmd};

    #

    #   Ensure that the target path does not exist

    #   Cannot allow a 'copy'/'rename' to copy into an existing path as

    #   Two problems:

    #       1) We end up copying the source into a subdir of

    #          target path, which is not what we want.

    #       2) Should use update to do that sort of a job

    #

    unless ( SvnTestPath ( $self, $cmd, $opt{target} ))

    {

        #

        #   Target does not exist

        #

        return 0 if ( $opt{'test'} || $opt{'available'} );

        Error ("$cmd: Element does not exist", "Element: $opt{target}")

            if ( $opt{'require'} );

    }

    else

    {

        #

        #    Target DOES exist

        #       - Good if the user requires the target

        #       - Error unless the user is prepared to delete it

        #

        return 1

                if ( $opt{'require'} || $opt{'test'} );

        Error ("$cmd: Element exists", "Element: $opt{target}")

            unless ( $opt{'delete'} );

        #

        #   The user has requested that an existing target be deleted

        #

        SvnCmd ($self, 'delete'

                        , $opt{target}

                        , '-m', SvnComment($opt{'comment'},"Deleted by $cmd"),

                        , { 'credentials' => 1,

                            'error' => "$cmd: Element not deleted" } );

    }

    return 0;

}

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

# Function        : ProcessRevNo

#

# Description     : Callback function for SvnCmd to Extract a revision number

#                   from the svn command output stream

#

# Inputs          : $self           - Instance data

#                   $line           - Command output

#

#                   Globals:

#

# Returns         : zero - we don't want to kill the command

#

sub ProcessRevNo

{

    my ($self, $line ) = @_;

    if ( $line =~ m~Committed revision\s+(\d+)\.~i )

    {

        $self->{REVNO} = $1;

    } elsif ( $self->{PRINTDATA} ) {

        Message ( $line ) if $line;

    }

    return 0;

}

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

# Function        : SvnScanPath

#

# Description     : Internal helper function

#                   Scan a directory and split contents into three groups

#

# Inputs          : $self               - Instance data

#                   $cmd                - Command prefix for errros

#                   $path               - Path to test

#

# Returns         : $ref_files          - Ref to array of files

#                   $ref_dirs           - Ref to array of dirs

#                   $ref_svn            - Ref to array of svn dirs

#                   $found              - True: Path found

#

sub SvnScanPath

{

    my $self = shift;

    my ($cmd, $path) = @_;

    my @files;

    my @dirs;

    my @svn;

    Debug ("SvnScanPath");

    Verbose2 ("SvnScanPath: $path");

    #

    #   Read in the directory information

    #   Just one level. Gets files and dirs

    #

    if ( ! SvnTestPath( $self, $cmd, $path, 1 ) )

    {

        #

        #   Path does not exist

        #

        return \@files, \@dirs, \@svn, 0;

    }

    #

    #   Path exists

    #   Sort into three sets

    #       - Svn Directories

    #       - Other Directories

    #       - Files

    #

    foreach ( @{$self->{RESULT_LIST}} )

    {

        if ( $_ eq 'trunk/' || $_ eq 'tags/' || $_ eq 'branches/' ) {

            push @svn, $_;

        } elsif ( substr ($_, -1) eq '/' ) {

            push @dirs, $_;

        } else {

            push @files, $_;

        }

    }

    return \@files, \@dirs, \@svn, 1;

}

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

# Function        : SvnTestPath

#

# Description     : Internal helper function

#                   Test a path within the Repo for existance

#                   Optionally read in immediate directory data

#

# Inputs          : $self               - Instance data

#                   $cmd                - Command prefix for errros

#                   $path               - Path to test

#                   $mode               - True: Read in immediate data

#

# Returns         : True  : Path found

#                   False : Path is non-existent in revision

#

#                   May populate @RESULT_LIST with 'immediate' data

#

sub SvnTestPath

{

    my $self = shift;

    my ($cmd, $path, $mode) = @_;

    my $depth = $mode ? 'immediates' : 'empty';

    Debug ("SvnTestPath", @_);

    #

    #   Read in the directory information - but no data

    #

    if ( SvnCmd ( $self, 'list', $path

                        , '--depth', $depth

                        , {'credentials' => 1,}

                        ))

    {

        #

        #   Error occurred

        #   If the path does not exist then this is an error that

        #   we can handle. The path does nto exist in the Repository

        #

        return 0

            if (    $self->{ERROR_LIST}[0] =~ m~' non-existent in that revision$~

                 || $self->{ERROR_LIST}[0] =~ m~: No repository found in '~

                 || $self->{ERROR_LIST}[0] =~ m~: Error resolving case of '~

                );

        Error ("$cmd: Unexpected error", @{$self->{ERROR_LIST}});

    }

    return 1;

}

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

# Function        : CalcRmReference

#

# Description     : Determine the Release Manager Reference for a SVN

#                   operation

#

# Inputs          : $self                   - Instance data

#                   $target                 - target

#                   $self->{REVNO}          - Revision number

#

# Returns         : RMREF - String Reference

#

sub CalcRmReference

{

    my ($self, $target) = @_;

    Debug ("CalcRmReference");

    Error ("CalcRmReference: No Target") unless ( $target );

    #

    #   Take target and remove the reference to the local repository,

    #   if its present. This will provide a ref that we can use on any site

    #

    #   Note: GBE_SVN_URL will have a trailing '/'

    #

    $target .= '@' . $self->{REVNO} if $self->{REVNO};

    $target =~ s~^\Q$::GBE_SVN_URL\E~~ if ( $::GBE_SVN_URL );

    return $self->{RMREF} = $target;

}

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

# Function        : SvnComment

#

# Description     : Create a nice SVN comment from a string or an array

#

# Inputs          : user            - User comment

#                   default         - Default comment

#

#                   Comments may be:

#                       1) A string - Simple

#                       2) An array

#

# Returns         : A string comment

#

sub SvnComment

{

    my ($user, $default) = @_;

    $user = $default unless ( $user );

    return '' unless ( $user );

    my $type = ref $user;

    if ( $type eq '' ) {

        return $user;

    } elsif ( $type eq 'ARRAY' ) {

        return join ("\n", @{$user});

    } else {

        Error ("Unknown comment type: $type");

    }

}

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

# Function        : SvnCredentials

#

# Description     : Return an array of login credentials

#                   Used to extend command lines where repository access

#                   is required.

#

#                   There are security implications in using EnvVars

#                   to contain passwords. Its best to avoid their use

#                   and to let cached authentication from a user-session

#                   handle the process.

#

# Inputs          : None

#

# Returns         : An array - may be empty

#

sub SvnCredentials

{

    my @result;

    if ( $::GBE_SVN_USERNAME )

    {

        push @result, '--no-auth-cache';

        push @result, '--username', $::GBE_SVN_USERNAME;

        push @result, '--password', $::GBE_SVN_PASSWORD if ($::GBE_SVN_PASSWORD);

    }

    return @result;

}

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

# Function        : SvnCmd

#

# Description     : Run a Subversion Command and capture/process the

#                   output

#

#                   See also SvnUserCmd

#

# Inputs          : $self           - Instance data

#                   Command arguments

#                   Last argument may be a hash of options.

#                       credentials - Add credentials

#                       nosavedata  - Don't save the data

#                       process     - Callback function

#                       error       - Error Message

#                                     Used as first line of an Error call

#

# Returns         : non-zero on errors detected

#

sub SvnCmd

{

    my $self = shift;

    Debug ("SvnCmd");

    #

    #   Extract arguments and options

    #   If last argument is a hesh, then its a hash of options

    #

    my $opt;

    $opt = pop @_

        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));

    #

    #   All commands are non-interactive, prepend argument

    #

    unshift @_, '--non-interactive';

    Verbose2 "SvnCmd $svn @_";

    #

    #   Prepend credentials, but don't show to users

    #

    unshift @_, SvnCredentials() if ( $opt->{'credentials'} );

    #

    # Useful debugging

    #

    # $self->{LAST_CMD} = [$svn, @_];

    #

    #   Reset command output data

    #

    $self->{ERROR_LIST} = [];

    $self->{RESULT_LIST} = [];

    #

    #   Make use of a wrapper program to mux the STDERR and STDOUT into

    #   one stream (STDOUT). #   This solves a lot of problems

    #

    #   Do not use IO redirection of STDERR because as this will cause a

    #   shell (sh or cmd.exe) to be invoked and this makes it much

    #   harder to kill on all platforms.

    #

    #   Use open3 as it allows the arguments to be passed

    #   directly without escaping and without any shell in the way

    #

    local (*CHLD_OUT, *CHLD_IN);

    my $pid = open3( \*CHLD_IN, \*CHLD_OUT, '>&STDERR', $stdmux, $svn, @_);

    #

    #   Looks as though we always get a PID - even if the process dies

    #   straight away or can't be found. I suspect that open3 doesn't set

    #   $! anyway. I know it doesn't set $?

    #

    Debug ("Pid: $pid");

    Error ("Can't run command: $!") unless $pid;

    #

    #   Close the input handle

    #   We don't have anything to send to this program

    #

    close(CHLD_IN);

    #

    #   Monitor the output from the utility

    #   Have used stdmux to multiplex stdout and stderr

    #

    #   Note: IO::Select doesn't work on Windows :(

    #   Note: Open3 will cause blocking unless both streams are read

    #         Can read both streams becsue IO::Select doesn't work

    #

    #   Observation:

    #       svn puts errors to STDERR

    #       svn puts status to STDOUT

    #

    while (<CHLD_OUT>)

    {

        s~\s+$~~;

        tr~\\/~/~;

        Verbose3 ( "SvnCmd:" . $_);

        m~^STD(...):(.+)~;

        my $data = $1 ? $2 : $_;

        next unless ( $data );

        if ( $1 && $1 eq 'ERR' )

        {

            #

            #   Process STDERR output

            #

            push @{$self->{ERROR_LIST}}, $data;

        }

        else

        {

            #

            #   Process STDOUT data

            #

            push @{$self->{RESULT_LIST}}, $data unless ($opt->{'nosavedata'});

            #

            #   If the user has specified a processing function then pass each

            #   line to the specified function.  A non-zero return will

            #   be taken as a signal to kill the command.

            #

            if ( exists ($opt->{'process'}) && $opt->{'process'}($self, $data) )

            {

                kill 9, $pid;

                last;

            }

        }

    }

    close(CHLD_OUT);

    #

    #   MUST wait for the process

    #   Under Windows if this is not done then we eventually fill up some

    #   perl-internal structure and can't spawn anymore processes.

    #

    my $rv = waitpid ( $pid, 0);

    #

    #   If an error condition was detected and the user has provided

    #   an error message, then display the error

    #

    #   This simplifies the user error processing

    #

    if ( @{$self->{ERROR_LIST}} && $opt->{'error'}  )

    {

        Error ( $opt->{'error'}, @{$self->{ERROR_LIST}} );

    }

    #

    #   Exit status has no meaning since open3 has been used

    #   This is because perl does not treat the opened process as a child

    #   Not too sure it makes any difference anyway

    #

    #

    Debug ("Useless Exit Status: $rv");

    my $result = @{$self->{ERROR_LIST}} ? 1 : 0;

    Verbose3 ("Exit Code: $result");

    return $result;

}

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

# Function        : SvnUserCmd

#

# Description     : Run a Subversion Command for interactive user

#                   Intended to be used interactive

#                   No data captured or processed

#                   See also SvnCmd

#

# Inputs          : Command arguments

#                   Last argument may be a hash of options.

#                       credentials - Add credentials

#

# Returns         : Result code of the SVN command

#

sub SvnUserCmd

{

    #

    #   Extract arguments and options

    #   If last argument is a hesh, then its a hash of options

    #

    my $opt;

    $opt = pop @_

        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));

    Verbose2 "SvnUserCmd $svn @_";

    #

    #   Prepend credentials, but don't show to users

    #

    unshift @_, SvnCredentials() if ( $opt->{'credentials'} );

    #

    #   Run the command

    #

    my $rv = system( $svn, @_ );

    Verbose2 "System Result Code: $rv";

    Verbose2 "System Result Code: $!" if ($rv);

     return $rv / 256;

}

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

1;