Subversion Repositories DevTools

Rev

Rev 1349 | Rev 1380 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
267 dpurdie 1 
########################################################################
2 
# Copyright (C) 2008 ERG Limited, All rights reserved
3 
#
4 
# Module name   : jats.sh
5 
# Module type   : Makefile system
6 
# Compiler(s)   : n/a
7 
# Environment(s): jats
8 
#
9 
# Description   : JATS Subversion Interface Functions
10 
#
11 
#                 Requires a subversion client to be present on the machine
12 
#                 Does require at least SubVersion 1.5
13 
#                 Uses features not available in 1.4
14 
#
15 
#                 The package currently implements a set of functions
16 
#                 There are some intentional limitations:
17 
#                   1) Non recursive
18 
#                   2) Errors terminate operation
19 
#
20 
#                 This package contains experimental argument passing
21 
#                 processes. Sometimes use a hash of arguments
22 
#
23 
#......................................................................#
24 
 
25 
require 5.008_002;
26 
use strict;
27 
use warnings;
341 dpurdie 28 
our $USER;
267 dpurdie 29 
use JatsEnv;
30 
 
31 
package JatsSvn;
32 
 
33 
use JatsError;
34 
use JatsSystem;
35 
use JatsSvnCore qw(:All);
36 
 
37 
use File::Path;             # Instead of FileUtils
38 
use File::Basename;
39 
use Cwd;
40 
 
41 
 
42 
# automatically export what we need into namespace of caller.
43 
use Exporter();
44 
our (@ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK);
45 
@ISA         = qw(Exporter JatsSvnCore);
46 
 
47 
@EXPORT      = qw(
48 
                    NewSession
49 
                    NewSessionByWS
50 
                    NewSessionByUrl
51 
 
52 
                    SvnRmView
53 
                    SvnIsaSimpleLabel
54 
                    SvnComment
55 
 
56 
                    SvnUserCmd
361 dpurdie 57 
 
58 
                    SvnPath2Url
369 dpurdie 59 
                    SvnPaths
267 dpurdie 60 
                );
61 
@EXPORT_OK =  qw(
62 
                );
63 
 
64 
%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);
65 
 
66 
#
67 
#   Global Variables
68 
#
69 
 
70 
#-------------------------------------------------------------------------------
71 
# Function        : SvnCo
72 
#
73 
# Description     : Create a workspace
74 
#                   Can be used to extract files, without creating the
75 
#                   subversion control files.
76 
#
1345 dpurdie 77 
# Inputs          : $self                   - Instance data
78 
#                   $RepoPath               - Within the repository
79 
#                   $Path                   - Local path
1356 dpurdie 80 
#                   Hash of Options
81 
#                           export          - Bool: Export Only
82 
#                           force           - Bool: Force export to overwrite
83 
#                           print           - Bool: Don't print files exported
84 
#                           pretext=aa      - Text: Display before operation
267 dpurdie 85 
#
86 
# Returns         : Nothing
87 
#
88 
sub SvnCo
89 
{
1356 dpurdie 90 
    my $self = shift;
91 
    my $RepoPath = shift;
92 
    my $path = shift;
93 
    my %opt = @_;
94 
 
341 dpurdie 95 
    Debug ("SvnCo", $RepoPath, $path);
1356 dpurdie 96 
    Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);
267 dpurdie 97 
 
1356 dpurdie 98 
    #
99 
    #   Set some defaults
100 
    #
101 
    my $cmd = $opt{export} ? 'export' : 'checkout';
102 
    my $print = exists $opt{print} ? $opt{print} : 1;
103 
    $self->{CoText} =  $opt{pretext} || 'Extracting';
1345 dpurdie 104 
 
267 dpurdie 105 
    #
106 
    #   Ensure that the output path does not exist
107 
    #   Do not allow the user to create a local work space
108 
    #   where one already exists
109 
    #
110 
    Error ("SvnCo: No PATH specified" ) unless ( $path );
1356 dpurdie 111 
    Error ("SvnCo: Target path already exists", "Path: " . $path ) if ( ! $opt{force} && -e $path  );
267 dpurdie 112 
 
113 
    #
114 
    #   Build up the command line
115 
    #
1345 dpurdie 116 
    my @args = $cmd;
267 dpurdie 117 
    push @args, qw( --ignore-externals );
1356 dpurdie 118 
    push @args, qw( --force ) if ( $opt{force} );
267 dpurdie 119 
    push @args, $RepoPath, $path;
120 
 
121 
    my @co_list;
122 
    if ( $self->SvnCmd ( @args,
123 
                            {
124 
                                'process' => \&ProcessCo,
125 
                                'data' => \@co_list,
126 
                                'credentials' => 1,
127 
                                'nosavedata' => 1,
1348 dpurdie 128 
                                'printdata' => $print,
267 dpurdie 129 
                            }
130 
                       ) || @co_list )
131 
    {
132 
        #
133 
        #   We have a checkout limitation
134 
        #   Delete the workspace and then report the error
135 
        #
385 dpurdie 136 
        #   Note: For some reason a simple rmtree doesn't work
137 
        #         Nor does glob show all the directories
138 
        #
267 dpurdie 139 
        Verbose2 ("Remove WorkSpace: $path");
140 
        rmtree( $path, IsVerbose(3) );
385 dpurdie 141 
        rmtree( $path, IsVerbose(3) );
267 dpurdie 142 
        Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );
143 
    }
144 
    return;
145 
 
146 
    #
147 
    #   Internal routine to scan each the checkout
148 
    #
149 
    #   Due to the structure of a SubVersion repository it would be
150 
    #   possible for a user to extract the entire repository. This is
151 
    #   not good as the repo could be very very large
152 
    #
153 
    #   Assume that the structure of the repo is such that our
154 
    #   user is not allowed to extract a directory tree that contains
155 
    #   key paths - such as /tags/ as this would indicate that they are
156 
    #   attempting to extract something that is not a package
157 
    #
158 
    #
159 
    sub ProcessCo
160 
    {
161 
        my $self = shift;
1270 dpurdie 162 
        my $data = shift;
163 
 
164 
        if ( $self->{PRINTDATA} )
267 dpurdie 165 
        {
1270 dpurdie 166 
            #
167 
            #   Pretty display for user
1349 dpurdie 168 
            #   Hide some noise, but not much
1270 dpurdie 169 
            #
1349 dpurdie 170 
            unless ( $data =~ m~^Export complete.~ )
171 
            {
172 
                Information1 ( $self->{CoText} . ': ' . $data);
173 
            }
1270 dpurdie 174 
        }
175 
 
176 
        if (  $data =~ m~((/)(tags|branches|trunk)(/|$))~ )
177 
        {
267 dpurdie 178 
            my $bad_dir = $1;
179 
            push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";
180 
            return 1;
181 
        }
182 
 
183 
        ##
184 
        ##   Limit the size of the WorkSpace
185 
        ##   This limit is a bit artificial, but does attempt to
186 
        ##   limit views that encompass too much.
187 
        ##
188 
        #if ( $#{$self->{RESULT_LIST}} > 100 )
189 
        #{
190 
        #    Warning ("View is too large - DEBUG USE ONLY. WILL BE REMOVED" );
191 
        #    push @{$self->{ERROR_LIST}}, "View too large";
192 
        #    return 1;
193 
        #}
194 
    }
195 
}
196 
 
197 
#-------------------------------------------------------------------------------
1343 dpurdie 198 
# Function        : SvnSwitch
199 
#
200 
# Description     : Switches files and directories
201 
#
202 
# Inputs          : $self               - Instance data
203 
#                   $RepoPath           - Within the repository
204 
#                   $Path               - Local path
205 
#                   Options             - Options
206 
#                           --NoPrint   - Don't print files exported
207 
#
208 
# Returns         : Nothing
209 
#
210 
sub SvnSwitch
211 
{
212 
    my ($self, $RepoPath, $path, @opts) = @_;
1348 dpurdie 213 
    my $printdata = ! grep (/^--NoPrint/, @opts );
1343 dpurdie 214 
    Debug ("SvnSwitch", $RepoPath, $path);
215 
 
216 
    #
217 
    #   Build up the command line
218 
    #
219 
    my @sw_list;
220 
    if ( $self->SvnCmd ( 'switch', $RepoPath, $path,
221 
                            {
222 
                                'process' => \&ProcessSwitch,
223 
                                'data' => \@sw_list,
224 
                                'credentials' => 1,
225 
                                'nosavedata' => 1,
1348 dpurdie 226 
                                'printdata' => $printdata,
1343 dpurdie 227 
                            }
228 
                       ) || @sw_list )
229 
    {
230 
        #
231 
        #   We have a switch problem
232 
        #   Delete the workspace and then report the error
233 
        #
234 
        #   Note: For some reason a simple rmtree doesn't work
235 
        #         Nor does glob show all the directories
236 
        #
237 
        Verbose2 ("Remove WorkSpace: $path");
238 
        rmtree( $path, IsVerbose(3) );
239 
        rmtree( $path, IsVerbose(3) );
240 
        Error ("Switch elements", @{$self->{ERROR_LIST}}, @sw_list );
241 
    }
242 
    return;
243 
 
244 
    #
245 
    #   Internal routine to scan each line of the Switch output
246 
    #   Use to provide a nice display
247 
    #
248 
    sub ProcessSwitch
249 
    {
250 
        my $self = shift;
251 
        my $data = shift;
252 
 
253 
        if ( $self->{PRINTDATA} )
254 
        {
255 
            #
256 
            #   Pretty display for user
257 
            #
258 
            Information1 ("Switching : $data");
259 
        }
260 
    }
261 
}
262 
 
263 
#-------------------------------------------------------------------------------
267 dpurdie 264 
# Function        : SvnCi
265 
#
266 
# Description     : Check in the specified WorkSpace
267 
#
268 
# Inputs          : $self           - Instance data
269 
#                   A hash of named arguments
270 
#                       comment     - Commit comment
379 dpurdie 271 
#                       allowSame   - Allow no change to the workspace
267 dpurdie 272 
#
273 
# Returns         : Tag of the checkin
274 
#
275 
sub SvnCi
276 
{
277 
    my $self = shift;
278 
    my %opt = @_;
279 
    my $status_url;
379 dpurdie 280 
    my $ws_rev;
267 dpurdie 281 
 
282 
    Debug ("SvnCi");
283 
    Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);
284 
 
285 
    #
286 
    #   Validate the source path
1328 dpurdie 287 
    #   Note: populates %{$self->{InfoWs}} with 'info' data
267 dpurdie 288 
    #
289 
    my $path = SvnValidateWs ($self, 'SvnCi');
290 
 
291 
    #
1328 dpurdie 292 
    #   Examine %{$self->{InfoWs}}, which has the results of an 'info'
267 dpurdie 293 
    #   command the locate the URL.
294 
    #
295 
    #   This contains the target view space
296 
    #   Sanity test. Don't allow Checkin to a /tags/ area
297 
    #
1328 dpurdie 298 
    $status_url = $self->{InfoWs}{URL};
