Subversion Repositories DevTools

Rev

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