Rev 297 | Rev 353 | 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 : 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 directoryour $GBE_SVN_USERNAME; # Optional: User nameour $GBE_SVN_PASSWORD; # Optional: User passwrdpackage JatsSvnCore;use JatsError;use JatsSystem;use IPC::Open3;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);@EXPORT = qw(SvnSessionSvnUserCmdSvnComment);@EXPORT_OK = qw(ProcessRevNo);%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);## Package Global#my $svn; # Abs path to 'svn' utilitymy $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', '');## For some reason thats not clear these EnvVars must be used in this function# for them to be available elsewhere.## No it doesn't make sence to me either# Problem seen on Linx. Not investigated on others#Debug ("GBE_SVN_USERNAME", $::GBE_SVN_USERNAME);Debug ("GBE_SVN_PASSWORD", $::GBE_SVN_PASSWORD);Debug ("GBE_SVN_PATH", $::GBE_SVN_PATH);$stdmux = LocateProgInPath ( 'stdmux');$svn = LocateProgInPath ( 'svn', '--All', '--Path=' . $::GBE_SVN_PATH );}#-------------------------------------------------------------------------------# 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 = {};## Delayed error reporting# Allows the the package to be used when SVN is not installed# as long as we don't want to use any of the features## Think of 'help' when svn is not yet installed#Error ("The JATS stdmux utility cannot be found" ) unless ( $stdmux );Error ("The svn utility cannot be found", "Configured Path: $::GBE_SVN_PATH") unless ( $svn );## 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 ProcessRevNobless ($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 1if ( $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 0if ( $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;