299 
    $ws_rev = $self->{InfoWs}{Revision};
379 dpurdie 300 
 
267 dpurdie 301 
    Error ("SvnCi: Cannot determine Repositoty URL")
302 
        unless ( $status_url );
303 
 
304 
    Error ("SvnCi: Not allowed to commit to a 'tags' area", "URL: $status_url")
305 
        if ( $status_url =~ m~/tags(/|$)~ );
306 
 
307 
    #
308 
    #   Commit
1328 dpurdie 309 
    #   Will modify Repo, so kill the cached Info
310 
    #   Will only be a real issue if we tag in the same session
267 dpurdie 311 
    #
1328 dpurdie 312 
    delete $self->{'InfoWs'};
313 
    delete $self->{'InfoRepo'};
314 
 
267 dpurdie 315 
    $self->SvnCmd ( 'commit', $path
316 
                    , '-m', SvnComment( $opt{'comment'}, 'Created by SvnCi' ),
317 
                    , { 'credentials' => 1,
318 
                        'process' => \&ProcessRevNo,
379 dpurdie 319 
                        'error' => "SvnCi: Copy Error",
320 
                         }
267 dpurdie 321 
                        );
379 dpurdie 322 
 
323 
    #
324 
    #   No error and no commit
325 
    #   Workspace was not changed, may be allowed
326 
    #
327 
    if ( ! $self->{REVNO} && $opt{allowSame} )
328 
    {
329 
        Warning ("SvnCi: Workspace matches Repository. No commit");
330 
        $self->{REVNO} = $ws_rev;
331 
    }
332 
 
267 dpurdie 333 
    Error ("SvnCi: Cannot determine Revision Number", @{$self->{RESULT_LIST}})
334 
        unless ( $self->{REVNO} );
335 
 
336 
    #
337 
    #   Update the view
338 
    #   Doing this so that the local view contains an up to date
339 
    #   revision number. If not done, and a 'copy' is done based
340 
    #   on this view then the branch information will indicate that
341 
    #   the copy is based on an incorrect version.
342 
    #   This can be confusing!
343 
    #
344 
    $self->SvnCmd ( 'update'   , $path
345 
                        , '--ignore-externals'
346 
                        , { 'credentials' => 1,
347 
                            'error' => "SvnCi: Updating WorkSpace" }
348 
                        );
349 
    #
350 
    #   Pass the updated revision number back to the user
351 
    #
352 
    $self->CalcRmReference($status_url);
379 dpurdie 353 
    Message ("Commit Tag is: " . $self->{RMREF} );
267 dpurdie 354 
    return $self->{RMREF} ;
355 
}
356 
 
357 
#-------------------------------------------------------------------------------
358 
# Function        : SvnCreatePackage
359 
#
360 
# Description     : Create a package and any associated files
361 
#
362 
# Inputs          : $self        - Instance data
363 
#                   A hash of named arguments
1348 dpurdie 364 
#                       package     - Name of the package
365 
#                                     May include subdirs
366 
#                       new         - True: Must not already exist
367 
#                       replace     - True: Replace targets
368 
#                       import      - DirTree to import
369 
#                       label       - Tag for imported DirTree
370 
#                       type        - Import TTB target
371 
#                       printdata   - True: Print extracted files (default)
267 dpurdie 372 
#
1348 dpurdie 373 
#
267 dpurdie 374 
# Returns         : Revision of the copy
375 
#
376 
sub SvnCreatePackage
377 
{
378 
    my $self = shift;
379 
    my %opt = @_;
380 
    my $target;
381 
 
382 
    Debug ("SvnCreatePackage", @_);
383 
    Error ("Odd number of args to SvnCreatePackage") unless ((@_ % 2) == 0);
384 
    my %dirs = ( 'trunk/'       => 0,
385 
                 'tags/'        => 0,
386 
                 'branches/'    => 0 );
387 
 
388 
    #
1348 dpurdie 389 
    #   Sanity Tests and defaul values
267 dpurdie 390 
    #
391 
    my $package = $self->Full || Error ("SvnCreatePackage: No package name provided");
392 
    Error ("SvnCreatePackage: Invalid import path") if ( $opt{'import'} && ! -d $opt{'import'} );
393 
    Error ("SvnCreatePackage: Tag without Import") if ( $opt{'label'} && ! $opt{'import'} );
394 
    $opt{'label'} = SvnIsaSimpleLabel( $opt{'label'} ) if (  $opt{'label'} );
1348 dpurdie 395 
    $opt{'printdata'} = 1 unless ( exists $opt{'printdata'} );
267 dpurdie 396 
 
397 
    #
398 
    #   Package path cannot contain any of the keyword paths tags,trunk,branches
399 
    #   as this would place a package with a package
400 
    #
401 
    Error ("Package path contains a reserved word ($1)", "Path: $package")
402 
        if (  $package =~ m~/(tags|branches|trunk)(/|$)~ );
403 
 
404 
    #
405 
    #   Package path cannot be pegged, or look like one
406 
    #
407 
    Error ("Package name contains a Peg ($1)", "Path: $package")
408 
        if ( $package =~ m~.*(@\d+)$~ );
409 
 
410 
    #
411 
    #   Determine TTB target
1356 dpurdie 412 
    #   The TTB type for branches and tags also conatins the branch or tag
267 dpurdie 413 
    #
414 
    $opt{'type'} = 'trunk' unless ( $opt{'type'} );
1347 dpurdie 415 
    if ( $opt{'type'} =~ m~^(tags|branches|trunk)(/|$)(.*)~ ) {
416 
        Error ("SvnCreatePackage: TTB type ($1) must be followed by a path element")
417 
            if ( (($1 eq 'tags') or ($1 eq 'branches' )) && ! $3  );
418 
        Error ('SvnCreatePackage: TTB type of trunk must not be followed by a path element: ' . $opt{'type'})
419 
            if ( ($1 eq 'trunk') && $3  );
420 
    } else {
421 
        Error ("SvnCreatePackage: Invalid TTB Type: " . $opt{'type'} );
422 
    }
267 dpurdie 423 
 
424 
    #
425 
    #   Before we import data we must ensure that the targets do not exist
426 
    #   Determine the import target(s)
427 
    #
428 
    my $import_target;
429 
    my $copy_target;
430 
 
1356 dpurdie 431 
    $self->{DEVBRANCH} = 'trunk';
267 dpurdie 432 
    if ( $opt{'import'} )
433 
    {
434 
        #
435 
        #   Primary target
436 
        #   trunk, branck or tag
437 
        #
438 
        $import_target = $package . '/' . $opt{'type'};
1347 dpurdie 439 
        $self->{DEVBRANCH} = $opt{'type'} ;
267 dpurdie 440 
 
441 
        $self->SvnValidateTarget( 'target'    => $import_target,
442 
                                  'delete'    => $opt{'replace'},
443 
                                  'available' => 1 );
444 
 
445 
        #
446 
        #   Secondary target
1347 dpurdie 447 
        #   Are we tagging the import too
267 dpurdie 448 
        #
1347 dpurdie 449 
        if ( $opt{'label'} )
267 dpurdie 450 
        {
451 
            $copy_target = $package . '/tags/' . $opt{'label'};
452 
            $self->SvnValidateTarget( 'target'    => $copy_target,
453 
                                      'delete'    => $opt{'replace'},
454 
                                      'available' => 1 );
455 
        }
456 
    }
457 
 
458 
    #
459 
    #   Probe to see if the package exists
460 
    #
461 
    my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'SvnCreatePackage', $package );
462 
    if ( @$ref_dirs )
463 
    {
464 
        Error ("SvnCreatePackage: Package directory exists",
465 
               "Cannot create a package here. Unexpected subdirectories:", @$ref_dirs);
466 
    }
467 
 
468 
    if ( @$ref_files )
469 
    {
470 
        Warning ("SvnCreatePackage: Unexpected files found",
471 
               "Path: $package",
472 
               "Unexpected files found: @$ref_files");
473 
    }
474 
 
475 
    if ( @$ref_svn )
476 
    {
477 
        #
478 
        #   Do we need a new one
479 
        #
480 
        Error ("SvnCreatePackage: Package exists: $package") if $opt{'new'};
481 
 
482 
        #
483 
        #   Some subversion files have been found here
484 
        #   Create the rest
485 
        #   Assume that the directory tree is good
486 
        #
487 
        #
488 
        #   Some, or all, of the required package subdirectories exist
489 
        #   Determine the new ones to created so that it can be done
490 
        #   in an atomic step
491 
        #
492 
        delete $dirs{$_} foreach  ( @$ref_svn );
493 
        if ( keys %dirs )
494 
        {
495 
            Warning ("SvnCreatePackage: Not all package subdirs present",
496 
                     "Remaining dirs will be created",
497 
                     "Found: @$ref_svn") if @$ref_svn;
498 
        }
499 
        else
500 
        {
501 
            Warning ("SvnCreatePackage: Package already present");
502 
        }
503 
    }
504 
    #
505 
    #   Create package directories that have not been discovered
506 
    #       trunk
507 
    #       branches
508 
    #       tags
509 
    #
510 
    my @dirs;
511 
    push @dirs, $package . '/' . $_ foreach ( keys %dirs );
512 
    $target = $package . '/trunk';
513 
 
514 
    #
515 
    #   Create missing directories - if any
516 
    #
517 
    if ( @dirs )
518 
    {
519 
        $self->SvnCmd ('mkdir', @dirs
379 dpurdie 520 
                       , '-m', $self->Path() . ': Created by SvnCreatePackage'
267 dpurdie 521 
                       , '--parents'
385 dpurdie 522 
                       , { 'credentials' => 1
523 
                           ,'error' => "SvnCreatePackage"
524 
                           ,'process' => \&ProcessRevNo
525 
                         } );
267 dpurdie 526 
    }
527 
 
528 
    #
529 
    #   Import data into the package if required
530 
    #   Import data. Possible cases:
531 
    #       - Import to trunk - and then tag it
532 
    #       - Import to branches
533 
    #       - Import to tags
534 
    #
535 
    if ( $import_target )
536 
    {
537 
        Verbose ("Importing directory into new package: $opt{'import'}");
538 
 
539 
        $target = $import_target;
1348 dpurdie 540 
        $self->{PRINTDATA} = $opt{'printdata'};
267 dpurdie 541 
        $self->SvnCmd ('import', $opt{'import'}
542 
                        , $target
543 
                        , '-m', 'Import by SvnCreatePackage'
544 
                        , '--force'
545 
                        , { 'credentials' => 1
546 
                           ,'error' => "Import Incomplete"
547 
                           ,'process' => \&ProcessRevNo
1348 dpurdie 548 
                           ,'printdata' => $opt{'printdata'}
267 dpurdie 549 
                          })
550 
    }
551 
 
552 
    #
553 
    #   If imported to the trunk AND a label is provided
554 
    #   then tag the import as well.
555 
    #   A simple URL copy
556 
    #
557 
    if ( $copy_target )
