Subversion Repositories DevTools

Rev

Rev 7272 | Details | Compare with Previous | Last modification | View Log | RSS feed

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