WebSVN – DevTools – Diff – /core_devl/branches/dpurdie_devl/TOOLS/LIB/JatsSvn.pm



    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",

#                   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

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

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

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

#                   $user           - Optional prefix for error messages
#                   $test           - True: Just test, Else Error
#
# Returns         : Will not return if not a workspace
#                   Returns the users path
 
#                   Populates the hash: $self->{InfoWs}
#
sub SvnValidateWs
{
    my ($self, $user, $test) = @_;
    Debug ("SvnValidateWs");
 
    $user = "Invalid Subversion Workspace" unless ( $user );
    my $path = $self->{WS};
 
    #
    #   Only validate it once
    #
    return $path if ( $self->{WS_VALIDATED} );
 
    #
    #   Validate the source path

    } 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->SvnInfo($path, 'InfoWs');
 
        #
        #   Error. Prepend nice message
        #
        unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"

    my $self = NewSession();
    $self->{WS} = $path;
 
    #
    #   Validate the path provided
    #   In the process populate $self->{InfoWs} with info 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 = $self->{'InfoWs'}{'URL'};
    my $reporoot = $self->{'InfoWs'}{'Repository Root'};
    my $repoVersion = $self->{'InfoWs'}{'Revision'};
 
 
    Error ("JatsSvn Internal error. Can't parse info")
        unless ( $url && $reporoot );
 
    #
    #   Need the length of the path to the repository