558 
    {
559 
        Verbose ("Labeling imported trunk: $opt{'label'} ");
560 
        $target = $copy_target;
561 
        $self->SvnCmd ('copy'  , $import_target
562 
                        , $target
563 
                        , '-m', 'Import tagged by SvnCreatePackage'
564 
                        , { 'credentials' => 1
565 
                          , 'process' => \&ProcessRevNo
566 
                          , 'error' => "Import Incomplete" } );
567 
    }
568 
 
569 
    #
1356 dpurdie 570 
    #   If we have done very little then we won't know the version
571 
    #   of the repo. Need to force it
572 
    #
573 
    unless ( $self->{REVNO} || $self->{WSREVNO} )
574 
    {
575 
        $self->SvnInfo( $package, 'InfoRepo' );
576 
        $self->{REVNO}  = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCreatePackage: Bad info for Repository");
577 
    }
578 
 
579 
 
580 
    #
267 dpurdie 581 
    #   Pass the updated revision number back to the user
582 
    #
583 
    $self->CalcRmReference($target);
1356 dpurdie 584 
    Message ("Create Package Rm Ref : " . $self->RmRef);
585 
    Message ("Create Package Vcs Tag: " . $self->SvnTag);
267 dpurdie 586 
    return $self->{RMREF} ;
587 
}
588 
 
589 
#-------------------------------------------------------------------------------
590 
# Function        : SvnRmView
591 
#
592 
# Description     : Remove a Subversion view
593 
#                   Will run sanity checks and only remove the view if
594 
#                   all is well
595 
#
596 
# Inputs          : A hash of named arguments
597 
#                       path     - Path to local workspace
598 
#                       modified - Array of files that are allowed to be modified
599 
#                       force    - True: Force deletion
600 
#
601 
# Returns         :
602 
#
603 
sub SvnRmView
604 
{
605 
    my %opt = @_;
606 
    Debug ("SvnRmView");
607 
    Error ("Odd number of args to SvnRmView") unless ((@_ % 2) == 0);
608 
 
609 
    #
610 
    #   Sanity test
611 
    #
612 
    my $path = $opt{'path'} || '';
613 
    my $path_length = length ($path);
614 
    Verbose2 ("Delete WorkSpace: $path");
615 
 
616 
    #
617 
    #   If the path does not exist then assume that its already deleted
618 
    #
619 
    unless ( $path && -e $path )
620 
    {
621 
        Verbose2 ("SvnRmView: Path does not exist");
622 
        return;
623 
    }
624 
 
625 
    #
626 
    #   Create information about the workspace
627 
    #   This will also validate the path
628 
    #
361 dpurdie 629 
    my $session = NewSessionByWS ( $path, 0, 1 );
267 dpurdie 630 
 
631 
    #
632 
    #   Validate the path
633 
    #
634 
    $session->SvnValidateWs ($path, 'SvnRmView');
635 
 
636 
    #
637 
    #   Ask subversion if there are any files to be updated
638 
    #   Prevent deletion of a view that has modified files
639 
    #
640 
    unless ( $opt{'force'} )
641 
    {
642 
        $session->SvnWsModified ( 'cmd' => 'SvnRmView', %opt );
643 
    }
644 
 
645 
    #
646 
    #   Now we can delete it
647 
    #
648 
    Verbose2 ("Remove WorkSpace: $path");
649 
    rmtree( $path, IsVerbose(3) );
650 
}
651 
 
652 
 
653 
#-------------------------------------------------------------------------------
654 
# Function        : SvnCopyWs
655 
#
656 
# Description     : Copy a workspace to a new place in the repository
657 
#                   Effectively 'label' the workspace
658 
#
659 
#                   It would appear that the 'copy' command is very clever
660 
#                   If a version-controlled file has been changed
661 
#                   in the source workspace, then it will automatically be
662 
#                   copied. This is a trap.
663 
#
664 
#                   Only allow a 'copy' if there are no modified
665 
#                   files in the work space (unless overridden)
666 
#
1328 dpurdie 667 
#                   Only allow a 'copy' if the local workspace is
668 
#                   up to date with respect with the repo. It possible
669 
#                   to do a 'commit' and then a 'copy' (tag) and have
670 
#                   unexpected results as the workspace has not been
671 
#                   updated. This is a trap.
267 dpurdie 672 
#
1328 dpurdie 673 
#
267 dpurdie 674 
# Inputs          : $self        - Instance data
675 
#                   A hash of named arguments
676 
#                       path     - Path to local workspace
677 
#                       target   - Location within the repository to copy to
678 
#                       comment  - Commit comment
679 
#                       modified - Array of files that are allowed to
680 
#                                  be modified in the workspace.
385 dpurdie 681 
#                       noswitch        - True: Don't switch to the new URL
682 
#                       replace         - True: Delete existing tag if present
683 
#                       allowLocalMods  - True: Allow complex tagging
1343 dpurdie 684 
#                       noupdatecheck   - True: Do not check that the WS is up to date
267 dpurdie 685 
#
686 
# Returns         : Revision of the copy
687 
#
688 
sub SvnCopyWs
689 
{
690 
    my $self = shift;
691 
    my %opt = @_;
385 dpurdie 692 
    my $rv;
267 dpurdie 693 
    Debug ("SvnCopyWs");
694 
    Error ("Odd number of args to SvnCopyWs") unless ((@_ % 2) == 0);
695 
    Error ("SvnCopyWs: No Workspace" ) unless ( $self->{WS} );
696 
 
697 
    #
698 
    #   Insert defaults
699 
    #
700 
    my $target = $opt{target} || Error ("SvnCopyWs: Target not specified" );
701 
 
702 
    #
703 
    #   Validate the source path
704 
    #
705 
    my $path = SvnValidateWs ($self, 'SvnCopyWs');
706 
 
707 
    #
708 
    #   Validate the target
709 
    #   Cannot have a 'peg'
710 
    #
711 
    Error ("SvnCopyWs: Target contains a Peg: ($1)", $target)
712 
        if ( $target =~ m~(@\d+)\s*$~ );
713 
 
714 
    #
1328 dpurdie 715 
    #   Ensure the Workspace is up to date
716 
    #       Determine the state of the Repo and the Workspace
717 
    #
1343 dpurdie 718 
    unless ( $opt{noupdatecheck} )
719 
    {
720 
        $self->SvnInfo( $self->{WS} , 'InfoWs' );
721 
        $self->SvnInfo( $self->FullWs, 'InfoRepo' );
1328 dpurdie 722 
 
1343 dpurdie 723 
        my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Workspace");
724 
        my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Repository");
1328 dpurdie 725 
 
1343 dpurdie 726 
        Verbose("WS Rev  : $wsLastChangedRev");
727 
        Verbose("Repo Rev: $repoLastChangedRev");
728 
        Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',
729 
               'Possibly caused by a commit without an update.',
730 
               'Update the workspace and try again.',
731 
               "Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );
732 
    }
1328 dpurdie 733 
 
734 
    #
267 dpurdie 735 
    #   Examine the workspace and ensure that there are no modified
736 
    #   files - unless they are expected
737 
    #
738 
    $self->SvnWsModified ( 'cmd' => 'SvnCopyWs', %opt );
385 dpurdie 739 
 
267 dpurdie 740 
    #
741 
    #   Validate the repository
742 
    #   Ensure that the target does not exist
743 
    #   The target may be deleted if it exists and allowed by the user
744 
    #
745 
    $self->SvnValidateTarget ( 'cmd'    => 'SvnCopyWs',
746 
                        'target' => $target,
747 
                        'delete' => $opt{replace},
748 
                        'comment' => 'Deleted by SvnCopyWs'
749 
                        );
369 dpurdie 750 
 
267 dpurdie 751 
    #
752 
    #   Copy source to destination
1328 dpurdie 753 
    #   Assuming the WorkSpace is up to date then, even though the source is a
754 
    #   WorkSpace, the copy does not transfer data from the WorkSpace.
755 
    #   It appears as though its all done on the server. This is good - and fast.
267 dpurdie 756 
    #
1328 dpurdie 757 
    #   If the Workspace is not up to date, then files that SVN thinks have not
758 
    #   been transferred will be transferred - hence the need to update after
759 
    #   a commit.
760 
    #
385 dpurdie 761 
    #   Moreover, files that are modified in the local workspace will
762 
    #   be copied and checked into the target, but this is not nice.
267 dpurdie 763 
    #
385 dpurdie 764 
    $rv = $self->SvnCmd ( 'cp'  , $path
267 dpurdie 765 
                        , $target
766 
                        , '--parents'
767 
                        , '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),
768 
                        , { 'process' => \&ProcessRevNo,
1348 dpurdie 769 
                            'credentials' => 1,
770 
                            'printdata' => 1,
771 
                             }
385 dpurdie 772 
                        );
773 
    if ($rv)
267 dpurdie 774 
    {
775 
        #
776 
        #   Error in copy
777 
        #   Attempt to delete the target. Don't worry if we can't do that
778 
        #
779 
        my @err1 = @{$self->{ERROR_LIST}};
780 
        $self->SvnCmd ( 'delete'
781 
                    , $target
782 
                    , '-m', 'Deleted by SvnCopyWs after creation failure'
783 
                    , { 'credentials' => 1, }
784 
               );
785 
        Error ("SvnCopyWs: Copy Error", @err1);
786 
    }
787 
 
788 
    Error ("SvnCopyWs: Cannot determine Revision Number", @{$self->{RESULT_LIST}})
789 
        unless ( $self->{REVNO} );
790 
 
791 
    Verbose2 ("Copy committed as revision: " . $self->{REVNO} );
792 
 
793 
    unless ( $opt{'noswitch'} )
794 
    {
795 
        #
796 
        #   Switch to the new URL
797 
        #   This will link the Workspace with the copy that we have just made
798 
        #
799 
        $self->SvnCmd ( 'switch', $target
800 
                         , $path
801 
                         , { 'credentials' => 1,
802 
                             'error' => "SvnCopyWs: Cannot switch to new URL" }
803 
               );
804 
    }
805 
 
806 
    #
807 
    #   Pass the updated revision number back to the user
808 
    #
1347 dpurdie 809 
    $self->CalcRmReference($target);
353 dpurdie 810 
    #Message ("Tag is: " . $self->{RMREF} );
267 dpurdie 811 
    return $self->{RMREF} ;
812 
}
813 
 