Rev 1270	Rev 1328
Line 200...	Line 200...
200	`Debug ("SvnCi");`	200	`Debug ("SvnCi");`
201	`Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);`	201	`Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);`
202		202
203	`#`	203	`#`
204	`# Validate the source path`	204	`# Validate the source path`
205	`# Note: populates @{$self->{RESULT_LIST}} with 'info' commands`	205	`# Note: populates %{$self->{InfoWs}} with 'info' data`
206	`#`	206	`#`
207	`my $path = SvnValidateWs ($self, 'SvnCi');`	207	`my $path = SvnValidateWs ($self, 'SvnCi');`
208		208
209	`#`	209	`#`
210	`# Scan the @{$self->{RESULT_LIST}}, which has the results of an 'info'`	210	`# Examine %{$self->{InfoWs}}, which has the results of an 'info'`
211	`# command the locate the URL.`	211	`# command the locate the URL.`
212	`#`	212	`#`
213	`# This contains the target view space`	213	`# This contains the target view space`
214	`# Sanity test. Don't allow Checkin to a /tags/ area`	214	`# Sanity test. Don't allow Checkin to a /tags/ area`
215	`#`	215	`#`
216	`foreach ( @{$self->{RESULT_LIST}})`	216	`$status_url = $self->{InfoWs}{URL};`
217	`{`	-
218	`if ( m~^URL:\s+(.+)~ ) {`	-
219	`$status_url = $1;`	217	`$ws_rev = $self->{InfoWs}{Revision};`
220	`} elsif ( m~^Revision:\s+(\d+)~ ) {`	-
221	`$ws_rev = $1;`	-
222	`}`	-
223		-
224	`last if ( defined $status_url && defined $ws_rev );`	-
225	`}`	-
226		218
227	`Error ("SvnCi: Cannot determine Repositoty URL")`	219	`Error ("SvnCi: Cannot determine Repositoty URL")`
228	`unless ( $status_url );`	220	`unless ( $status_url );`
229		221
230	`Error ("SvnCi: Not allowed to commit to a 'tags' area", "URL: $status_url")`	222	`Error ("SvnCi: Not allowed to commit to a 'tags' area", "URL: $status_url")`
231	`if ( $status_url =~ m~/tags(/\|$)~ );`	223	`if ( $status_url =~ m~/tags(/\|$)~ );`
232		224
233	`#`	225	`#`
234	`# Commit`	226	`# Commit`
-		227	`# Will modify Repo, so kill the cached Info`
-		228	`# Will only be a real issue if we tag in the same session`
235	`#`	229	`#`
-		230	`delete $self->{'InfoWs'};`
-		231	`delete $self->{'InfoRepo'};`
-		232
236	`$self->SvnCmd ( 'commit', $path`	233	`$self->SvnCmd ( 'commit', $path`
237	`, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),`	234	`, '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),`
238	`, { 'credentials' => 1,`	235	`, { 'credentials' => 1,`
239	`'process' => \&ProcessRevNo,`	236	`'process' => \&ProcessRevNo,`
240	`'error' => "SvnCi: Copy Error",`	237	`'error' => "SvnCi: Copy Error",`
Line 561...	Line 558...
561	`# copied. This is a trap.`	558	`# copied. This is a trap.`
562	`#`	559	`#`
563	`# Only allow a 'copy' if there are no modified`	560	`# Only allow a 'copy' if there are no modified`
564	`# files in the work space (unless overridden)`	561	`# files in the work space (unless overridden)`
565	`#`	562	`#`
-		563	`# Only allow a 'copy' if the local workspace is`
-		564	`# up to date with respect with the repo. It possible`
-		565	`# to do a 'commit' and then a 'copy' (tag) and have`
-		566	`# unexpected results as the workspace has not been`
-		567	`# updated. This is a trap.`
-		568	`#`
566	`#`	569	`#`
567	`# Inputs : $self - Instance data`	570	`# Inputs : $self - Instance data`
568	`# A hash of named arguments`	571	`# A hash of named arguments`
569	`# path - Path to local workspace`	572	`# path - Path to local workspace`
570	`# target - Location within the repository to copy to`	573	`# target - Location within the repository to copy to`
Line 602...	Line 605...
602	`#`	605	`#`
603	`Error ("SvnCopyWs: Target contains a Peg: ($1)", $target)`	606	`Error ("SvnCopyWs: Target contains a Peg: ($1)", $target)`
604	`if ( $target =~ m~(@\d+)\s*$~ );`	607	`if ( $target =~ m~(@\d+)\s*$~ );`
605		608
606	`#`	609	`#`
-		610	`# Ensure the Workspace is up to date`
-		611	`# Determine the state of the Repo and the Workspace`
-		612	`#`
-		613	`$self->SvnInfo( $self->{WS} , 'InfoWs' );`
-		614	`$self->SvnInfo( $self->FullWs, 'InfoRepo' );`
-		615
-		616	`my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} \|\| Error ("SvnCopyWs: Bad info for Workspace");`
-		617	`my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} \|\| Error ("SvnCopyWs: Bad info for Repository");`
-		618
-		619	`Verbose("WS Rev : $wsLastChangedRev");`
-		620	`Verbose("Repo Rev: $repoLastChangedRev");`
-		621
-		622	`Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',`
-		623	`'Possibly caused by a commit without an update.',`
-		624	`'Update the workspace and try again.',`
-		625	`"Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );`
-		626
-		627	`#`
607	`# Examine the workspace and ensure that there are no modified`	628	`# Examine the workspace and ensure that there are no modified`
608	`# files - unless they are expected`	629	`# files - unless they are expected`
609	`#`	630	`#`
610	`$self->SvnWsModified ( 'cmd' => 'SvnCopyWs', %opt );`	631	`$self->SvnWsModified ( 'cmd' => 'SvnCopyWs', %opt );`
611		632
Line 620...	Line 641...
620	`'comment' => 'Deleted by SvnCopyWs'`	641	`'comment' => 'Deleted by SvnCopyWs'`
621	`);`	642	`);`
622		643
623	`#`	644	`#`
624	`# Copy source to destination`	645	`# Copy source to destination`
625	`# It would appear that even though the source is a WorkSpace, the copy`	646	`# Assuming the WorkSpace is up to date then, even though the source is a`
626	`# does not transfer data from the WorkSpace. It appears as though its all`	647	`# WorkSpace, the copy does not transfer data from the WorkSpace.`
627	`# done on the server. This is good - and fast.`	648	`# It appears as though its all done on the server. This is good - and fast.`
-		649	`#`
-		650	`# If the Workspace is not up to date, then files that SVN thinks have not`
-		651	`# been transferred will be transferred - hence the need to update after`
-		652	`# a commit.`
628	`#`	653	`#`
629	`# Moreover, files that are modified in the local workspace will`	654	`# Moreover, files that are modified in the local workspace will`
630	`# be copied and checked into the target, but this is not nice.`	655	`# be copied and checked into the target, but this is not nice.`
631	`#`	656	`#`
632	`$self->{PRINTDATA} = 1;`	657	`$self->{PRINTDATA} = 1;`
Line 762...	Line 787...
762	`#`	787	`#`
763	`# Extract filename from line`	788	`# Extract filename from line`
764	`# First 8 chars are status`	789	`# First 8 chars are status`
765	`# Remove WS path too`	790	`# Remove WS path too`
766	`#`	791	`#`
-		792	`if ( length $entry >= 8 + $path_length)`
-		793	`{`
767	`my $file = substr ( $entry, 8 + $path_length );`	794	`my $file = substr ( $entry, 8 + $path_length );`
768	`next if ( $allowed{$file} );`	795	`next if ( $allowed{$file} );`
-		796	`}`
769		797
770	`#`	798	`#`
771	`# Examine the first char and rule out funny things`	799	`# Examine the first char and rule out funny things`
772	`#`	800	`#`
773	`my $f1 = substr ($entry, 0,1 );`	801	`my $f1 = substr ($entry, 0,1 );`
Line 1002...	Line 1030...
1002	`# $user - Optional prefix for error messages`	1030	`# $user - Optional prefix for error messages`
1003	`# $test - True: Just test, Else Error`	1031	`# $test - True: Just test, Else Error`
1004	`#`	1032	`#`
1005	`# Returns : Will not return if not a workspace`	1033	`# Returns : Will not return if not a workspace`
1006	`# Returns the users path`	1034	`# Returns the users path`
1007	`# @{$self->{RESULT_LIST}} will be populated with info about the`	-
1008	`# item requested as per an 'info' call`	1035	`# Populates the hash: $self->{InfoWs}`
1009	`#`	1036	`#`
1010	`sub SvnValidateWs`	1037	`sub SvnValidateWs`
1011	`{`	1038	`{`
1012	`my ($self, $user, $test) = @_;`	1039	`my ($self, $user, $test) = @_;`
1013	`Debug ("SvnValidateWs");`	1040	`Debug ("SvnValidateWs");`
1014		1041
1015	`$user = "Invalid Subversion Workspace" unless ( $user );`	1042	`$user = "Invalid Subversion Workspace" unless ( $user );`
1016	`my $path = $self->{WS} ;`	1043	`my $path = $self->{WS};`
1017		1044
1018	`#`	1045	`#`
1019	`# Only validate it one`	1046	`# Only validate it once`
1020	`#`	1047	`#`
1021	`return $path if ( $self->{WS_VALIDATED} );`	1048	`return $path if ( $self->{WS_VALIDATED} );`
1022		1049
1023	`#`	1050	`#`
1024	`# Validate the source path`	1051	`# Validate the source path`
Line 1035...	Line 1062...
1035	`} else {`	1062	`} else {`
1036	`#`	1063	`#`
1037	`# Determine the source path is an fact a view`	1064	`# Determine the source path is an fact a view`
1038	`# The info command can do this. Use depth empty to limit the work done`	1065	`# The info command can do this. Use depth empty to limit the work done`
1039	`#`	1066	`#`
1040	`$self->SvnCmd ('info', $path, '--depth', 'empty' );`	1067	`$self->SvnInfo($path, 'InfoWs');`
1041		1068
1042	`#`	1069	`#`
1043	`# Error. Prepend nice message`	1070	`# Error. Prepend nice message`
1044	`#`	1071	`#`
1045	`unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"`	1072	`unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"`
Line 1224...	Line 1251...
1224	`my $self = NewSession();`	1251	`my $self = NewSession();`
1225	`$self->{WS} = $path;`	1252	`$self->{WS} = $path;`
1226		1253
1227	`#`	1254	`#`
1228	`# Validate the path provided`	1255	`# Validate the path provided`
1229	`# In the process populate the @{$self->{RESULT_LIST}} with information`	1256	`# In the process populate $self->{InfoWs} with info about the workspace.`
1230	`# about the workspace.`	-
1231	`#`	1257	`#`
1232	`if ($self->SvnValidateWs ( undef, 1) )`	1258	`if ($self->SvnValidateWs ( undef, 1) )`
1233	`{`	1259	`{`
1234	`return $self if ( $test );`	1260	`return $self if ( $test );`
1235	`Error ( @{$self->{ERROR_LIST}} );`	1261	`Error ( @{$self->{ERROR_LIST}} );`
Line 1238...	Line 1264...
1238	`#`	1264	`#`
1239	`# Extract useful info`	1265	`# Extract useful info`
1240	`# URL: svn://auperaws996vm21/test/MixedView/trunk`	1266	`# URL: svn://auperaws996vm21/test/MixedView/trunk`
1241	`# Repository Root: svn://auperaws996vm21/test`	1267	`# Repository Root: svn://auperaws996vm21/test`
1242	`#`	1268	`#`
1243	`my $url;`	-
1244	`my $reporoot;`	-
1245	`my $repoVersion;`	-
1246		-
1247	`foreach ( @{$self->{RESULT_LIST}} )`	-
1248	`{`	-
1249	`$url = $1 if ( m~^URL:\s+(.+)~ );`	1269	`my $url = $self->{'InfoWs'}{'URL'};`
1250	`$reporoot = $1 if ( m~^Repository Root:\s+(.+)~ );`	1270	`my $reporoot = $self->{'InfoWs'}{'Repository Root'};`
1251	`$repoVersion = $1 if ( m~^Revision:\s+(.+)~ );`	1271	`my $repoVersion = $self->{'InfoWs'}{'Revision'};`
1252	`last if ( $url && $reporoot && $repoVersion);`	-
1253	`}`	1272
1254	`Error ("JatsSvn Internal error. Can't parse info")`	1273	`Error ("JatsSvn Internal error. Can't parse info")`
1255	`unless ( $url && $reporoot );`	1274	`unless ( $url && $reporoot );`
1256		1275
1257	`#`	1276	`#`
1258	`# Need the length of the path to the repository`	1277	`# Need the length of the path to the repository`

Subversion Repositories DevTools

(root)/core_devl/branches/dpurdie_devl/TOOLS/LIB/JatsSvn.pm – Rev 1270 → 1328