814 
#-------------------------------------------------------------------------------
815 
# Function        : SvnWsModified
816 
#
817 
# Description     : Test a Workspace for modified files
818 
#                   Allow some files to be modified
819 
#
820 
# Inputs          : $self           - Instance data
821 
#                   A hash of named arguments
822 
#                       path        - Path to local workspace
823 
#                       modified    - Files that are allowed to be modified
824 
#                                     Relative to the 'path'
825 
#                                     May be a single file or an array of files
385 dpurdie 826 
#                       allowLocalMods - Only warn about local mods
267 dpurdie 827 
#                       cmd         - Command name for error reporting
828 
#
829 
# Returns         :
830 
#
831 
sub SvnWsModified
832 
{
833 
    my $self = shift;
834 
    my %opt = @_;
835 
    Debug ("SvnWsModified");
836 
    Error ("Odd number of args to SvnWsModified") unless ((@_ % 2) == 0);
837 
 
838 
    my $cmd = $opt{'cmd'} || 'SvnWsModified';
839 
 
840 
    #
841 
    #   Validate the path
842 
    #
843 
    SvnValidateWs ($self, $cmd);
844 
    my $path = $self->{WS};
845 
    my $path_length = length ($path);
846 
    Verbose2 ("Test Workspace for Modifications: $path");
847 
 
848 
    #
849 
    #   Ask subversion if there are any files to be updated
850 
    #
851 
    $self->SvnCmd ('status', $path, {'error' => "Svn status command error"} );
852 
 
853 
    #
854 
    #   Examine the list of modified files
855 
    #
856 
    if ( @{$self->{RESULT_LIST}} )
857 
    {
858 
        #
351 dpurdie 859 
        #   Create a hash of files that are allowed to change
267 dpurdie 860 
        #   These are files relative to the base of the view
861 
        #
862 
        #   The svn command has the 'path' prepended, so this
863 
        #   will be removed as we process the commands
864 
        #
865 
        my %allowed;
866 
        my @unexpected;
867 
 
868 
        if ( exists $opt{'modified'}  )
869 
        {
870 
            $allowed{'/' . $_} = 1 foreach ( ref ($opt{'modified'}) ? @{$opt{'modified'}} : $opt{'modified'}  );
871 
        }
872 
 
873 
        #
874 
        #   Process the list of modified files
875 
        #   Do this even if we aren't allowed modified files as we
876 
        #   still need to examine the status and kill off junk entries
877 
        #   ie: ?, I, ! and ~
878 
        #
879 
        #    First column: Says if item was added, deleted, or otherwise changed
880 
        #      ' ' no modifications
881 
        #      'A' Added
882 
        #      'C' Conflicted
883 
        #      'D' Deleted
884 
        #      'I' Ignored
885 
        #      'M' Modified
886 
        #      'R' Replaced
887 
        #      'X' item is unversioned, but is used by an externals definition
888 
        #      '?' item is not under version control
889 
        #      '!' item is missing (removed by non-svn command) or incomplete
890 
        #      '~' versioned item obstructed by some item of a different kind
891 
        #
892 
        foreach my $entry ( @{$self->{RESULT_LIST}} )
893 
        {
894 
            #
895 
            #   Extract filename from line
351 dpurdie 896 
            #       First 8 chars are status
267 dpurdie 897 
            #       Remove WS path too
898 
            #
1328 dpurdie 899 
            if ( length $entry >= 8 + $path_length)
900 
            {
901 
                my $file = substr ( $entry, 8 + $path_length );
902 
                next if ( $allowed{$file} );
903 
            }
267 dpurdie 904 
 
905 
            #
906 
            #   Examine the first char and rule out funny things
907 
            #
908 
            my $f1 =  substr ($entry, 0,1 );
909 
            next if ( $f1 =~ m{[?I!~]} );
910 
            push @unexpected, $entry;
911 
        }
385 dpurdie 912 
 
913 
        if ( @unexpected )
914 
        {
915 
            if ( $opt{allowLocalMods} ) {
916 
                Message ("Workspace contains locally modified files:", @unexpected);
917 
            } else {
918 
                Error ("Workspace contains unexpected modified files", @unexpected);
919 
            }
920 
        }
267 dpurdie 921 
    }
922 
}
923 
 
924 
#-------------------------------------------------------------------------------
925 
# Function        : SvnListPackages
926 
#
927 
# Description     : Determine a list of packages within the repo
928 
#                   This turns out to be a very slow process
929 
#                   so don't use it unless you really really need to
930 
#
1341 dpurdie 931 
# Inputs          : $self       - Instance data
932 
#                   $repo       - Name of the repository
933 
#                   Last argument may be a hash of options.
934 
#                           Progress    - True: Show progress
935 
#                           Show        - >1 : display matched Tags and stats
936 
#                                         >2 : display Packages
937 
#                           Tag         - Enable Tag Matching
938 
#                                         Value is the tag to match
267 dpurdie 939 
#
1341 dpurdie 940 
# Returns         : Ref to an array of all packages
941 
#                   Ref to an array of all packahes with matched tag
267 dpurdie 942 
#
943 
sub SvnListPackages
944 
{
1341 dpurdie 945 
    #
946 
    #   Extract arguments and options
947 
    #   If last argument is a hesh, then its a hash of options
948 
    #
949 
    my $opt;
950 
    $opt = pop @_
951 
        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
267 dpurdie 952 
 
1341 dpurdie 953 
    my ($self, $repo) = @_;
954 
 
955 
    my @path_list = '';
267 dpurdie 956 
    my @list;
1341 dpurdie 957 
    my @mlist;
267 dpurdie 958 
    my $scanned = 0;
959 
    Debug ("SvnListPackages");
960 
    while ( @path_list )
961 
    {
962 
        my $path = shift @path_list;
1341 dpurdie 963 
        if ( $opt->{Progress} )
964 
        {
965 
            Message ("Reading: " . ( $path || 'RepoRoot') );
966 
        }
267 dpurdie 967 
        $scanned++;
1341 dpurdie 968 
        my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Packages', join( '/', $repo, $path) );
267 dpurdie 969 
 
970 
        #
971 
        #   If there are Subversion dirs (ttb) in this directory
972 
        #   then this is a package. Add to list
973 
        #
974 
        push @list, $path if ( @$ref_svn );
975 
 
976 
        #
977 
        #   Add subdirs to the list of paths to explore
978 
        #
979 
        foreach  ( @$ref_dirs )
980 
        {
1341 dpurdie 981 
            chop;                                   # Remove trailing '/'
982 
            push @path_list, $path ? join('/', $path , $_) : $_; # Extend the path
267 dpurdie 983 
        }
984 
    }
985 
 
1341 dpurdie 986 
    if ( $opt->{Tag} )
987 
    {
988 
        my $tag = $opt->{Tag};
989 
        foreach my $path ( sort @list )
990 
        {
991 
            Message ("Testing: $path") if ( $opt->{Progress} );
992 
            if ( $self->SvnTestPath ( 'Listing Packages', join('/', $repo, $path, 'tags', $tag) ) )
993 
            {
994 
                push @mlist, $path;
995 
            }
996 
        }
997 
    }
998 
 
999 
    if ( $opt->{Show} )
1000 
    {
1001 
        Message ("Found Tags:", @mlist );
1002 
        Message ("Found Packages:", @list ) if  $opt->{Show} > 2;
1003 
        Message ("Tags Found: " . scalar @mlist );
1004 
        Message ("Packages Found: " . scalar @list );
1005 
        Message ("Dirs Scanned: $scanned");
1006 
    }
1007 
 
1008 
    return \@list, \@mlist;
267 dpurdie 1009 
}
1010 
 
1011 
#-------------------------------------------------------------------------------
1012 
# Function        : ListLabels
1013 
#
1014 
# Description     : List labels within a given package
1015 
#
1016 
# Inputs          : $self               - Instance data
1017 
#                   $path               - path to label source
1018 
#
1019 
# Returns         : Ref to an array
1020 
#
1021 
sub ListLabels
1022 
{
1023 
    my ($self, $path) = @_;
1024 
    Debug ("ListLabels");
1025 
 
1026 
    my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Versions', $path );
1027 
 
1028 
    Error ("List: Path not found: $path") unless ( $found );
1029 
 
1030 
    #
1031 
    #   Dont report files - just directories
1032 
    #
1033 
    return $ref_dirs;
1034 
}
1035 
 
1036 
 
1037 
#-------------------------------------------------------------------------------
1038 
# Function        : SvnLocateWsRoot
1039 
#
1040 
# Description     : Given a WorkSpace, determine the root of the work space
1041 
#                   This is not as simple as you might think
1042 
#
1043 
#                   Algorithm
1044 
#                       svn ls ..
1045 
#                       Am I in the parent directory
1046 
#                       Repeat
1047 
#
369 dpurdie 1048 
#                   Updates 'WS' and 'WSURL'
1049 
#
267 dpurdie 1050 
# Inputs          : $self               - Instance data
1051 
#                   $test               - True: Don't die on error
1052 
#
1053 
# Returns         : Root of workspace as an absolute address
1054 
#                   Will not return if there is an error
1055 
#
1056 
sub SvnLocateWsRoot
1057 
{
1058 
    my ($self, $test) = @_;
1059 
    my @path;
1060 
    my $path = $self->{WS};
1061 
 
1062 
    Debug ("SvnLocateWsRoot");
1063 
    Error ("SvnLocateWsRoot: No Workspace") unless ( $path  );
1064 
    Verbose2 ("SvnLocateWsRoot: Start in $path");
1065 
 
1066 
    #
1067 
    #   Validate the source path
1068 
    #
1069 
    if ( SvnValidateWs ($self, 'SvnLocateWsRoot', $test) )
1070 
    {
1071 
        return undef;
1072 
    }
1073 
 
1074 
    #
1075 
    #   Need to sanitize the users path to ensure that the following
1076 
    #   algorithm works. Need:
1077 
    #       1) Absolute Path
1078 
    #       2) Not ending in '/'
1079 
    #
1080 
 
1081 
    #
1082 
    #   If we have a relative path then prepend the current directory
1083 
    #   An absolute path is:
1084 
    #           /aaa/aa/aa
1085 
    #       or  c:/aaa/aa/aa
1086 
    #
1087 
    $path = getcwd() . '/' . $path
1088 
        unless ( $path =~ m~^/|\w:/~  );
1089 
 
1090 
    #
1091 
    #   Walk the bits and remove ".." directories
1092 
    #       Done by pushing non-.. elements and poping last entry for .. elements.
1093 
    #   Have a leading "/" which is good.
1094 
    #
1095 
    #   Create a array of directories in the path
1096 
    #   Split on one or more \ or / separators
1097 
    #
1098 
    foreach ( split /[\\\/]+/ , $path )
1099 
    {
1100 
        next if ( $_ eq '.' );
1101 
        unless ( $_ eq '..' )
1102 
        {
1103 
            push @path, $_;
1104 
        }
1105 
        else
1106 
        {
1107 
            Error ("SvnLocateWsRoot: Bad Pathname: $path")
1108 
                if ( $#path <= 0 );
1109 
            pop @path;
1110 
        }
1111 
    }
1112 
 
369 dpurdie 1113 
    #
1114 
    #   Need to adjust the WSURL too
1115 
    #   Break into parts and pop them off as we go
1116 
    #   Add a dummy one to allow for the first iteration
1117 
    #
1118 
    my @wsurl = (split (/[\\\/]+/ , $self->{WSURL}), 'Dummy');
1119 
 
267 dpurdie 1120 
    Verbose2 ("Clean absolute path elements: @path");
1121 
    PATH_LOOP:
1122 
    while ( @path )
1123 
    {
1124 
        #
1125 
        #   This directory element. Append / to assist in compare
1126 
        #   Determine parent path
1127 
        #
1128 
        my $name = pop (@path) . '/';
1129 
        my $parent = join ('/', @path );
369 dpurdie 1130 
        pop @wsurl;
267 dpurdie 1131 
 
1132 
        #
1133 
        #   Examine the parent directory
1134 
        #   Get a list of all elements in the parent
1135 
        #   Need to ensure that this directory is one of them
1136 
        #
1137 
        #   Ignore any errors - assume that they are because the
1138 
        #   parent is not a part of the work space. This will terminate the
1139 
        #   search.
1140 
        #
1141 
        $self->SvnCmd ('list', $parent, '--depth', 'immediates' );
1142 
        foreach my $entry ( @{$self->{RESULT_LIST}} )
1143 
        {
1144 
            next PATH_LOOP
1145 
                if ( $entry eq $name );
1146 
        }
1147 
 
1148 
        #
1149 
        #   Didn't find 'dir' in directory svn listing of parent
1150 
        #   This parent is not a part of the same WorkSpace as 'dir'
1151 
        #   We have a winner.
1152 
        #
1153 
        chop $name;                         #   Chop the '/' previously added
1154 
        $self->{WS} = $parent . '/' . $name;
369 dpurdie 1155 
 
1156 
        #
1157 
        #   Reform the WSURL. Elements have been removed as we tested up the
1158 
        #   path
1159 
        #
1160 
        $self->{WSURL} = join '/', @wsurl;
1161 
 
267 dpurdie 1162 
        return $self->{WS};
1163 
    }
1164 
 
1165 
    #
1166 
    #   Shouldn't get this far
1167 
    #
1168 
    Error ("SvnLocateWsRoot: Root not found");
1169 
}
1170 
 
1171 
#-------------------------------------------------------------------------------
1172 
# Function        : SvnValidateWs
1173 
#
1174 
# Description     : Validate the path to a working store
1175 
#
1176 
# Inputs          : $self           - Instance data
1177 
#                   $user           - Optional prefix for error messages
1178 
#                   $test           - True: Just test, Else Error
1179 
#
1180 
# Returns         : Will not return if not a workspace
1181 
#                   Returns the users path
1328 dpurdie 1182 
#                   Populates the hash: $self->{InfoWs}
267 dpurdie 1183 
#
1184 
sub SvnValidateWs
1185 
{
1186 
    my ($self, $user, $test) = @_;
1187 
    Debug ("SvnValidateWs");
1188 
 
1189 
    $user = "Invalid Subversion Workspace" unless ( $user );
1328 dpurdie 1190 
    my $path = $self->{WS};
267 dpurdie 1191 
 
1192 
    #
1328 dpurdie 1193 
    #   Only validate it once
267 dpurdie 1194 
    #
1195 
    return $path if ( $self->{WS_VALIDATED} );
1196 
 
1197 
    #
1198 
    #   Validate the source path
1199 
    #   Must exist and must be a directory
1200 
    #
1201 
    if ( ! $path ) {
1202 
        @{$self->{ERROR_LIST}} = "$user: No path specified";
1203 
 
1204 
    } elsif ( ! -e $path ) {
1205 
        @{$self->{ERROR_LIST}} = "$user: Path does not exist: $path";
1206 
 
1207 
    } elsif ( ! -d $path ) {
1208 
        @{$self->{ERROR_LIST}} = "$user: Path is not a directory";
1209 
    } else {
1210 
        #
1211 
        #   Determine the source path is an fact a view
1212 
        #   The info command can do this. Use depth empty to limit the work done
1213 
        #
1328 dpurdie 1214 
        $self->SvnInfo($path, 'InfoWs');
267 dpurdie 1215 
 
1216 
        #
1217 
        #   Error. Prepend nice message
1218 
        #
1219 
        unshift @{$self->{ERROR_LIST}}, "$user: Path is not a WorkSpace: $path"
1220 
            if ( @{$self->{ERROR_LIST}} );
1221 
    }
1222 
 
1223 
    #
1224 
    #   Figure out what to do
1225 
    #
1226 
    if ( $test )
1227 
    {
1228 
        return @{$self->{ERROR_LIST}};
1229 
    }
1230 
    else
1231 
    {
1232 
        Error @{$self->{ERROR_LIST}} if @{$self->{ERROR_LIST}};
1233 
        $self->{WS_VALIDATED} = 1;
1234 
        return $path;
1235 
    }
1236 
}
1237 
 
1238 
#-------------------------------------------------------------------------------
1239 
# Function        : SvnValidatePackageRoot
1240 
#
1241 
# Description     : Validate a package root
1242 
#
1243 
# Inputs          : $self           - Instance data
1244 
#
1245 
# Returns         : Will only return if valid
1246 
#                   Returns a cleaned package root
1247 
#
1248 
sub SvnValidatePackageRoot
1249 
{
379 dpurdie 1250 
    my ($self, $warning_only) = @_;
267 dpurdie 1251 
    Debug ("SvnValidatePackageRoot");
1252 
    my $url = $self->Full || Error ("SvnValidatePackageRoot: No URL");
1253 
 
1254 
    Error ("Package path contains a reserved word ($self->{TAGTYPE})", "Path: $url")
1255 
        if (  $self->{TAGTYPE} );
1256 
 
1257 
    Error ("Package name contains a Peg ($self->{PEG})", "Path: $url")
1258 
        if ( $self->{PEG} );
1259 
 
1260 
    #
1261 
    #   Ensure that the target path does exist
1262 
    #   Moreover it needs to be a directory and it should have a
1263 
    #   a ttb structure
1264 
    #
1265 
    my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Package Base Test', $url );
1266 
 
1267 
    #
379 dpurdie 1268 
    #   Only looking for package path
1269 
    #
1270 
    if ( !$found && $warning_only )
1271 
    {
1272 
        return $url;
1273 
    }
1274 
 
1275 
    #
267 dpurdie 1276 
    #   Examine the results to see if we have a valid package base
1277 
    #
1278 
    Error ("Package Base Test: Not a valid package") unless ( $found );
1279 
 
1280 
    #
1281 
    #   Extra bits found
1282 
    #   Its not the root of a package
1283 
    #
1284 
    if ( @$ref_files )
1285 
    {
1286 
        Warning ("Package Base Test: Files exists",
1287 
               "Unexpected files found:", @$ref_files );
1288 
    }
1289 
 
1290 
    #
1291 
    #   Need a truck directory
1292 
    #   If we don't have a truck we don't have a package
1293 
    #
1294 
    my $trunk_found = grep ( /trunk\//, @$ref_svn );
1295 
    Error ("Invalid Package Base. Does not contain a 'trunk' directory")
1296 
        unless ( $trunk_found );
1297 
 
1298 
    return $url;
1299 
}
1300 
 
1301 
 
1302 
#-------------------------------------------------------------------------------
1303 
# Function        : SvnIsaSimpleLabel
1304 
#
1305 
# Description     : Check a label
1306 
#                       Must not contain a PEG
1307 
#                       Must not contain invalid characters (@ or /)
1308 
#                       Must not contain a :: sequence (will confuse other tools)
1309 
#                       Handle special label of TIMESTAMP
1310 
#
1311 
# Inputs          : $label          - to test
1312 
#
1313 
# Returns         : Will not return on error
1314 
#                   Returns label on success
1315 
#
1316 
sub SvnIsaSimpleLabel
1317 
{
1318 
    my ($label) = @_;
1319 
    Debug ("SvnIsaSimpleLabel, $label");
1320 
 
1321 
    Error ("No label provided") unless ( $label );
1322 
    Error ("Invalid label. Peg (\@nnn) is not allowed: \"$label\"" ) if ( $label =~ m~@\d+$~ );
1323 
    Error ("Invalid label. Package Path is not allowed: \"$label\"" ) if ( $label =~ m~/~ );
383 dpurdie 1324 
    Error ("Invalid label. Invalid Start Character: \"$label\"" ) unless ( $label =~ m~^[0-9a-zA-Z]~ );
1325 
    Error ("Invalid label. Invalid End Character: \"$label\"" ) unless ( $label =~ m~[0-9a-zA-Z]$~ );
267 dpurdie 1326 
    Error ("Invalid label. Invalid Characters: \"$label\"" ) unless ( $label =~ m~^[-.:0-9a-zA-Z_]+$~ );
1327 
    Error ("Invalid label. Double :: not allowed: \"$label\"" ) if ( $label =~m~::~ );
1328 
 
1329 
    #
1330 
    #   Allow for a label of TIMESTAMP and have it expand
383 dpurdie 1331 
    #   Create a label based on users name and a date-time that can be sorted
267 dpurdie 1332 
    #
1333 
    if ( $label eq 'TIMESTAMP' )
1334 
    {
341 dpurdie 1335 
        ::EnvImport ('USER' );
1336 
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
1337 
        $label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u",
1338 
            $::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );
267 dpurdie 1339 
    }
1340 
    return $label;
1341 
}
1342 
 
1343 
#-------------------------------------------------------------------------------
1344 
# Function        : NewSession
1345 
#
1346 
# Description     : Create a new empty SvnSession Class
1347 
#
1348 
# Inputs          : None
1349 
#
1350 
# Returns         : Class
1351 
#
1352 
sub NewSession
1353 
{
1354 
    Debug ("NewSession");
1355 
    my $self  = SvnSession();
1356 
 
1357 
    #
1358 
    #   Document Class Variables
1359 
    #
1360 
    $self->{URL} = '';                  # Repo URL prefix
1361 
    $self->{WS}  = '';                  # Users WorkSpace
1362 
    $self->{PROTOCOL} = '';             # Named Access Protocol
1363 
    $self->{PKGROOT} = '';              # Package root
1364 
 
1365 
    #
1366 
    #   Create a class
1367 
    #   Bless my self
1368 
    #
1369 
    bless ($self, __PACKAGE__);
1370 
    return $self;
1371 
}
1372 
 
1373 
#-------------------------------------------------------------------------------
1374 
# Function        : NewSessionByWS
1375 
#
1376 
# Description     : Establish a new SVN Session based on a Workspace
1377 
#                   Given a workspace path determine the SvnServer and other
1378 
#                   relevent information.
1379 
#
1380 
#                   Requires some rules
1381 
#                       * The package is rooted within a 'ttb'
1382 
#
1383 
# Inputs          : $path                   - Path to WorkSpace
1384 
#                   $test                   - No Error on no WS
361 dpurdie 1385 
#                   $slack                  - Less stringent
267 dpurdie 1386 
#
1387 
# Returns         : Ref to Session Information
1388 
#
1389 
sub NewSessionByWS
1390 
{
361 dpurdie 1391 
    my ($path, $test, $slack) = @_;
267 dpurdie 1392 
    Debug ("NewSessionByWS", @_);
1393 
 
1394 
    #
1395 
    #   Create a basic Session
1396 
    #   Populate it with information that is known
1397 
    #
1398 
    my $self = NewSession();
1399 
    $self->{WS} = $path;
1400 
 
1401 
    #
1402 
    #   Validate the path provided
1328 dpurdie 1403 
    #   In the process populate $self->{InfoWs} with info about the workspace.
267 dpurdie 1404 
    #
1405 
    if ($self->SvnValidateWs ( undef, 1) )
1406 
    {
1407 
        return $self if ( $test );
1408 
        Error ( @{$self->{ERROR_LIST}} );
1409 
    }
1410 
 
1411 
    #
1412 
    #   Extract useful info
1413 
    #       URL: svn://auperaws996vm21/test/MixedView/trunk
1414 
    #       Repository Root: svn://auperaws996vm21/test
1415 
    #
1328 dpurdie 1416 
    my $url = $self->{'InfoWs'}{'URL'};
1417 
    my $reporoot = $self->{'InfoWs'}{'Repository Root'};
1418 
    my $repoVersion = $self->{'InfoWs'}{'Revision'};
1347 dpurdie 1419 
    my $devBranch;
267 dpurdie 1420 
 
1421 
    Error ("JatsSvn Internal error. Can't parse info")
1422 
        unless ( $url && $reporoot );
1423 
 
1424 
    #
1425 
    #   Need the length of the path to the repository
1426 
    #   but not the name of the repostory itself.
1427 
    #
1428 
    #   Remove that from the head of the URL to give a
1429 
    #   path within the repository, that includes the repos name
1430 
    #
1431 
    $reporoot = (fileparse( $reporoot ))[1];
1432 
    $url = substr ($url, length ($reporoot));
1433 
    $self->{WSURL} = $url;
1434 
    chop $reporoot;
1435 
 
1436 
    Verbose2 ("SvnLocatePackageRoot: $reporoot, $url" );
1437 
 
1438 
    #
1439 
    #   Remove anything after a ttb ( truck, tags, branch ) element
1440 
    #   This will be the root of the package within the repo
1441 
    #
1442 
    if (  $url =~ m~(.+)/((tags|branches|trunk)(/|$).*)~ )
1443 
    {
1444 
        $url = $1;
1445 
        $self->{WSTYPE} = $3;
1347 dpurdie 1446 
        if ( $3 eq 'trunk' ) {
1447 
            $devBranch = $3;
1448 
        } elsif ( $3 eq 'branches' ) {
1449 
            $devBranch = $2;
1450 
        }
267 dpurdie 1451 
    }
1452 
    else
1453 
    {
361 dpurdie 1454 
        #
1455 
        #   If we are being slack (ie deleting the workspace)
1456 
        #   Then generate a warning, not an error
1457 
        #
1458 
        my $fnc = $slack ? \&Warning : \&Error;
1459 
        $fnc->("SvnLocatePackageRoot. Non standard repository format",
1460 
               "Url must contain 'tags' or 'branches' or 'trunk'",
267 dpurdie 1461 
               "Url: $url");
361 dpurdie 1462 
        $self->{WSTYPE} = 'trunk';
267 dpurdie 1463 
    }
1464 
 
1465 
    #
1466 
    #   Insert known information
1467 
    #
1468 
    $self->{URL} = $reporoot . '/';
1469 
    $self->{PKGROOT} = $url;
369 dpurdie 1470 
    $self->{WSREVNO} = $repoVersion;
1347 dpurdie 1471 
    $self->{DEVBRANCH} = $devBranch;
267 dpurdie 1472 
 
1473 
    #
1474 
    #   Create useful information
1475 
    #
1476 
    SplitPackageUrl($self);
1477 
    return $self;
1478 
}
1479 
 
1480 
#-------------------------------------------------------------------------------
1481 
# Function        : NewSessionByUrl
1482 
#
1483 
# Description     : Establish a new SVN Session based on a user URL
1484 
#
1485 
# Inputs          : $uurl                   - Users URL
361 dpurdie 1486 
#                   $ttb_test               - Test and warn for TTB structure
267 dpurdie 1487 
#                   $session                - Optional: Existing session
1488 
#
1489 
# Returns         : Ref to Session Information
1490 
#
1491 
sub NewSessionByUrl
1492 
{
361 dpurdie 1493 
    my ($uurl, $ttb_test, $self ) = @_;
267 dpurdie 1494 
    Debug ("NewSessionByUrl", @_);
1495 
    Error ("No Repostory Path specified") unless ( $uurl );
1496 
 
1497 
    #
1498 
    #   Create a basic Session
1499 
    #   Populate it with information that is known
1500 
    #
1501 
    $self = NewSession() unless ( $self );
1502 
 
1503 
    #
369 dpurdie 1504 
    #   Examine the URL and convert a Repository Path into a URL
353 dpurdie 1505 
    #   as provided by configuration information within the environment
267 dpurdie 1506 
    #
361 dpurdie 1507 
    ($self->{URL}, $self->{PKGROOT} ) = SvnPath2Url ($uurl);
1508 
 
1509 
    #
1510 
    #   Create useful information
1511 
    #
1512 
    SplitPackageUrl($self);
1513 
 
1514 
    #
1515 
    #   Warn of non-standard URLs
1516 
    #   These may create problems latter
1517 
    #
1518 
    if ( $ttb_test )
1519 
    {
1520 
        Warning("Non standard repository format",
1521 
                 "Url should contain 'tags' or 'branches' or 'trunk'",
1522 
                 "Url: $self->{PKGROOT}") unless $self->{TAGTYPE};
1523 
    }
1524 
 
1525 
    return $self;
1526 
}
1527 
 
1528 
#-------------------------------------------------------------------------------
1529 
# Function        : SvnPath2Url
1530 
#
1531 
# Description     : Convert a repository path to a Full Url
1532 
#                   Also handles Full Url
1533 
#
1534 
# Inputs          : $rpath             - Repository Path
1535 
#                                        May be a full URL
1536 
#
1537 
# Returns         : List context
1538 
#                   Two items that can be joined
1539 
#                   URL                - URL
1540 
#                   PKG_ROOT           - Package Root
1541 
#
1542 
#                   Scalar context: Joined URL and Package Root
1543 
#                                   Fully formed URL
1544 
#
1545 
sub SvnPath2Url
1546 
{
1547 
    my ($rpath) = @_;
1548 
    my $processed = 0;
1549 
    my $url;
1550 
    my $pkgroot;
1551 
 
1552 
    #
1553 
    #   Examine the argument and convert a Repository Path into a URL
1554 
    #   as provided by configuration information within the environment
1555 
    #
1556 
    $rpath =~ m~(.+?)/(.*)~;
1557 
    my $fe = $1 || $rpath;
353 dpurdie 1558 
    my $rest = $2 || '';
1559 
    if ( $SVN_URLS{$fe} )
267 dpurdie 1560 
    {
361 dpurdie 1561 
        $url = $SVN_URLS{$fe};
1562 
        $pkgroot = $rest;
353 dpurdie 1563 
        $processed = 1;
341 dpurdie 1564 
    }
1565 
 
353 dpurdie 1566 
    if ( ! $processed )
341 dpurdie 1567 
    {
267 dpurdie 1568 
        #
353 dpurdie 1569 
        #   Examine the URL and determine if we have a FULL Url or
1570 
        #   a path within the 'default' server
1571 
        #
1572 
        foreach my $key ( @SVN_URLS_LIST )
1573 
        {
361 dpurdie 1574 
            if ( $rpath =~ m~^$SVN_URLS{$key}(.*)~ )
353 dpurdie 1575 
            {
361 dpurdie 1576 
                $url = $SVN_URLS{$key};
1577 
                $pkgroot = $1;
353 dpurdie 1578 
                $processed = 1;
1579 
                last;
1580 
            }
1581 
        }
1582 
    }
267 dpurdie 1583 
 
353 dpurdie 1584 
    #
1585 
    #   Last attempt
1586 
    #   Treat as a raw URL - some operations won't be allowed
1587 
    #
1588 
    if ( ! $processed )
267 dpurdie 1589 
    {
361 dpurdie 1590 
        if ( $rpath =~ m~^((file|http|https|svn):///?([^/]+)/)(.+)~ )
353 dpurdie 1591 
        {
1592 
            #       http://server/
1593 
            #       https://server/
1594 
            #       svn://server/
1595 
            #       file://This/Isa/Bad/Guess
1596 
            #
361 dpurdie 1597 
            $url = $1;
1598 
            $pkgroot = $4;
353 dpurdie 1599 
        }
369 dpurdie 1600 
        elsif ($SVN_URLS{''} )
353 dpurdie 1601 
        {
1270 dpurdie 1602 
            if ( exists $ENV{'GBE_ABT'} && $ENV{'GBE_ABT'})
1603 
            {
1604 
                Error ("Attempt to use default repository within automated build", "Path: " . $rpath);
1605 
            }
361 dpurdie 1606 
            $url = $SVN_URLS{''};
1607 
            $pkgroot = $rpath;
353 dpurdie 1608 
        }
1609 
        else
1610 
        {
1611 
            #
1612 
            #   User default (site configured) Repo Root
1613 
            #
1614 
            Error ("No site repository configured for : $fe",
1615 
                   "Configure GBE_SVN_URL_" . uc($fe) );
1616 
        }
267 dpurdie 1617 
    }
1618 
 
1619 
    #
361 dpurdie 1620 
    #   May want two elements, may want one
267 dpurdie 1621 
    #
361 dpurdie 1622 
    return $url, $pkgroot if ( wantarray );
1623 
    return $url . $pkgroot;
267 dpurdie 1624 
}
1625 
 
369 dpurdie 1626 
#-------------------------------------------------------------------------------
1627 
# Function        : SvnPaths
1628 
#
1629 
# Description     : Extract SVN path conversion information
1630 
#
1631 
# Inputs          : Nothing
1632 
#
1633 
# Returns         : Two refs
1634 
#                   Hash of SVN URLS
1635 
#                   Array for search order
1636 
#
1637 
sub SvnPaths
1638 
{
1639 
    return \%SVN_URLS, \@SVN_URLS_LIST;
1640 
}
361 dpurdie 1641 
 
267 dpurdie 1642 
#-------------------------------------------------------------------------------
1643 
# Function        : SplitPackageUrl
1644 
#
1347 dpurdie 1645 
# Description     : Split the package URL into a few useful bits
267 dpurdie 1646 
#
1647 
# Inputs          : $self           - Instance data
1648 
#
1649 
# Returns         : Nothing
1650 
#
1651 
sub SplitPackageUrl
1652 
{
1653 
    my ($self) = @_;
353 dpurdie 1654 
    Debug ("SplitPackageUrl", $self->{URL}, $self->{PKGROOT});
267 dpurdie 1655 
 
1656 
    #
1657 
    #   Remove any protocol that may be present
1658 
    #       http://server/
341 dpurdie 1659 
    #       https://server/
267 dpurdie 1660 
    #       svn://server/
1661 
    #       file://This/Isa/Bad/Guess
1662 
    #
341 dpurdie 1663 
    if ( $self->{URL} =~ m~^(file|http|https|svn)://([^/]+)~ )
267 dpurdie 1664 
    {
1665 
        $self->{PROTOCOL} = $1;
1666 
        $self->{SERVER} = $2;
1667 
    }
1668 
 
1669 
    if ( $self->{PKGROOT} =~ m~(.*)(@\d+)$~ )
1670 
    {
1671 
        $self->{PEG} = $2;
1672 
    }
1673 
 
1674 
    #
1675 
    #   Determine TTB type
1676 
    #   Need to handle
1677 
    #       .../trunk
1678 
    #       .../trunk@nnnnn
1679 
    #       .../tags/version@nnnnn
1680 
    #       .../branches/version@nnnnn
1681 
    #
1682 
    #
1683 
    if (  $self->{PKGROOT} =~ m~/?(.*)/(tags|branches|trunk)(/|$|@)(.*)$~ )
1684 
    {
1685 
        $self->{PATH}         = $1;
1686 
        $self->{TAGTYPE}      = $2;
1687 
        $self->{VERSION}      = $4;
1688 
    }
1689 
    else
1690 
    {
1691 
        $self->{PATH} = $self->{PKGROOT};
1692 
    }
1693 
 
1694 
    DebugDumpData ('SplitPackageUrl', $self ) if ( IsDebug(2) );
1695 
}
1696 
 
1697 
#-------------------------------------------------------------------------------
1698 
# Function        : Full
1699 
#                   FullWs
1700 
#                   Repo
1701 
#                   Peg
1702 
#                   Type
1703 
#                   WsType
1704 
#                   Path
1705 
#                   Version
1706 
#                   RmRef
385 dpurdie 1707 
#                   RmPath
267 dpurdie 1708 
#
1709 
# Description     : Accessor functions
1710 
#
1711 
# Inputs          : $self       - Instance data
1712 
#                                 self (is $_[0])
1713 
#
1714 
# Returns         : Data Item
1715 
#
369 dpurdie 1716 
sub Full        { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }
1717 
sub FullWs      { return $_[0]->{URL} . $_[0]->{WSURL} ; }
1718 
sub FullWsRev   { return $_[0]->{URL} . $_[0]->{WSURL} . '@' . $_[0]->{WSREVNO} ; }
1343 dpurdie 1719 
sub FullPath    { return $_[0]->{URL} . $_[0]->{PATH} ; }
369 dpurdie 1720 
sub Peg         { return $_[0]->{PEG} ; }
1347 dpurdie 1721 
sub DevBranch   { return $_[0]->{DEVBRANCH} || '' ; }
369 dpurdie 1722 
sub Type        { return $_[0]->{TAGTYPE} || '' ; }
1723 
sub WsType      { return $_[0]->{WSTYPE}  || '' ; }
1724 
sub Path        { return $_[0]->{PATH} ; }
1725 
sub Version     { return $_[0]->{VERSION} ; }
1726 
sub RmRef       { return $_[0]->{RMREF} ; }
385 dpurdie 1727 
sub RmPath      { my $path = $_[0]->{RMREF}; $path =~ s~@.*?$~~ ;return  $path; }
1347 dpurdie 1728 
sub SvnTag      { return $_[0]->{SVNTAG} || '' ; }
267 dpurdie 1729 
 
1730 
#-------------------------------------------------------------------------------
1731 
# Function        : Print
1732 
#
1733 
# Description     : Debug display the URL
1734 
#
1735 
# Inputs          : $self           - Instance data
1736 
#                   $header
1737 
#                   $indent
1738 
#
1739 
# Returns         : Nothing
1740 
#
1741 
sub Print
1742 
{
1743 
    my ($self, $header, $indent) = @_;
1744 
    print "$header\n" if $header;
1745 
    $indent = 4 unless ( defined $indent );
1746 
    $indent = ' ' x $indent;
1747 
 
1748 
 
1347 dpurdie 1749 
    print $indent . "PROTOCOL :" . $self->{PROTOCOL} . "\n";
1750 
    print $indent . "SERVER   :" . $self->{SERVER} . "\n";
1751 
    print $indent . "URL      :" . $self->{URL} . "\n";
1752 
    print $indent . "PKGROOT  :" . $self->{PKGROOT} . "\n";
1753 
    print $indent . "PATH     :" . $self->{PATH} . "\n";
1754 
    print $indent . "TAGTYPE  :" . ($self->{TAGTYPE} || '') . "\n";
1755 
    print $indent . "VERSION  :" . ($self->{VERSION} || '') . "\n";
1756 
    print $indent . "PEG      :" . ($self->{PEG} || '') . "\n";
1757 
    print $indent . "DEVBRANCH:" . ($self->{DEVBRANCH} || '') . "\n";
1758 
    print $indent . "SVNTAG   :" . ($self->{SVNTAG} || '') . "\n";
1343 dpurdie 1759 
#    print $indent . "FULL    :" . $self->Full . "\n";
1760 
 
1761 
    print $indent . "Full         :" . $self->Full . "\n";
1762 
#    print $indent . "FullWs       :" . $self->FullWs    . "\n";
1763 
#    print $indent . "FullWsRev    :" . $self->FullWsRev . "\n";
1764 
    print $indent . "FullPath     :" . $self->FullPath  . "\n";
1765 
    print $indent . "Peg          :" . $self->Peg       . "\n";
1347 dpurdie 1766 
    print $indent . "DevBranch    :" . $self->DevBranch . "\n";
1343 dpurdie 1767 
    print $indent . "Type         :" . $self->Type      . "\n";
1768 
    print $indent . "WsType       :" . $self->WsType    . "\n";
1769 
    print $indent . "Path         :" . $self->Path      . "\n";
1770 
    print $indent . "Version      :" . $self->Version   . "\n";
1771 
    print $indent . "RmRef        :" . ($self->RmRef || '') . "\n";
1772 
#    print $indent . "RmPath       :" . ($self->RmPath|| '') . "\n";
267 dpurdie 1773 
}
1774 
 
1775 
#-------------------------------------------------------------------------------
1776 
# Function        : BranchName
1777 
#
1778 
# Description     : Create a full URL to a branch or tag based on the
1779 
#                   current entry
1780 
#
1781 
#                   URL must have a TTB format
1782 
#
1783 
# Inputs          : $self           - Instance data
1784 
#                   $branch         - Name of the branch
1785 
#                   $type           - Optional branch type
1786 
#
1787 
# Returns         : Full URL name to the new branch
1788 
#
1789 
sub BranchName
1790 
{
1791 
    my ($self, $branch, $type ) = @_;
1792 
    Debug ( "BranchName", $branch );
1793 
 
1794 
    $type = 'branches' unless ( $type );
1795 
    my $root = $self->{PKGROOT};
1796 
 
1797 
    $root =~ s~/(tags|branches|trunk)(/|$|@).*~~;
1798 
 
1799 
    return $self->{URL} . $root . '/' . $type . '/' . $branch;
1800 
}
1801 
 
379 dpurdie 1802 
#-------------------------------------------------------------------------------
1803 
# Function        : setRepoProperty
1804 
#
1805 
# Description     : Sets a Repository property
1806 
#                   This may well fail unless the Repo is setup to allow such
1807 
#                   chnages and the user is allowed to make such changes
1808 
#
1809 
# Inputs          : $name
1810 
#                   $value
1341 dpurdie 1811 
#                   $allowError     - Support for bad repositories
379 dpurdie 1812 
#
1341 dpurdie 1813 
# Returns         : 0 - Change made
1814 
#                   Will not return on error
379 dpurdie 1815 
#
1816 
sub setRepoProperty
1817 
{
1341 dpurdie 1818 
    my ($self, $name, $value, $allowError ) = @_;
1819 
    my $retval = 0;
1820 
 
379 dpurdie 1821 
    Debug ( "setRepoProperty", $name, $value );
1822 
    #
1823 
    #   Ensure that the Repo version is known
1824 
    #   This should be set by a previous operation
1825 
    #
1826 
    unless ( defined $self->{REVNO} )
1827 
    {
1828 
        Error ("setRepoProperty. Release Revision Number not known");
1829 
    }
1830 
 
1831 
    #
1832 
    #   Execute the command
1833 
    #
1834 
    if ( $self->SvnCmd ( 'propset' , $name, '--revprop', '-r',  $self->{REVNO}, $value, $self->Full,
1835 
                            {
1836 
                                'credentials' => 1,
1837 
                                'nosavedata' => 1,
1838 
                            }
1839 
                       ) )
1840 
    {
1841 
        #
1842 
        #   Property NOT set
1843 
        #
1341 dpurdie 1844 
        if ( $allowError )
1845 
        {
1846 
            Warning ("setRepoProperty: $name - FAILED");
1847 
            $retval = 1;
1848 
        }
1849 
        else
1850 
        {
1851 
            Error ("setRepoProperty: $name - FAILED");
1852 
        }
379 dpurdie 1853 
    }
1341 dpurdie 1854 
 
1855 
    return $retval;
379 dpurdie 1856 
}
1857 
 
1341 dpurdie 1858 
#-------------------------------------------------------------------------------
1859 
# Function        : backTrackSvnLabel
1860 
#
1861 
# Description     : Examine a Svn Tag and backtrack until we find the branch
1862 
#                   that was used to create the label
1863 
#
1864 
# Inputs          : $self                   - Instance Data
1865 
#                   $src_label              - Label to process
1866 
#                                             Label within the current instance
1349 dpurdie 1867 
#                   A hash of named arguments
1868 
#                       data                - Scalar ref. Hash of good stuff returned
1869 
#                       printdata           - Print RAW svn data
1870 
#                       onlysimple          - Do not do exhaustive scan
1356 dpurdie 1871 
#                       savedevbranch       - Save Dev Branch in session
1341 dpurdie 1872 
#
1873 
# Returns         : Branch from which the label was taken
1874 
#                   or the label prefixed with 'tags'.
1875 
#
1876 
sub backTrackSvnLabel
1877 
{
1349 dpurdie 1878 
    my $self = shift;
1879 
    my $src_label = shift;
1880 
    my %opt = @_;
1881 
    my $branch;
1341 dpurdie 1882 
 
1349 dpurdie 1883 
    Debug ("backTrackSvnLabel");
1884 
    Error ("backTrackSvnLabel: Odd number of args") unless ((@_ % 2) == 0);
1885 
 
1341 dpurdie 1886 
    #
1349 dpurdie 1887 
    #   May need to read and process data twice
1888 
    #   First   - stop on copy. May it fast
1889 
    #   Second  - all the log.
1341 dpurdie 1890 
 
1891 
    #
1892 
    #   extract data
1893 
    #
1349 dpurdie 1894 
    foreach my $mode ( '--stop-on-copy', '' )
1895 
    {
1896 
        #   Init stored data
1897 
        #   Used to communicate with callback function(s)
1898 
        #
1899 
        Information ("backTrackSvnLabel: Performing exhaustive search") unless $mode;
1900 
        $self->{btData} = ();
1901 
        $self->{btData}{results}{base} = $self->FullPath();
1902 
        $self->{btData}{results}{label} = $src_label;
1903 
        $self->{btData}{results}{changeSets} = 0;
1356 dpurdie 1904 
        $self->{btData}{results}{distance} = 0;
1341 dpurdie 1905 
 
1349 dpurdie 1906 
        #
1907 
        #   Linux does not handle empty arguments in the same
1908 
        #   manner as windows. Solution: pass an array
1909 
        #
1910 
        my @mode;
1911 
        push @mode, $mode if ( $mode);
1341 dpurdie 1912 
 
1349 dpurdie 1913 
        $self->SvnCmd ( 'log', '-v', '--xml', '-q'
1914 
                        , @mode
1915 
                        , $self->FullPath() . '/' . $src_label
1916 
                        , { 'credentials' => 1,
1917 
                            'process' => \&ProcessBackTrack,
1918 
                            'printdata' => $opt{printdata},
1919 
                            'nosavedata' => 1,
1920 
                             }
1921 
                            );
1341 dpurdie 1922 
 
1349 dpurdie 1923 
        last if ( $self->{btData}{good} );
1924 
        last if ( $opt{onlysimple} );
1341 dpurdie 1925 
    }
1343 dpurdie 1926 
 
1341 dpurdie 1927 
    #
1349 dpurdie 1928 
    #   Did not backtrack to a branch (or trunk)
1929 
    #   Return the users label
1341 dpurdie 1930 
    #
1349 dpurdie 1931 
    unless ( $self->{btData}{good} )
1341 dpurdie 1932 
    {
1348 dpurdie 1933 
        $branch = $src_label;
1341 dpurdie 1934 
    }
1349 dpurdie 1935 
    else
1936 
    {
1937 
        $branch = $self->{btData}{results}{devBranch};
1356 dpurdie 1938 
        if ( $opt{savedevbranch} )
1939 
        {
1940 
            $self->{btData}{results}{devBranch} =~ m~^(.*?)(@|$)~;
1941 
            $self->{DEVBRANCH} = $1;
1942 
        }
1943 
 
1349 dpurdie 1944 
    }
1341 dpurdie 1945 
 
1344 dpurdie 1946 
    #
1349 dpurdie 1947 
    #   Return data to the user
1344 dpurdie 1948 
    #
1349 dpurdie 1949 
    if ( my $refData = $opt{data} )
1950 
    {
1951 
        Error ('Internal: backTrackSvnLabel. Arg to "data" must be ref to a scalar')
1952 
            unless ( ref($refData) eq 'SCALAR' );
1953 
        $$refData = $self->{btData}{results};
1954 
    }
1955 
 
1956 
    #
1957 
    #   Clean up the data
1958 
    #
1344 dpurdie 1959 
    delete $self->{btData};
1341 dpurdie 1960 
    return $branch;
1961 
}
1962 
 
1963 
#-------------------------------------------------------------------------------
1964 
# Function        : ProcessBackTrack
1965 
#
1966 
# Description     :
1967 
#                   Parse
1968 
#                       <logentry
1969 
#                          revision="24272">
1970 
#                       <author>bivey</author>
1971 
#                       <date>2005-07-25T15:45:35.000000Z</date>
1972 
#                       <paths>
1973 
#                       <path
1974 
#                          prop-mods="false"
1975 
#                          text-mods="false"
1976 
#                          kind="dir"
1977 
#                          copyfrom-path="/enqdef/branches/Stockholm"
1978 
#                          copyfrom-rev="24271"
1979 
#                          action="A">/enqdef/tags/enqdef_24.0.1.sls</path>
1980 
#                       </paths>
1981 
#                       <msg>COTS/enqdef: Tagged by Jats Svn Import</msg>
1982 
#                       </logentry>
1983 
#
1984 
#
1985 
#                   Uses:   $self->{btData}     - Scratch Data
1986 
#
1987 
# Inputs          : $self           - Class Data
1988 
#                   $line           - Input data to parse
1989 
#
1990 
# Returns         : 0 - Do not terminate input command
1991 
#
1992 
sub  ProcessBackTrack
1993 
{
1994 
    my ($self, $line ) = @_;
1995 
    Message ( $line ) if $self->{PRINTDATA};
1996 
 
1349 dpurdie 1997 
    $line =~ s~\s+$~~;
1998 
    next unless ( $line );
1999 
#    Debug0('', $line);
2000 
 
2001 
    my $workSpace =  \%{$self->{btData}};
2002 
    if ( $line =~ m~<logentry$~ ) {
2003 
        $workSpace->{mode} = 'l';
2004 
        $workSpace->{rev} = 0;
2005 
        $workSpace->{changesSeen} = 0;
2006 
 
2007 
    } elsif ( $line =~ m~</logentry>$~ ) {
2008 
        $workSpace->{mode} = '';
2009 
 
2010 
        #
2011 
        #   End of a <logenty>
2012 
        #   See if we have a result - a dev branch not copied from a tag
2013 
        #
2014 
        if ( exists $workSpace->{devBranch} )
2015 
        {
2016 
            $workSpace->{results}{distance}++;
2017 
            $workSpace->{devBranch} =~ m~/((tags|branches|trunk)(/|\@).*)~;
2018 
            my $devBranch = $1;
2019 
 
2020 
            push @{$workSpace->{results}{paths}}, $devBranch;
2021 
            unless ( $devBranch =~ m ~^tags~ )
2022 
            {
2023 
                $workSpace->{results}{devBranch} = $devBranch;
2024 
                $workSpace->{results}{isaBranch} = 1;
2025 
                $workSpace->{good} = 1;
2026 
                return 1;
2027 
            }
2028 
        }
2029 
 
2030 
    } elsif ( $line =~ m~<path$~ ) {
2031 
        $workSpace->{mode} = 'p';
2032 
        Error ('Path without Rev') unless ( $workSpace->{rev} );
2033 
 
2034 
    } elsif ( $line =~ m~</paths>$~ ) {
2035 
        $workSpace->{mode} = '';
1344 dpurdie 2036 
    }
1349 dpurdie 2037 
    return 0 unless ( $workSpace->{mode} );
1344 dpurdie 2038 
 
1349 dpurdie 2039 
    if ( $workSpace->{mode} eq 'l' )
2040 
    {
2041 
        #
2042 
        #   Processing logentry data
2043 
        #       Only need the rev
2044 
        #
2045 
        $workSpace->{rev} = $1
2046 
            if ( $line =~ m~revision=\"(\d+)\"~ );
2047 
 
2048 
    } elsif ( $workSpace->{mode} eq 'p' ) {
2049 
        #
2050 
        #   Processing Paths
2051 
        #       Entries appear to be in a random order
2052 
        #       Not always the same order
2053 
        #
2054 
        my $end = 0;
2055 
        if ( $line =~ s~\s*(.+?)="(.+)">(.*)</path>$~~ )
2056 
        {
2057 
            #
2058 
            #   Last entry has two items
2059 
            #       Attribute
2060 
            #       Data Item
2061 
            #
2062 
            $end = 1;
2063 
            $workSpace->{path}{$1} = $2;
2064 
            $workSpace->{path}{DATA} = $3;
2065 
        }
2066 
        elsif ($line =~ m~\s*(.*?)="(.*)"~ )
2067 
        {
2068 
            $workSpace->{path}{$1} = $2;
2069 
        }
2070 
#        else
2071 
#        {
2072 
#            Warning ("Cannot decode XML log: $line");
2073 
#        }
2074 
 
2075 
        if ( $end )
2076 
        {
1356 dpurdie 2077 
            #
2078 
            #   If the Repo is created by a pre 1.6 SVN, then kind will be
2079 
            #   empty. Have a guess.
2080 
            #
2081 
            if ( $workSpace->{path}{'kind'} eq '' )
1349 dpurdie 2082 
            {
1356 dpurdie 2083 
                if ( exists $workSpace->{path}{'copyfrom-path'} ) {
2084 
                    $workSpace->{path}{'kind'} = 'dir';
2085 
                } else {
2086 
                    $workSpace->{path}{'kind'} = 'file';
2087 
                }
2088 
            }
2089 
 
2090 
            if ( $workSpace->{path}{'kind'} eq 'dir' &&  exists $workSpace->{path}{'copyfrom-path'} )
2091 
            {
1349 dpurdie 2092 
                my $srev = $workSpace->{path}{'copyfrom-rev'};
1356 dpurdie 2093 
                my $from = $workSpace->{path}{'copyfrom-path'};
2094 
                if ( $from =~ m~/trunk$~ || $from =~ m~/branches/[^/]+$~ )
2095 
                {
2096 
                    $workSpace->{devBranch} = $from . '@' . $srev;
2097 
                }
1349 dpurdie 2098 
            }
2099 
 
2100 
            elsif ( $workSpace->{path}{'kind'} eq 'file' )
2101 
            {
2102 
                #
2103 
                #   Track files that have been changed between tag and branch
2104 
                #   The log is presented as newest first
2105 
                #   The files have a tag-name component.
2106 
                #       Remove the tag name - so that we can compare files
2107 
                #       Save the first instance of changed files
2108 
                #           Others will be in older versions
2109 
                #           and thus of no interest
2110 
                #
2111 
                #   Count the chnage sets that have changes
2112 
                #   Having changes in multiple change sets indicates
2113 
                #   development on a /tags/ - which is BAD
2114 
                #
2115 
                $workSpace->{path}{'DATA'} =~ m~(.+)/((tags|branches|trunk)(/|$).*)~;
2116 
                my $file =  $2;
2117 
                my $full = $file;
2118 
                $file =~ s~^tags/(.+?)/~~;
2119 
 
2120 
                if ( ! exists $workSpace->{files}{$file}  )
2121 
                {
2122 
                    push @{$workSpace->{results}{files}}, $full . '@' . $workSpace->{rev};
2123 
                }
2124 
                $workSpace->{files}{$file}++;
2125 
                $workSpace->{firstFile} = $file unless ( defined $workSpace->{firstFile} );
2126 
 
2127 
                unless ( $workSpace->{changesSeen} )
2128 
                {
2129 
                    unless( $workSpace->{firstFile} eq $file )
2130 
                    {
2131 
                        $workSpace->{results}{changeSets}++;
2132 
                        $workSpace->{changesSeen}++;
2133 
                    }
2134 
                }
2135 
 
2136 
                if ( scalar keys %{$workSpace->{files}} > 1 )
2137 
                {
2138 
                    $workSpace->{results}{multipleChanges} = 1;
2139 
                    Verbose ("backTrackSvnLabel: Changes in multiple versions");
2140 
                }
2141 
            }
2142 
 
2143 
            delete $workSpace->{path};
2144 
        }
1341 dpurdie 2145 
    }
2146 
 
2147 
    #
2148 
    #   Return 0 to keep on going
2149 
    return 0;
2150 
}
2151 
 
267 dpurdie 2152 
#------------------------------------------------------------------------------
2153 
1;