Subversion Repositories DevTools

Rev

Rev 1329 | Rev 1431 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 1329 Rev 1403
Line 72... Line 72...
72 
#
 72 
#
73 
# Description     : Create a workspace
 73 
# Description     : Create a workspace
74 
#                   Can be used to extract files, without creating the
 74 
#                   Can be used to extract files, without creating the
75 
#                   subversion control files.
 75 
#                   subversion control files.
76 
#
 76 
#
77 
# Inputs          : $self               - Instance data
 77 
# Inputs          : $self                   - Instance data
78 
#                   $RepoPath           - Within the repository
 78 
#                   $RepoPath               - Within the repository
79 
#                   $Path               - Local path
 79 
#                   $Path                   - Local path
80 
#                   Options             - Options
 80 
#                   Hash of Options
81 
#                           --Export    - Export Only
 81 
#                           export          - Bool: Export Only
- 
 
 82 
#                           force           - Bool: Force export to overwrite
82 
#                           --NoPrint   - Don't print files exported
 83 
#                           print           - Bool: Don't print files exported
- 
 
 84 
#                           pretext=aa      - Text: Display before operation
83 
#
 85 
#
84 
# Returns         : Nothing
 86 
# Returns         : Nothing
85 
#
 87 
#
86 
sub SvnCo
 88 
sub SvnCo
87 
{
 89 
{
- 
 
 90 
    my $self = shift;
88 
    my ($self, $RepoPath, $path, @opts) = @_;
 91 
    my $RepoPath = shift;
89 
    my $export = grep (/^--Export/, @opts );
 92 
    my $path = shift;
90 
    $self->{PRINTDATA} = ! grep (/^--NoPrint/, @opts );
 93 
    my %opt = @_;
- 
 
 94
91 
    Debug ("SvnCo", $RepoPath, $path);
 95 
    Debug ("SvnCo", $RepoPath, $path);
- 
 
 96 
    Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);
- 
 
 97 
 
- 
 
 98 
    #
- 
 
 99 
    #   Set some defaults
- 
 
 100 
    #
- 
 
 101 
    my $cmd = $opt{export} ? 'export' : 'checkout';
- 
 
 102 
    my $print = exists $opt{print} ? $opt{print} : 1;
- 
 
 103 
    $self->{CoText} =  $opt{pretext} || 'Extracting';
92 
 
 104 
 
93 
    #
 105 
    #
94 
    #   Ensure that the output path does not exist
 106 
    #   Ensure that the output path does not exist
95 
    #   Do not allow the user to create a local work space
 107 
    #   Do not allow the user to create a local work space
96 
    #   where one already exists
 108 
    #   where one already exists
97 
    #
 109 
    #
98 
    Error ("SvnCo: No PATH specified" ) unless ( $path );
 110 
    Error ("SvnCo: No PATH specified" ) unless ( $path );
99 
    Error ("SvnCo: Target path already exists", "Path: " . $path ) if ( -e $path );
 111 
    Error ("SvnCo: Target path already exists", "Path: " . $path ) if ( ! $opt{force} && -e $path  );
100 
 
 112 
 
101 
    #
 113 
    #
102 
    #   Build up the command line
 114 
    #   Build up the command line
103 
    #
 115 
    #
104 
    my @args = $export ? 'export' : 'checkout';
 116 
    my @args = $cmd;
105 
    push @args, qw( --ignore-externals );
 117 
    push @args, qw( --ignore-externals );
- 
 
 118 
    push @args, qw( --force ) if ( $opt{force} );
106 
    push @args, $RepoPath, $path;
 119 
    push @args, $RepoPath, $path;
107 
 
 120 
 
108 
 
 - 
 
109 
    my @co_list;
 121 
    my @co_list;
110 
    if ( $self->SvnCmd ( @args,
 122 
    if ( $self->SvnCmd ( @args,
111 
                            {
 123 
                            {
112 
                                'process' => \&ProcessCo,
 124 
                                'process' => \&ProcessCo,
113 
                                'data' => \@co_list,
 125 
                                'data' => \@co_list,
114 
                                'credentials' => 1,
 126 
                                'credentials' => 1,
115 
                                'nosavedata' => 1,
 127 
                                'nosavedata' => 1,
- 
 
 128 
                                'printdata' => $print,
116 
                            }
 129 
                            }
117 
                       ) || @co_list )
 130 
                       ) || @co_list )
118 
    {
 131 
    {
119 
        #
 132 
        #
120 
        #   We have a checkout limitation
 133 
        #   We have a checkout limitation
Line 126... Line 139...
126 
        Verbose2 ("Remove WorkSpace: $path");
 139 
        Verbose2 ("Remove WorkSpace: $path");
127 
        rmtree( $path, IsVerbose(3) );
 140 
        rmtree( $path, IsVerbose(3) );
128 
        rmtree( $path, IsVerbose(3) );
 141 
        rmtree( $path, IsVerbose(3) );
129 
        Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );
 142 
        Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );
130 
    }
 143 
    }
131 
    $self->{PRINTDATA} = 0;
 - 
 
132 
    return;
 144 
    return;
133 
 
 145 
 
134 
    #
 146 
    #
135 
    #   Internal routine to scan each the checkout
 147 
    #   Internal routine to scan each the checkout
136 
    #
 148 
    #
Line 151... Line 163...
151 
 
 163 
 
152 
        if ( $self->{PRINTDATA} )
 164 
        if ( $self->{PRINTDATA} )
153 
        {
 165 
        {
154 
            #
 166 
            #
155 
            #   Pretty display for user
 167 
            #   Pretty display for user
- 
 
 168 
            #   Hide some noise, but not much
156 
            #
 169 
            #
- 
 
 170 
            unless ( $data =~ m~^Export complete.~ )
- 
 
 171 
            {
157 
            Information1 ("Extracting: $data");
 172 
                Information1 ( $self->{CoText} . ': ' . $data);
- 
 
 173 
            }
158 
        }
 174 
        }
159 
 
 175 
 
160 
        if (  $data =~ m~((/)(tags|branches|trunk)(/|$))~ )
 176 
        if (  $data =~ m~((/)(tags|branches|trunk)(/|$))~ )
161 
        {
 177 
        {
162 
            my $bad_dir = $1;
 178 
            my $bad_dir = $1;
Line 177... Line 193...
177 
        #}
 193 
        #}
178 
    }
 194 
    }
179 
}
 195 
}
180 
 
 196 
 
181 
#-------------------------------------------------------------------------------
 197 
#-------------------------------------------------------------------------------
- 
 
 198 
# Function        : SvnSwitch
- 
 
 199 
#
- 
 
 200 
# Description     : Switches files and directories
- 
 
 201 
#
- 
 
 202 
# Inputs          : $self               - Instance data
- 
 
 203 
#                   $RepoPath           - Within the repository
- 
 
 204 
#                   $Path               - Local path
- 
 
 205 
#                   Options             - Options
- 
 
 206 
#                           --NoPrint   - Don't print files exported
- 
 
 207 
#
- 
 
 208 
# Returns         : Nothing
- 
 
 209 
#
- 
 
 210 
sub SvnSwitch
- 
 
 211 
{
- 
 
 212 
    my ($self, $RepoPath, $path, @opts) = @_;
- 
 
 213 
    my $printdata = ! grep (/^--NoPrint/, @opts );
- 
 
 214 
    Debug ("SvnSwitch", $RepoPath, $path);
- 
 
 215 
 
- 
 
 216 
    #
- 
 
 217 
    #   Build up the command line
- 
 
 218 
    #
- 
 
 219 
    my @sw_list;
- 
 
 220 
    if ( $self->SvnCmd ( 'switch', $RepoPath, $path,
- 
 
 221 
                            {
- 
 
 222 
                                'process' => \&ProcessSwitch,
- 
 
 223 
                                'data' => \@sw_list,
- 
 
 224 
                                'credentials' => 1,
- 
 
 225 
                                'nosavedata' => 1,
- 
 
 226 
                                'printdata' => $printdata,
- 
 
 227 
                            }
- 
 
 228 
                       ) || @sw_list )
- 
 
 229 
    {
- 
 
 230 
        #
- 
 
 231 
        #   We have a switch problem
- 
 
 232 
        #   Delete the workspace and then report the error
- 
 
 233 
        #
- 
 
 234 
        #   Note: For some reason a simple rmtree doesn't work
- 
 
 235 
        #         Nor does glob show all the directories
- 
 
 236 
        #
- 
 
 237 
        Verbose2 ("Remove WorkSpace: $path");
- 
 
 238 
        rmtree( $path, IsVerbose(3) );
- 
 
 239 
        rmtree( $path, IsVerbose(3) );
- 
 
 240 
        Error ("Switch elements", @{$self->{ERROR_LIST}}, @sw_list );
- 
 
 241 
    }
- 
 
 242 
    return;
- 
 
 243 
 
- 
 
 244 
    #
- 
 
 245 
    #   Internal routine to scan each line of the Switch output
- 
 
 246 
    #   Use to provide a nice display
- 
 
 247 
    #
- 
 
 248 
    sub ProcessSwitch
- 
 
 249 
    {
- 
 
 250 
        my $self = shift;
- 
 
 251 
        my $data = shift;
- 
 
 252 
 
- 
 
 253 
        if ( $self->{PRINTDATA} )
- 
 
 254 
        {
- 
 
 255 
            #
- 
 
 256 
            #   Pretty display for user
- 
 
 257 
            #
- 
 
 258 
            Information1 ("Switching : $data");
- 
 
 259 
        }
- 
 
 260 
    }
- 
 
 261 
}
- 
 
 262 
 
- 
 
 263 
#-------------------------------------------------------------------------------
182 
# Function        : SvnCi
 264 
# Function        : SvnCi
183 
#
 265 
#
184 
# Description     : Check in the specified WorkSpace
 266 
# Description     : Check in the specified WorkSpace
185 
#
 267 
#
186 
# Inputs          : $self           - Instance data
 268 
# Inputs          : $self           - Instance data
Line 277... Line 359...
277 
#
 359 
#
278 
# Description     : Create a package and any associated files
 360 
# Description     : Create a package and any associated files
279 
#
 361 
#
280 
# Inputs          : $self        - Instance data
 362 
# Inputs          : $self        - Instance data
281 
#                   A hash of named arguments
 363 
#                   A hash of named arguments
282 
#                       package  - Name of the package
 364 
#                       package     - Name of the package
283 
#                                  May include subdirs
 365 
#                                     May include subdirs
284 
#                       new      - True: Must not already exist
 366 
#                       new         - True: Must not already exist
285 
#                       replace  - True: Replace targets
 367 
#                       replace     - True: Replace targets
286 
#                       import   - DirTree to import
 368 
#                       import      - DirTree to import
287 
#                       label    - Tag for imported DirTree
 369 
#                       label       - Tag for imported DirTree
288 
#                       type     - Import TTB target
 370 
#                       type        - Import TTB target
- 
 
 371 
#                       printdata   - True: Print extracted files (default)
- 
 
 372 
#
289 
#
 373 
#
290 
# Returns         : Revision of the copy
 374 
# Returns         : Revision of the copy
291 
#
 375 
#
292 
sub SvnCreatePackage
 376 
sub SvnCreatePackage
293 
{
 377 
{
Line 300... Line 384...
300 
    my %dirs = ( 'trunk/'       => 0,
 384 
    my %dirs = ( 'trunk/'       => 0,
301 
                 'tags/'        => 0,
 385 
                 'tags/'        => 0,
302 
                 'branches/'    => 0 );
 386 
                 'branches/'    => 0 );
303 
 
 387 
 
304 
    #
 388 
    #
305 
    #   Sanity Tests
 389 
    #   Sanity Tests and defaul values
306 
    #
 390 
    #
307 
    my $package = $self->Full || Error ("SvnCreatePackage: No package name provided");
 391 
    my $package = $self->Full || Error ("SvnCreatePackage: No package name provided");
308 
    Error ("SvnCreatePackage: Invalid import path") if ( $opt{'import'} && ! -d $opt{'import'} );
 392 
    Error ("SvnCreatePackage: Invalid import path") if ( $opt{'import'} && ! -d $opt{'import'} );
309 
    Error ("SvnCreatePackage: Tag without Import") if ( $opt{'label'} && ! $opt{'import'} );
 393 
    Error ("SvnCreatePackage: Tag without Import") if ( $opt{'label'} && ! $opt{'import'} );
310 
    $opt{'label'} = SvnIsaSimpleLabel( $opt{'label'} ) if (  $opt{'label'} );
 394 
    $opt{'label'} = SvnIsaSimpleLabel( $opt{'label'} ) if (  $opt{'label'} );
- 
 
 395 
    $opt{'printdata'} = 1 unless ( exists $opt{'printdata'} );
311 
 
 396 
 
312 
    #
 397 
    #
313 
    #   Package path cannot contain any of the keyword paths tags,trunk,branches
 398 
    #   Package path cannot contain any of the keyword paths tags,trunk,branches
314 
    #   as this would place a package with a package
 399 
    #   as this would place a package with a package
315 
    #
 400 
    #
Line 322... Line 407...
322 
    Error ("Package name contains a Peg ($1)", "Path: $package")
 407 
    Error ("Package name contains a Peg ($1)", "Path: $package")
323 
        if ( $package =~ m~.*(@\d+)$~ );
 408 
        if ( $package =~ m~.*(@\d+)$~ );
324 
 
 409 
 
325 
    #
 410 
    #
326 
    #   Determine TTB target
 411 
    #   Determine TTB target
- 
 
 412 
    #   The TTB type for branches and tags also conatins the branch or tag
327 
    #
 413 
    #
328 
    $opt{'type'} = 'trunk' unless ( $opt{'type'} );
 414 
    $opt{'type'} = 'trunk' unless ( $opt{'type'} );
329 
    Error ("Invalid TTB type") unless ( $opt{'type'} =~ m{^(tags|branches|trunk)$} );
 415 
    if ( $opt{'type'} =~ m~^(tags|branches|trunk)(/|$)(.*)~ ) {
- 
 
 416 
        Error ("SvnCreatePackage: TTB type ($1) must be followed by a path element")
- 
 
 417 
            if ( (($1 eq 'tags') or ($1 eq 'branches' )) && ! $3  );
- 
 
 418 
        Error ('SvnCreatePackage: TTB type of trunk must not be followed by a path element: ' . $opt{'type'})
- 
 
 419 
            if ( ($1 eq 'trunk') && $3  );
- 
 
 420 
    } else {
330 
    Error ("Import without label") if ( $opt{'type'} ne  'trunk'  && ! $opt{'label'} );
 421 
        Error ("SvnCreatePackage: Invalid TTB Type: " . $opt{'type'} );
- 
 
 422 
    }
331 
 
 423 
 
332 
    #
 424 
    #
333 
    #   Before we import data we must ensure that the targets do not exist
 425 
    #   Before we import data we must ensure that the targets do not exist
334 
    #   Determine the import target(s)
 426 
    #   Determine the import target(s)
335 
    #
 427 
    #
336 
    my $import_target;
 428 
    my $import_target;
337 
    my $copy_target;
 429 
    my $copy_target;
338 
 
 430 
 
- 
 
 431 
    $self->{DEVBRANCH} = 'trunk';
339 
    if ( $opt{'import'} )
 432 
    if ( $opt{'import'} )
340 
    {
 433 
    {
341 
        #
 434 
        #
342 
        #   Primary target
 435 
        #   Primary target
343 
        #   trunk, branck or tag
 436 
        #   trunk, branck or tag
344 
        #
 437 
        #
345 
        $import_target = $package . '/' . $opt{'type'};
 438 
        $import_target = $package . '/' . $opt{'type'};
346 
        $import_target .= '/' .$opt{'label'} if ( $opt{'type'} ne 'trunk');
 439 
        $self->{DEVBRANCH} = $opt{'type'} ;
347 
 
 440 
 
348 
        $self->SvnValidateTarget( 'target'    => $import_target,
 441 
        $self->SvnValidateTarget( 'target'    => $import_target,
349 
                                  'delete'    => $opt{'replace'},
 442 
                                  'delete'    => $opt{'replace'},
350 
                                  'available' => 1 );
 443 
                                  'available' => 1 );
351 
 
 444 
 
352 
        #
 445 
        #
353 
        #   Secondary target
 446 
        #   Secondary target
354 
        #   If primary is a trunk and a label is provided
 447 
        #   Are we tagging the import too
355 
        #
 448 
        #
356 
        if ( $opt{'type'} eq 'trunk' && $opt{'label'} )
 449 
        if ( $opt{'label'} )
357 
        {
 450 
        {
358 
            $copy_target = $package . '/tags/' . $opt{'label'};
 451 
            $copy_target = $package . '/tags/' . $opt{'label'};
359 
            $self->SvnValidateTarget( 'target'    => $copy_target,
 452 
            $self->SvnValidateTarget( 'target'    => $copy_target,
360 
                                      'delete'    => $opt{'replace'},
 453 
                                      'delete'    => $opt{'replace'},
361 
                                      'available' => 1 );
 454 
                                      'available' => 1 );
Line 364... Line 457...
364 
 
 457 
 
365 
    #
 458 
    #
366 
    #   Probe to see if the package exists
 459 
    #   Probe to see if the package exists
367 
    #
 460 
    #
368 
    my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'SvnCreatePackage', $package );
 461 
    my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'SvnCreatePackage', $package );
369 
 
 - 
 
370 
    if ( @$ref_dirs )
 462 
    if ( @$ref_dirs )
371 
    {
 463 
    {
372 
        Error ("SvnCreatePackage: Package directory exists",
 464 
        Error ("SvnCreatePackage: Package directory exists",
373 
               "Cannot create a package here. Unexpected subdirectories:", @$ref_dirs);
 465 
               "Cannot create a package here. Unexpected subdirectories:", @$ref_dirs);
374 
    }
 466 
    }
Line 407... Line 499...
407 
        else
 499 
        else
408 
        {
 500 
        {
409 
            Warning ("SvnCreatePackage: Package already present");
 501 
            Warning ("SvnCreatePackage: Package already present");
410 
        }
 502 
        }
411 
    }
 503 
    }
412 
 
 - 
 
413 
    #
 504 
    #
414 
    #   Create package directories that have not been discovered
 505 
    #   Create package directories that have not been discovered
415 
    #       trunk
 506 
    #       trunk
416 
    #       branches
 507 
    #       branches
417 
    #       tags
 508 
    #       tags
Line 444... Line 535...
444 
    if ( $import_target )
 535 
    if ( $import_target )
445 
    {
 536 
    {
446 
        Verbose ("Importing directory into new package: $opt{'import'}");
 537 
        Verbose ("Importing directory into new package: $opt{'import'}");
447 
 
 538 
 
448 
        $target = $import_target;
 539 
        $target = $import_target;
449 
        $self->{PRINTDATA} = 1;
 540 
        $self->{PRINTDATA} = $opt{'printdata'};
450 
        $self->SvnCmd ('import', $opt{'import'}
 541 
        $self->SvnCmd ('import', $opt{'import'}
451 
                        , $target
 542 
                        , $target
452 
                        , '-m', 'Import by SvnCreatePackage'
 543 
                        , '-m', 'Import by SvnCreatePackage'
453 
                        , '--force'
 544 
                        , '--force'
454 
                        , { 'credentials' => 1
 545 
                        , { 'credentials' => 1
455 
                           ,'error' => "Import Incomplete"
 546 
                           ,'error' => "Import Incomplete"
456 
                           ,'process' => \&ProcessRevNo
 547 
                           ,'process' => \&ProcessRevNo
- 
 
 548 
                           ,'printdata' => $opt{'printdata'}
457 
                          })
 549 
                          })
458 
    }
 550 
    }
459 
 
 551 
 
460 
    #
 552 
    #
461 
    #   If imported to the trunk AND a label is provided
 553 
    #   If imported to the trunk AND a label is provided
Line 473... Line 565...
473 
                          , 'process' => \&ProcessRevNo
 565 
                          , 'process' => \&ProcessRevNo
474 
                          , 'error' => "Import Incomplete" } );
 566 
                          , 'error' => "Import Incomplete" } );
475 
    }
 567 
    }
476 
 
 568 
 
477 
    #
 569 
    #
- 
 
 570 
    #   If we have done very little then we won't know the version
- 
 
 571 
    #   of the repo. Need to force it
- 
 
 572 
    #
- 
 
 573 
    unless ( $self->{REVNO} || $self->{WSREVNO} )
- 
 
 574 
    {
- 
 
 575 
        $self->SvnInfo( $package, 'InfoRepo' );
- 
 
 576 
        $self->{REVNO}  = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCreatePackage: Bad info for Repository");
- 
 
 577 
    }
- 
 
 578 
 
- 
 
 579 
 
- 
 
 580 
    #
478 
    #   Pass the updated revision number back to the user
 581 
    #   Pass the updated revision number back to the user
479 
    #
 582 
    #
480 
    $self->CalcRmReference($target);
 583 
    $self->CalcRmReference($target);
481 
    Message ("Create Package Tag is: " . $self->{RMREF} );
 584 
    Message ("Create Package Rm Ref : " . $self->RmRef);
- 
 
 585 
    Message ("Create Package Vcs Tag: " . $self->SvnTag);
482 
    return $self->{RMREF} ;
 586 
    return $self->{RMREF} ;
483 
}
 587 
}
484 
 
 588 
 
485 
#-------------------------------------------------------------------------------
 589 
#-------------------------------------------------------------------------------
486 
# Function        : SvnRmView
 590 
# Function        : SvnRmView
Line 575... Line 679...
575 
#                       modified - Array of files that are allowed to
 679 
#                       modified - Array of files that are allowed to
576 
#                                  be modified in the workspace.
 680 
#                                  be modified in the workspace.
577 
#                       noswitch        - True: Don't switch to the new URL
 681 
#                       noswitch        - True: Don't switch to the new URL
578 
#                       replace         - True: Delete existing tag if present
 682 
#                       replace         - True: Delete existing tag if present
579 
#                       allowLocalMods  - True: Allow complex tagging
 683 
#                       allowLocalMods  - True: Allow complex tagging
- 
 
 684 
#                       noupdatecheck   - True: Do not check that the WS is up to date
580 
#
 685 
#
581 
# Returns         : Revision of the copy
 686 
# Returns         : Revision of the copy
582 
#
 687 
#
583 
sub SvnCopyWs
 688 
sub SvnCopyWs
584 
{
 689 
{
Line 608... Line 713...
608 
 
 713 
 
609 
    #
 714 
    #
610 
    #   Ensure the Workspace is up to date
 715 
    #   Ensure the Workspace is up to date
611 
    #       Determine the state of the Repo and the Workspace
 716 
    #       Determine the state of the Repo and the Workspace
612 
    #
 717 
    #
- 
 
 718 
    unless ( $opt{noupdatecheck} )
- 
 
 719 
    {
613 
    $self->SvnInfo( $self->{WS} , 'InfoWs' );
 720 
        $self->SvnInfo( $self->{WS} , 'InfoWs' );
614 
    $self->SvnInfo( $self->FullWs, 'InfoRepo' );
 721 
        $self->SvnInfo( $self->FullWs, 'InfoRepo' );
615 
 
 - 
 
616 
    my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Workspace");
 - 
 
617 
    my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Repository");
 - 
 
618 
 
 722 
 
619 
    Verbose("WS Rev  : $wsLastChangedRev");
 723 
        my $wsLastChangedRev = $self->{'InfoWs'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Workspace");
620 
    Verbose("Repo Rev: $repoLastChangedRev");
 724 
        my $repoLastChangedRev = $self->{'InfoRepo'}{'Last Changed Rev'} || Error ("SvnCopyWs: Bad info for Repository");
621 
 
 725 
 
- 
 
 726 
        Verbose("WS Rev  : $wsLastChangedRev");
- 
 
 727 
        Verbose("Repo Rev: $repoLastChangedRev");
622 
    Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',
 728 
        Error ('SvnCopyWs: The repository has been modified since the workspace was last updated.',
623 
           'Possibly caused by a commit without an update.',
 729 
               'Possibly caused by a commit without an update.',
624 
           'Update the workspace and try again.',
 730 
               'Update the workspace and try again.',
625 
           "Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );
 731 
               "Last Changed Rev. Repo: $repoLastChangedRev. Ws:$wsLastChangedRev") if ( $repoLastChangedRev > $wsLastChangedRev );
- 
 
 732 
    }
626 
 
 733 
 
627 
    #
 734 
    #
628 
    #   Examine the workspace and ensure that there are no modified
 735 
    #   Examine the workspace and ensure that there are no modified
629 
    #   files - unless they are expected
 736 
    #   files - unless they are expected
630 
    #
 737 
    #
Line 652... Line 759...
652 
    #   a commit.
 759 
    #   a commit.
653 
    #
 760 
    #
654 
    #   Moreover, files that are modified in the local workspace will
 761 
    #   Moreover, files that are modified in the local workspace will
655 
    #   be copied and checked into the target, but this is not nice.
 762 
    #   be copied and checked into the target, but this is not nice.
656 
    #
 763 
    #
657 
    $self->{PRINTDATA} = 1;
 - 
 
658 
    $rv = $self->SvnCmd ( 'cp'  , $path
 764 
    $rv = $self->SvnCmd ( 'cp'  , $path
659 
                        , $target
 765 
                        , $target
660 
                        , '--parents'
 766 
                        , '--parents'
661 
                        , '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),
 767 
                        , '-m', SvnComment( $opt{'comment'}, 'Created by SvnCopyWs' ),
662 
                        , { 'process' => \&ProcessRevNo,
 768 
                        , { 'process' => \&ProcessRevNo,
663 
                            'credentials' => 1, }
 769 
                            'credentials' => 1,
- 
 
 770 
                            'printdata' => 1,
- 
 
 771 
                             }
664 
                        );
 772 
                        );
665 
    $self->{PRINTDATA} = 0;
 - 
 
666 
    if ($rv)
 773 
    if ($rv)
667 
    {
 774 
    {
668 
        #
 775 
        #
669 
        #   Error in copy
 776 
        #   Error in copy
670 
        #   Attempt to delete the target. Don't worry if we can't do that
 777 
        #   Attempt to delete the target. Don't worry if we can't do that
Line 697... Line 804...
697 
    }
 804 
    }
698 
 
 805 
 
699 
    #
 806 
    #
700 
    #   Pass the updated revision number back to the user
 807 
    #   Pass the updated revision number back to the user
701 
    #
 808 
    #
702 
    $self->CalcRmReference($target );
 809 
    $self->CalcRmReference($target);
703 
    #Message ("Tag is: " . $self->{RMREF} );
 810 
    #Message ("Tag is: " . $self->{RMREF} );
704 
    return $self->{RMREF} ;
 811 
    return $self->{RMREF} ;
705 
}
 812 
}
706 
 
 813 
 
707 
#-------------------------------------------------------------------------------
 814 
#-------------------------------------------------------------------------------
Line 819... Line 926...
819 
#
 926 
#
820 
# Description     : Determine a list of packages within the repo
 927 
# Description     : Determine a list of packages within the repo
821 
#                   This turns out to be a very slow process
 928 
#                   This turns out to be a very slow process
822 
#                   so don't use it unless you really really need to
 929 
#                   so don't use it unless you really really need to
823 
#
 930 
#
- 
 
 931 
# Inputs          : $self       - Instance data
824 
# Inputs          : $repo       - Name of the repository
 932 
#                   $repo       - Name of the repository
- 
 
 933 
#                   Last argument may be a hash of options.
- 
 
 934 
#                           Progress    - True: Show progress
- 
 
 935 
#                           Show        - >1 : display matched Tags and stats
- 
 
 936 
#                                         >2 : display Packages
- 
 
 937 
#                           Tag         - Enable Tag Matching
- 
 
 938 
#                                         Value is the tag to match
825 
#
 939 
#
826 
# Returns         :
940 
# Returns         : Ref to an array of all packages
- 
 
 941 
#                   Ref to an array of all packahes with matched tag
827 
#
 942 
#
828 
sub SvnListPackages
 943 
sub SvnListPackages
829 
{
 944 
{
- 
 
 945 
    #
- 
 
 946 
    #   Extract arguments and options
- 
 
 947 
    #   If last argument is a hesh, then its a hash of options
- 
 
 948 
    #
- 
 
 949 
    my $opt;
- 
 
 950 
    $opt = pop @_
- 
 
 951 
        if (@_ > 0 and UNIVERSAL::isa($_[-1],'HASH'));
- 
 
 952 
 
830 
    my ($repo) = @_;
 953 
    my ($self, $repo) = @_;
831 
 
 954 
 
832 
    my @path_list = $repo;
 955 
    my @path_list = '';
833 
    my @list;
 956 
    my @list;
- 
 
 957 
    my @mlist;
834 
    my $scanned = 0;
 958 
    my $scanned = 0;
835 
    Debug ("SvnListPackages");
 959 
    Debug ("SvnListPackages");
836 
    while ( @path_list )
 960 
    while ( @path_list )
837 
    {
 961 
    {
838 
        my $path = shift @path_list;
 962 
        my $path = shift @path_list;
- 
 
 963 
        if ( $opt->{Progress} )
- 
 
 964 
        {
- 
 
 965 
            Message ("Reading: " . ( $path || 'RepoRoot') );
- 
 
 966 
        }
839 
        $scanned++;
 967 
        $scanned++;
840 
print "Reading: $path\n";
 - 
 
841 
        my ( $ref_files, $ref_dirs, $ref_svn, $found ) = SvnScanPath ( 'Listing Packages', $path );
 968 
        my ( $ref_files, $ref_dirs, $ref_svn, $found ) = $self->SvnScanPath ( 'Listing Packages', join( '/', $repo, $path) );
842 
 
 969 
 
843 
        #
 970 
        #
844 
        #   If there are Subversion dirs (ttb) in this directory
 971 
        #   If there are Subversion dirs (ttb) in this directory
845 
        #   then this is a package. Add to list
 972 
        #   then this is a package. Add to list
846 
        #
 973 
        #
Line 849... Line 976...
849 
        #
 976 
        #
850 
        #   Add subdirs to the list of paths to explore
 977 
        #   Add subdirs to the list of paths to explore
851 
        #
 978 
        #
852 
        foreach  ( @$ref_dirs )
 979 
        foreach  ( @$ref_dirs )
853 
        {
 980 
        {
854 
            chop;                                 # Remove trailing '/'
 981 
            chop;                                   # Remove trailing '/'
855 
            push @path_list, $path . '/' . $_;    # Extend the path
 982 
            push @path_list, $path ? join('/', $path , $_) : $_; # Extend the path
- 
 
 983 
        }
- 
 
 984 
    }
- 
 
 985 
 
- 
 
 986 
    if ( $opt->{Tag} )
- 
 
 987 
    {
- 
 
 988 
        my $tag = $opt->{Tag};
- 
 
 989 
        foreach my $path ( sort @list )
- 
 
 990 
        {
- 
 
 991 
            Message ("Testing: $path") if ( $opt->{Progress} );
- 
 
 992 
            if ( $self->SvnTestPath ( 'Listing Packages', join('/', $repo, $path, 'tags', $tag) ) )
- 
 
 993 
            {
- 
 
 994 
                push @mlist, $path;
- 
 
 995 
            }
856 
        }
 996 
        }
857 
    }
 997 
    }
858 
 
 998 
 
- 
 
 999 
    if ( $opt->{Show} )
- 
 
 1000 
    {
859 
    Message ("Found:", @list );
 1001 
        Message ("Found Tags:", @mlist );
- 
 
 1002 
        Message ("Found Packages:", @list ) if  $opt->{Show} > 2;
- 
 
 1003 
        Message ("Tags Found: " . scalar @mlist );
- 
 
 1004 
        Message ("Packages Found: " . scalar @list );
860 
    Message ("Dirs Scanned: $scanned");
 1005 
        Message ("Dirs Scanned: $scanned");
- 
 
 1006 
    }
- 
 
 1007 
 
861 
    Message ("Packages Found: $#list");
 1008 
    return \@list, \@mlist;
862 
}
 1009 
}
863 
 
 1010 
 
864 
#-------------------------------------------------------------------------------
 1011 
#-------------------------------------------------------------------------------
865 
# Function        : ListLabels
 1012 
# Function        : ListLabels
866 
#
 1013 
#
Line 909... Line 1056...
909 
sub SvnLocateWsRoot
 1056 
sub SvnLocateWsRoot
910 
{
 1057 
{
911 
    my ($self, $test) = @_;
 1058 
    my ($self, $test) = @_;
912 
    my @path;
 1059 
    my @path;
913 
    my $path = $self->{WS};
 1060 
    my $path = $self->{WS};
- 
 
 1061 
    my $found;
914 
 
 1062 
 
915 
    Debug ("SvnLocateWsRoot");
 1063 
    Debug ("SvnLocateWsRoot");
916 
    Error ("SvnLocateWsRoot: No Workspace") unless ( $path  );
 1064 
    Error ("SvnLocateWsRoot: No Workspace") unless ( $path  );
917 
    Verbose2 ("SvnLocateWsRoot: Start in $path");
 1065 
    Verbose2 ("SvnLocateWsRoot: Start in $path");
918 
 
 1066 
 
Line 923... Line 1071...
923 
    {
 1071 
    {
924 
        return undef;
 1072 
        return undef;
925 
    }
 1073 
    }
926 
 
 1074 
 
927 
    #
 1075 
    #
928 
    #   Need to sanitize the users path to ensure that the following
 1076 
    #   Under Subversion 1.7 the process is a lot easier
929 
    #   algorithm works. Need:
 - 
 
930 
    #       1) Absolute Path
 - 
 
931 
    #       2) Not ending in '/'
 - 
 
932 
    #
 1077 
    #
933 
 
 - 
 
934 
    #
 - 
 
935 
    #   If we have a relative path then prepend the current directory
 - 
 
936 
    #   An absolute path is:
 - 
 
937 
    #           /aaa/aa/aa
 - 
 
938 
    #       or  c:/aaa/aa/aa
 - 
 
939 
    #
 - 
 
940 
    $path = getcwd() . '/' . $path
 - 
 
941 
        unless ( $path =~ m~^/|\w:/~  );
 - 
 
942 
 
 - 
 
943 
    #
 - 
 
944 
    #   Walk the bits and remove ".." directories
 - 
 
945 
    #       Done by pushing non-.. elements and poping last entry for .. elements.
 - 
 
946 
    #   Have a leading "/" which is good.
 - 
 
947 
    #
 - 
 
948 
    #   Create a array of directories in the path
 1078 
    if ( exists $self->{'InfoWs'}{'Working Copy Root Path'} )
949 
    #   Split on one or more \ or / separators
 - 
 
950 
    #
 - 
 
951 
    foreach ( split /[\\\/]+/ , $path )
 - 
 
952 
    {
 1079 
    {
953 
        next if ( $_ eq '.' );
 1080 
        #
954 
        unless ( $_ eq '..' )
 1081 
        #   WS is now known
955 
        {
 1082 
        #
956 
            push @path, $_;
 1083 
        $self->{WS} = $self->{'InfoWs'}{'Working Copy Root Path'};
- 
 
 1084 
 
957 
        }
 1085 
        #
958 
        else
 1086 
        #   Calculate WSURL
959 
        {
 1087 
        #
960 
            Error ("SvnLocateWsRoot: Bad Pathname: $path")
 1088 
        $self->{WSURL} = join('/', $self->{PKGROOT}, $self->{DEVBRANCH});
961 
                if ( $#path <= 0 );
 - 
 
962 
            pop @path;
 1089 
        $found = 1;
963 
        }
 - 
 
964 
    }
 1090 
    }
- 
 
 1091 
    else
- 
 
 1092 
    {
- 
 
 1093 
        # Preversion 1.7
- 
 
 1094 
        Warning ("Using svn < 1.7. This is not recommended");
965 
 
 1095 
 
966 
    #
 1096 
        #
- 
 
 1097 
        #   Need to sanitize the users path to ensure that the following
967 
    #   Need to adjust the WSURL too
 1098 
        #   algorithm works. Need:
968 
    #   Break into parts and pop them off as we go
 1099 
        #       1) Absolute Path
969 
    #   Add a dummy one to allow for the first iteration
 1100 
        #       2) Not ending in '/'
970 
    #
 1101 
        #
971 
    my @wsurl = (split (/[\\\/]+/ , $self->{WSURL}), 'Dummy');
 - 
 
972 
 
 1102 
 
973 
    Verbose2 ("Clean absolute path elements: @path");
 - 
 
974 
    PATH_LOOP:
 - 
 
975 
    while ( @path )
 - 
 
976 
    {
 - 
 
977 
        #
 1103 
        #
978 
        #   This directory element. Append / to assist in compare
 1104 
        #   If we have a relative path then prepend the current directory
979 
        #   Determine parent path
 1105 
        #   An absolute path is:
- 
 
 1106 
        #           /aaa/aa/aa
- 
 
 1107 
        #       or  c:/aaa/aa/aa
980 
        #
 1108 
        #
981 
        my $name = pop (@path) . '/';
 1109 
        $path = getcwd() . '/' . $path
982 
        my $parent = join ('/', @path );
 1110 
            unless ( $path =~ m~^/|\w:/~  );
983 
        pop @wsurl;
 - 
 
984 
 
 1111 
 
985 
        #
 1112 
        #
986 
        #   Examine the parent directory
 1113 
        #   Walk the bits and remove ".." directories
987 
        #   Get a list of all elements in the parent
 1114 
        #       Done by pushing non-.. elements and poping last entry for .. elements.
988 
        #   Need to ensure that this directory is one of them
 1115 
        #   Have a leading "/" which is good.
989 
        #
 1116 
        #
990 
        #   Ignore any errors - assume that they are because the
 1117 
        #   Create a array of directories in the path
991 
        #   parent is not a part of the work space. This will terminate the
 1118 
        #   Split on one or more \ or / separators
992 
        #   search.
 - 
 
993 
        #
 1119 
        #
994 
        $self->SvnCmd ('list', $parent, '--depth', 'immediates' );
 - 
 
995 
        foreach my $entry ( @{$self->{RESULT_LIST}} )
 1120 
        foreach ( split /[\\\/]+/ , $path )
996 
        {
 1121 
        {
997 
            next PATH_LOOP
 1122 
            next if ( $_ eq '.' );
- 
 
 1123 
            unless ( $_ eq '..' )
- 
 
 1124 
            {
- 
 
 1125 
                push @path, $_;
- 
 
 1126 
            }
- 
 
 1127 
            else
- 
 
 1128 
            {
- 
 
 1129 
                Error ("SvnLocateWsRoot: Bad Pathname: $path")
998 
                if ( $entry eq $name );
 1130 
                    if ( $#path <= 0 );
- 
 
 1131 
                pop @path;
- 
 
 1132 
            }
999 
        }
 1133 
        }
1000 
 
 1134 
 
1001 
        #
 1135 
        #
- 
 
 1136 
        #   Need to adjust the WSURL too
1002 
        #   Didn't find 'dir' in directory svn listing of parent
 1137 
        #   Break into parts and pop them off as we go
1003 
        #   This parent is not a part of the same WorkSpace as 'dir'
 1138 
        #   Add a dummy one to allow for the first iteration
- 
 
 1139 
        #
- 
 
 1140 
        my @wsurl = (split (/[\\\/]+/ , $self->{WSURL}), 'Dummy');
- 
 
 1141 
 
- 
 
 1142 
        Verbose2 ("Clean absolute path elements: @path");
- 
 
 1143 
        PATH_LOOP:
1004 
        #   We have a winner.
 1144 
        while ( @path )
1005 
        #
 1145 
        {
- 
 
 1146 
            #
1006 
        chop $name;                         #   Chop the '/' previously added
 1147 
            #   This directory element. Append / to assist in compare
- 
 
 1148 
            #   Determine parent path
- 
 
 1149 
            #
- 
 
 1150 
            my $name = pop (@path) . '/';
1007 
        $self->{WS} = $parent . '/' . $name;
 1151 
            my $parent = join ('/', @path );
- 
 
 1152 
            pop @wsurl;
1008 
 
 1153 
 
1009 
        #
 1154 
            #
- 
 
 1155 
            #   Examine the parent directory
- 
 
 1156 
            #   Get a list of all elements in the parent
1010 
        #   Reform the WSURL. Elements have been removed as we tested up the
 1157 
            #   Need to ensure that this directory is one of them
1011 
        #   path
 1158 
            #
- 
 
 1159 
            #   Ignore any errors - assume that they are because the
- 
 
 1160 
            #   parent is not a part of the work space. This will terminate the
- 
 
 1161 
            #   search.
1012 
        #
 1162 
            #
- 
 
 1163 
            $self->SvnCmd ('list', $parent, '--depth', 'immediates' );
- 
 
 1164 
            foreach my $entry ( @{$self->{RESULT_LIST}} )
- 
 
 1165 
            {
- 
 
 1166 
                next PATH_LOOP
1013 
        $self->{WSURL} = join '/', @wsurl;
 1167 
                    if ( $entry eq $name );
- 
 
 1168 
            }
1014 
 
 1169 
 
- 
 
 1170 
            #
- 
 
 1171 
            #   Didn't find 'dir' in directory svn listing of parent
- 
 
 1172 
            #   This parent is not a part of the same WorkSpace as 'dir'
- 
 
 1173 
            #   We have a winner.
- 
 
 1174 
            #
- 
 
 1175 
            chop $name;                         #   Chop the '/' previously added
- 
 
 1176 
            $self->{WS} = $parent . '/' . $name;
- 
 
 1177 
 
- 
 
 1178 
            #
- 
 
 1179 
            #   Reform the WSURL. Elements have been removed as we tested up the
- 
 
 1180 
            #   path
- 
 
 1181 
            #
- 
 
 1182 
            $self->{WSURL} = join '/', @wsurl;
1015 
        return $self->{WS};
 1183 
            $found = 1;
- 
 
 1184 
            last;
- 
 
 1185 
        }
1016 
    }
 1186 
    }
1017 
 
 1187 
 
1018 
    #
 1188 
    #
1019 
    #   Shouldn't get this far
 1189 
    #   Shouldn't get this far
1020 
    #
 1190 
    #
1021 
    Error ("SvnLocateWsRoot: Root not found");
 1191 
    Error ("SvnLocateWsRoot: Root not found")
- 
 
 1192 
        unless ( $found );
- 
 
 1193 
 
- 
 
 1194 
    #
- 
 
 1195 
    #   Refresh Info
- 
 
 1196 
    #   Must kill cached copy
- 
 
 1197 
    #
- 
 
 1198 
    delete $self->{'InfoWs'};
- 
 
 1199 
    $self->SvnInfo($self->{WS}, 'InfoWs');
- 
 
 1200 
    return $self->{WS};
- 
 
 1201
1022 
}
 1202 
}
1023 
 
 1203 
 
1024 
#-------------------------------------------------------------------------------
 1204 
#-------------------------------------------------------------------------------
1025 
# Function        : SvnValidateWs
 1205 
# Function        : SvnValidateWs
1026 
#
 1206 
#
Line 1267... Line 1447...
1267 
    #       Repository Root: svn://auperaws996vm21/test
 1447 
    #       Repository Root: svn://auperaws996vm21/test
1268 
    #
 1448 
    #
1269 
    my $url = $self->{'InfoWs'}{'URL'};
 1449 
    my $url = $self->{'InfoWs'}{'URL'};
1270 
    my $reporoot = $self->{'InfoWs'}{'Repository Root'};
 1450 
    my $reporoot = $self->{'InfoWs'}{'Repository Root'};
1271 
    my $repoVersion = $self->{'InfoWs'}{'Revision'};
 1451 
    my $repoVersion = $self->{'InfoWs'}{'Revision'};
- 
 
 1452 
    my $devBranch;
1272 
 
 1453 
 
1273 
    Error ("JatsSvn Internal error. Can't parse info")
 1454 
    Error ("JatsSvn Internal error. Can't parse info")
1274 
        unless ( $url && $reporoot );
 1455 
        unless ( $url && $reporoot );
1275 
 
 1456 
 
1276 
    #
 1457 
    #
Line 1293... Line 1474...
1293 
    #
 1474 
    #
1294 
    if (  $url =~ m~(.+)/((tags|branches|trunk)(/|$).*)~ )
 1475 
    if (  $url =~ m~(.+)/((tags|branches|trunk)(/|$).*)~ )
1295 
    {
 1476 
    {
1296 
        $url = $1;
 1477 
        $url = $1;
1297 
        $self->{WSTYPE} = $3;
 1478 
        $self->{WSTYPE} = $3;
- 
 
 1479 
        if ( $3 eq 'trunk' ) {
- 
 
 1480 
            $devBranch = $3;
- 
 
 1481 
        } elsif ( $3 eq 'branches' ) {
- 
 
 1482 
            $devBranch = $2;
- 
 
 1483 
        }
1298 
    }
 1484 
    }
1299 
    else
 1485 
    else
1300 
    {
 1486 
    {
1301 
        #
 1487 
        #
1302 
        #   If we are being slack (ie deleting the workspace)
 1488 
        #   If we are being slack (ie deleting the workspace)
Line 1313... Line 1499...
1313 
    #   Insert known information
 1499 
    #   Insert known information
1314 
    #
 1500 
    #
1315 
    $self->{URL} = $reporoot . '/';
 1501 
    $self->{URL} = $reporoot . '/';
1316 
    $self->{PKGROOT} = $url;
 1502 
    $self->{PKGROOT} = $url;
1317 
    $self->{WSREVNO} = $repoVersion;
 1503 
    $self->{WSREVNO} = $repoVersion;
- 
 
 1504 
    $self->{DEVBRANCH} = $devBranch;
1318 
 
 1505 
 
1319 
    #
 1506 
    #
1320 
    #   Create useful information
 1507 
    #   Create useful information
1321 
    #
 1508 
    #
1322 
    SplitPackageUrl($self);
 1509 
    SplitPackageUrl($self);
Line 1400... Line 1587...
1400 
    #   as provided by configuration information within the environment
 1587 
    #   as provided by configuration information within the environment
1401 
    #
 1588 
    #
1402 
    $rpath =~ m~(.+?)/(.*)~;
 1589 
    $rpath =~ m~(.+?)/(.*)~;
1403 
    my $fe = $1 || $rpath;
 1590 
    my $fe = $1 || $rpath;
1404 
    my $rest = $2 || '';
 1591 
    my $rest = $2 || '';
1405 
 
 - 
 
1406 
    if ( $SVN_URLS{$fe} )
 1592 
    if ( $SVN_URLS{$fe} )
1407 
    {
 1593 
    {
1408 
        $url = $SVN_URLS{$fe};
 1594 
        $url = $SVN_URLS{$fe};
1409 
        $pkgroot = $rest;
 1595 
        $pkgroot = $rest;
1410 
        $processed = 1;
 1596 
        $processed = 1;
Line 1487... Line 1673...
1487 
}
 1673 
}
1488 
 
 1674 
 
1489 
#-------------------------------------------------------------------------------
 1675 
#-------------------------------------------------------------------------------
1490 
# Function        : SplitPackageUrl
 1676 
# Function        : SplitPackageUrl
1491 
#
 1677 
#
1492 
# Description     : Slip the package URL into a few useful bits
 1678 
# Description     : Split the package URL into a few useful bits
1493 
#
 1679 
#
1494 
# Inputs          : $self           - Instance data
 1680 
# Inputs          : $self           - Instance data
1495 
#
 1681 
#
1496 
# Returns         : Nothing
 1682 
# Returns         : Nothing
1497 
#
 1683 
#
Line 1561... Line 1747...
1561 
# Returns         : Data Item
 1747 
# Returns         : Data Item
1562 
#
 1748 
#
1563 
sub Full        { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }
 1749 
sub Full        { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }
1564 
sub FullWs      { return $_[0]->{URL} . $_[0]->{WSURL} ; }
 1750 
sub FullWs      { return $_[0]->{URL} . $_[0]->{WSURL} ; }
1565 
sub FullWsRev   { return $_[0]->{URL} . $_[0]->{WSURL} . '@' . $_[0]->{WSREVNO} ; }
 1751 
sub FullWsRev   { return $_[0]->{URL} . $_[0]->{WSURL} . '@' . $_[0]->{WSREVNO} ; }
- 
 
 1752 
sub FullPath    { return $_[0]->{URL} . $_[0]->{PATH} ; }
1566 
sub Peg         { return $_[0]->{PEG} ; }
 1753 
sub Peg         { return $_[0]->{PEG} ; }
- 
 
 1754 
sub DevBranch   { return $_[0]->{DEVBRANCH} || '' ; }
1567 
sub Type        { return $_[0]->{TAGTYPE} || '' ; }
 1755 
sub Type        { return $_[0]->{TAGTYPE} || '' ; }
1568 
sub WsType      { return $_[0]->{WSTYPE}  || '' ; }
 1756 
sub WsType      { return $_[0]->{WSTYPE}  || '' ; }
1569 
sub Path        { return $_[0]->{PATH} ; }
 1757 
sub Path        { return $_[0]->{PATH} ; }
1570 
sub Version     { return $_[0]->{VERSION} ; }
 1758 
sub Version     { return $_[0]->{VERSION} ; }
1571 
sub RmRef       { return $_[0]->{RMREF} ; }
 1759 
sub RmRef       { return $_[0]->{RMREF} ; }
1572 
sub RmPath      { my $path = $_[0]->{RMREF}; $path =~ s~@.*?$~~ ;return  $path; }
 1760 
sub RmPath      { my $path = $_[0]->{RMREF}; $path =~ s~@.*?$~~ ;return  $path; }
- 
 
 1761 
sub SvnTag      { return $_[0]->{SVNTAG} || '' ; }
1573 
 
 1762 
 
1574 
#-------------------------------------------------------------------------------
 1763 
#-------------------------------------------------------------------------------
1575 
# Function        : Print
 1764 
# Function        : Print
1576 
#
 1765 
#
1577 
# Description     : Debug display the URL
 1766 
# Description     : Debug display the URL
Line 1588... Line 1777...
1588 
    print "$header\n" if $header;
 1777 
    print "$header\n" if $header;
1589 
    $indent = 4 unless ( defined $indent );
 1778 
    $indent = 4 unless ( defined $indent );
1590 
    $indent = ' ' x $indent;
 1779 
    $indent = ' ' x $indent;
1591 
 
 1780 
 
1592 
 
 1781 
 
1593 
    print $indent . "PROTOCOL:" . $self->{PROTOCOL} . "\n";
 1782 
    print $indent . "PROTOCOL :" . $self->{PROTOCOL} . "\n";
1594 
    print $indent . "SERVER  :" . $self->{SERVER} . "\n";
 1783 
    print $indent . "SERVER   :" . $self->{SERVER} . "\n";
1595 
    print $indent . "URL     :" . $self->{URL} . "\n";
 1784 
    print $indent . "URL      :" . $self->{URL} . "\n";
1596 
    print $indent . "PKGROOT :" . $self->{PKGROOT} . "\n";
 1785 
    print $indent . "PKGROOT  :" . $self->{PKGROOT} . "\n";
1597 
    print $indent . "PATH    :" . $self->{PATH} . "\n";
 1786 
    print $indent . "PATH     :" . $self->{PATH} . "\n";
1598 
    print $indent . "TAGTYPE :" . ($self->{TAGTYPE} || '') . "\n";
 1787 
    print $indent . "TAGTYPE  :" . ($self->{TAGTYPE} || '') . "\n";
1599 
    print $indent . "VERSION :" . ($self->{VERSION} || '') . "\n";
 1788 
    print $indent . "VERSION  :" . ($self->{VERSION} || '') . "\n";
1600 
    print $indent . "PEG     :" . ($self->{PEG} || '') . "\n";
 1789 
    print $indent . "PEG      :" . ($self->{PEG} || '') . "\n";
- 
 
 1790 
    print $indent . "DEVBRANCH:" . ($self->{DEVBRANCH} || '') . "\n";
- 
 
 1791 
    print $indent . "SVNTAG   :" . ($self->{SVNTAG} || '') . "\n";
1601 
    print $indent . "FULL    :" . $self->Full . "\n";
 1792 
#    print $indent . "FULL    :" . $self->Full . "\n";
- 
 
 1793 
 
- 
 
 1794 
    print $indent . "Full         :" . $self->Full . "\n";
- 
 
 1795 
#    print $indent . "FullWs       :" . $self->FullWs    . "\n";
- 
 
 1796 
#    print $indent . "FullWsRev    :" . $self->FullWsRev . "\n";
- 
 
 1797 
    print $indent . "FullPath     :" . $self->FullPath  . "\n";
- 
 
 1798 
    print $indent . "Peg          :" . $self->Peg       . "\n";
- 
 
 1799 
    print $indent . "DevBranch    :" . $self->DevBranch . "\n";
- 
 
 1800 
    print $indent . "Type         :" . $self->Type      . "\n";
- 
 
 1801 
    print $indent . "WsType       :" . $self->WsType    . "\n";
- 
 
 1802 
    print $indent . "Path         :" . $self->Path      . "\n";
- 
 
 1803 
    print $indent . "Version      :" . $self->Version   . "\n";
- 
 
 1804 
    print $indent . "RmRef        :" . ($self->RmRef || '') . "\n";
- 
 
 1805 
#    print $indent . "RmPath       :" . ($self->RmPath|| '') . "\n";
1602 
}
 1806 
}
1603 
 
 1807 
 
1604 
#-------------------------------------------------------------------------------
 1808 
#-------------------------------------------------------------------------------
1605 
# Function        : BranchName
 1809 
# Function        : BranchName
1606 
#
 1810 
#
Line 1635... Line 1839...
1635 
#                   This may well fail unless the Repo is setup to allow such
 1839 
#                   This may well fail unless the Repo is setup to allow such
1636 
#                   chnages and the user is allowed to make such changes
 1840 
#                   chnages and the user is allowed to make such changes
1637 
#
 1841 
#
1638 
# Inputs          : $name
 1842 
# Inputs          : $name
1639 
#                   $value
 1843 
#                   $value
- 
 
 1844 
#                   $allowError     - Support for bad repositories
1640 
#
 1845 
#
- 
 
 1846 
# Returns         : 0 - Change made
1641 
# Returns         : Will not return on error
 1847 
#                   Will not return on error
1642 
#
 1848 
#
1643 
sub setRepoProperty
 1849 
sub setRepoProperty
1644 
{
 1850 
{
1645 
    my ($self, $name, $value ) = @_;
 1851 
    my ($self, $name, $value, $allowError ) = @_;
- 
 
 1852 
    my $retval = 0;
- 
 
 1853 
 
1646 
    Debug ( "setRepoProperty", $name, $value );
 1854 
    Debug ( "setRepoProperty", $name, $value );
1647 
    #
 1855 
    #
1648 
    #   Ensure that the Repo version is known
 1856 
    #   Ensure that the Repo version is known
1649 
    #   This should be set by a previous operation
 1857 
    #   This should be set by a previous operation
1650 
    #
 1858 
    #
Line 1664... Line 1872...
1664 
                       ) )
 1872 
                       ) )
1665 
    {
 1873 
    {
1666 
        #
 1874 
        #
1667 
        #   Property NOT set
 1875 
        #   Property NOT set
1668 
        #
 1876 
        #
- 
 
 1877 
        if ( $allowError )
- 
 
 1878 
        {
- 
 
 1879 
            Warning ("setRepoProperty: $name - FAILED");
- 
 
 1880 
            $retval = 1;
- 
 
 1881 
        }
- 
 
 1882 
        else
- 
 
 1883 
        {
1669 
        Error ("setRepoProperty: $name - FAILED");
 1884 
            Error ("setRepoProperty: $name - FAILED");
- 
 
 1885 
        }
- 
 
 1886 
    }
- 
 
 1887 
 
- 
 
 1888 
    return $retval;
- 
 
 1889 
}
- 
 
 1890 
 
- 
 
 1891 
#-------------------------------------------------------------------------------
- 
 
 1892 
# Function        : backTrackSvnLabel
- 
 
 1893 
#
- 
 
 1894 
# Description     : Examine a Svn Tag and backtrack until we find the branch
- 
 
 1895 
#                   that was used to create the label
- 
 
 1896 
#
- 
 
 1897 
# Inputs          : $self                   - Instance Data
- 
 
 1898 
#                   $src_label              - Label to process
- 
 
 1899 
#                                             Label within the current instance
- 
 
 1900 
#                   A hash of named arguments
- 
 
 1901 
#                       data                - Scalar ref. Hash of good stuff returned
- 
 
 1902 
#                       printdata           - Print RAW svn data
- 
 
 1903 
#                       onlysimple          - Do not do exhaustive scan
- 
 
 1904 
#                       savedevbranch       - Save Dev Branch in session
- 
 
 1905 
#
- 
 
 1906 
# Returns         : Branch from which the label was taken
- 
 
 1907 
#                   or the label prefixed with 'tags'.
- 
 
 1908 
#
- 
 
 1909 
sub backTrackSvnLabel
- 
 
 1910 
{
- 
 
 1911 
    my $self = shift;
- 
 
 1912 
    my $src_label = shift;
- 
 
 1913 
    my %opt = @_;
- 
 
 1914 
    my $branch;
- 
 
 1915 
 
- 
 
 1916 
    Debug ("backTrackSvnLabel");
- 
 
 1917 
    Error ("backTrackSvnLabel: Odd number of args") unless ((@_ % 2) == 0);
- 
 
 1918
- 
 
 1919 
    #
- 
 
 1920 
    #   May need to read and process data twice
- 
 
 1921 
    #   First   - stop on copy. May it fast
- 
 
 1922 
    #   Second  - all the log.
- 
 
 1923 
 
- 
 
 1924 
    #
- 
 
 1925 
    #   extract data
- 
 
 1926 
    #
- 
 
 1927 
    foreach my $mode ( '--stop-on-copy', '' )
- 
 
 1928 
    {
- 
 
 1929 
        #   Init stored data
- 
 
 1930 
        #   Used to communicate with callback function(s)
- 
 
 1931 
        #
- 
 
 1932 
        Information ("backTrackSvnLabel: Performing exhaustive search") unless $mode;
- 
 
 1933 
        $self->{btData} = ();
- 
 
 1934 
        $self->{btData}{results}{base} = $self->FullPath();
- 
 
 1935 
        $self->{btData}{results}{label} = $src_label;
- 
 
 1936 
        $self->{btData}{results}{changeSets} = 0;
- 
 
 1937 
        $self->{btData}{results}{distance} = 0;
- 
 
 1938 
 
- 
 
 1939 
        #
- 
 
 1940 
        #   Linux does not handle empty arguments in the same
- 
 
 1941 
        #   manner as windows. Solution: pass an array
- 
 
 1942 
        #
- 
 
 1943 
        my @mode;
- 
 
 1944 
        push @mode, $mode if ( $mode);
- 
 
 1945 
        my $spath = $self->FullPath() . '/' . $src_label;
- 
 
 1946 
 
- 
 
 1947 
        Verbose2("backTrackSvnLabel. Log from $spath");
- 
 
 1948 
        $self->SvnCmd ( 'log', '-v', '--xml', '-q'
- 
 
 1949 
                        , @mode
- 
 
 1950 
                        , $spath
- 
 
 1951 
                        , { 'credentials' => 1,
- 
 
 1952 
                            'process' => \&ProcessBackTrack,
- 
 
 1953 
                            'printdata' => $opt{printdata},
- 
 
 1954 
                            'nosavedata' => 1,
- 
 
 1955 
                             }
- 
 
 1956 
                            );
- 
 
 1957 
 
- 
 
 1958 
        last if ( $self->{btData}{good} );
- 
 
 1959 
        last if ( $opt{onlysimple} );
- 
 
 1960 
    }
- 
 
 1961 
 
- 
 
 1962 
    #
- 
 
 1963 
    #   Did not backtrack to a branch (or trunk)
- 
 
 1964 
    #   Return the users label
- 
 
 1965 
    #
- 
 
 1966 
    unless ( $self->{btData}{good} )
- 
 
 1967 
    {
- 
 
 1968 
        $branch = $src_label;
1670 
    }
 1969 
    }
- 
 
 1970 
    else
- 
 
 1971 
    {
- 
 
 1972 
        $branch = $self->{btData}{results}{devBranch};
- 
 
 1973 
        if ( $opt{savedevbranch} )
- 
 
 1974 
        {
- 
 
 1975 
            $self->{btData}{results}{devBranch} =~ m~^(.*?)(@|$)~;
- 
 
 1976 
            $self->{DEVBRANCH} = $1;
- 
 
 1977 
        }
- 
 
 1978
- 
 
 1979 
    }
- 
 
 1980 
 
- 
 
 1981 
    #
- 
 
 1982 
    #   Return data to the user
- 
 
 1983 
    #
- 
 
 1984 
    if ( my $refData = $opt{data} )
- 
 
 1985 
    {
- 
 
 1986 
        Error ('Internal: backTrackSvnLabel. Arg to "data" must be ref to a scalar')
- 
 
 1987 
            unless ( ref($refData) eq 'SCALAR' );
- 
 
 1988 
        $$refData = $self->{btData}{results};
- 
 
 1989 
    }
- 
 
 1990 
 
- 
 
 1991 
    #
- 
 
 1992 
    #   Clean up the data
- 
 
 1993 
    #
- 
 
 1994 
    delete $self->{btData};
- 
 
 1995 
    return $branch;
- 
 
 1996 
}
- 
 
 1997 
 
- 
 
 1998 
#-------------------------------------------------------------------------------
- 
 
 1999 
# Function        : ProcessBackTrack
- 
 
 2000 
#
- 
 
 2001 
# Description     :
- 
 
 2002 
#                   Parse
- 
 
 2003 
#                       <logentry
- 
 
 2004 
#                          revision="24272">
- 
 
 2005 
#                       <author>bivey</author>
- 
 
 2006 
#                       <date>2005-07-25T15:45:35.000000Z</date>
- 
 
 2007 
#                       <paths>
- 
 
 2008 
#                       <path
- 
 
 2009 
#                          prop-mods="false"
- 
 
 2010 
#                          text-mods="false"
- 
 
 2011 
#                          kind="dir"
- 
 
 2012 
#                          copyfrom-path="/enqdef/branches/Stockholm"
- 
 
 2013 
#                          copyfrom-rev="24271"
- 
 
 2014 
#                          action="A">/enqdef/tags/enqdef_24.0.1.sls</path>
- 
 
 2015 
#                       </paths>
- 
 
 2016 
#                       <msg>COTS/enqdef: Tagged by Jats Svn Import</msg>
- 
 
 2017 
#                       </logentry>
- 
 
 2018 
#
- 
 
 2019 
#
- 
 
 2020 
#                   Uses:   $self->{btData}     - Scratch Data
- 
 
 2021 
#
- 
 
 2022 
# Inputs          : $self           - Class Data
- 
 
 2023 
#                   $line           - Input data to parse
- 
 
 2024 
#
- 
 
 2025 
# Returns         : 0 - Do not terminate input command
- 
 
 2026 
#
- 
 
 2027 
sub  ProcessBackTrack
- 
 
 2028 
{
- 
 
 2029 
    my ($self, $line ) = @_;
- 
 
 2030 
    Message ( $line ) if $self->{PRINTDATA};
- 
 
 2031 
 
- 
 
 2032 
    $line =~ s~\s+$~~;
- 
 
 2033 
    next unless ( $line );
- 
 
 2034 
#    Debug0('', $line);
- 
 
 2035 
 
- 
 
 2036 
    my $workSpace =  \%{$self->{btData}};
- 
 
 2037 
    if ( $line =~ m~<logentry$~ ) {
- 
 
 2038 
        $workSpace->{mode} = 'l';
- 
 
 2039 
        $workSpace->{rev} = 0;
- 
 
 2040 
        $workSpace->{changesSeen} = 0;
- 
 
 2041 
 
- 
 
 2042 
    } elsif ( $line =~ m~</logentry>$~ ) {
- 
 
 2043 
        $workSpace->{mode} = '';
- 
 
 2044 
 
- 
 
 2045 
        #
- 
 
 2046 
        #   End of a <logenty>
- 
 
 2047 
        #   See if we have a result - a dev branch not copied from a tag
- 
 
 2048 
        #
- 
 
 2049 
        if ( exists $workSpace->{devBranch} )
- 
 
 2050 
        {
- 
 
 2051 
            $workSpace->{results}{distance}++;
- 
 
 2052 
            $workSpace->{devBranch} =~ m~/((tags|branches|trunk)(/|\@).*)~;
- 
 
 2053 
            my $devBranch = $1;
- 
 
 2054 
 
- 
 
 2055 
            push @{$workSpace->{results}{paths}}, $devBranch;
- 
 
 2056 
            unless ( $devBranch =~ m ~^tags~ )
- 
 
 2057 
            {
- 
 
 2058 
                $workSpace->{results}{devBranch} = $devBranch;
- 
 
 2059 
                $workSpace->{results}{isaBranch} = 1;
- 
 
 2060 
                $workSpace->{good} = 1;
- 
 
 2061 
                return 1;
- 
 
 2062 
            }
- 
 
 2063 
        }
- 
 
 2064 
 
- 
 
 2065 
    } elsif ( $line =~ m~<path$~ ) {
- 
 
 2066 
        $workSpace->{mode} = 'p';
- 
 
 2067 
        Error ('Path without Rev') unless ( $workSpace->{rev} );
- 
 
 2068 
 
- 
 
 2069 
    } elsif ( $line =~ m~</paths>$~ ) {
- 
 
 2070 
        $workSpace->{mode} = '';
- 
 
 2071 
    }
- 
 
 2072 
    return 0 unless ( $workSpace->{mode} );
- 
 
 2073 
 
- 
 
 2074 
    if ( $workSpace->{mode} eq 'l' )
- 
 
 2075 
    {
- 
 
 2076 
        #
- 
 
 2077 
        #   Processing logentry data
- 
 
 2078 
        #       Only need the rev
- 
 
 2079 
        #
- 
 
 2080 
        $workSpace->{rev} = $1
- 
 
 2081 
            if ( $line =~ m~revision=\"(\d+)\"~ );
- 
 
 2082 
 
- 
 
 2083 
    } elsif ( $workSpace->{mode} eq 'p' ) {
- 
 
 2084 
        #
- 
 
 2085 
        #   Processing Paths
- 
 
 2086 
        #       Entries appear to be in a random order
- 
 
 2087 
        #       Not always the same order
- 
 
 2088 
        #
- 
 
 2089 
        my $end = 0;
- 
 
 2090 
        if ( $line =~ s~\s*(.+?)="(.+)">(.*)</path>$~~ )
- 
 
 2091 
        {
- 
 
 2092 
            #
- 
 
 2093 
            #   Last entry has two items
- 
 
 2094 
            #       Attribute
- 
 
 2095 
            #       Data Item
- 
 
 2096 
            #
- 
 
 2097 
            $end = 1;
- 
 
 2098 
            $workSpace->{path}{$1} = $2;
- 
 
 2099 
            $workSpace->{path}{DATA} = $3;
- 
 
 2100 
        }
- 
 
 2101 
        elsif ($line =~ m~\s*(.*?)="(.*)"~ )
- 
 
 2102 
        {
- 
 
 2103 
            $workSpace->{path}{$1} = $2;
- 
 
 2104 
        }
- 
 
 2105 
#        else
- 
 
 2106 
#        {
- 
 
 2107 
#            Warning ("Cannot decode XML log: $line");
- 
 
 2108 
#        }
- 
 
 2109 
 
- 
 
 2110 
        if ( $end )
- 
 
 2111 
        {
- 
 
 2112 
            #
- 
 
 2113 
            #   If the Repo is created by a pre 1.6 SVN, then kind will be
- 
 
 2114 
            #   empty. Have a guess.
- 
 
 2115 
            #
- 
 
 2116 
            if ( $workSpace->{path}{'kind'} eq '' )
- 
 
 2117 
            {
- 
 
 2118 
                if ( exists $workSpace->{path}{'copyfrom-path'} ) {
- 
 
 2119 
                    $workSpace->{path}{'kind'} = 'dir';
- 
 
 2120 
                } else {
- 
 
 2121 
                    $workSpace->{path}{'kind'} = 'file';
- 
 
 2122 
                }
- 
 
 2123 
            }
- 
 
 2124 
 
- 
 
 2125 
            if ( $workSpace->{path}{'kind'} eq 'dir' &&  exists $workSpace->{path}{'copyfrom-path'} )
- 
 
 2126 
            {
- 
 
 2127 
                my $srev = $workSpace->{path}{'copyfrom-rev'};
- 
 
 2128 
                my $from = $workSpace->{path}{'copyfrom-path'};
- 
 
 2129 
                if ( $from =~ m~/trunk$~ || $from =~ m~/branches/[^/]+$~ )
- 
 
 2130 
                {
- 
 
 2131 
                    $workSpace->{devBranch} = $from . '@' . $srev;
- 
 
 2132 
                }
- 
 
 2133 
            }
- 
 
 2134 
 
- 
 
 2135 
            elsif ( $workSpace->{path}{'kind'} eq 'file' )
- 
 
 2136 
            {
- 
 
 2137 
                #
- 
 
 2138 
                #   Track files that have been changed between tag and branch
- 
 
 2139 
                #   The log is presented as newest first
- 
 
 2140 
                #   The files have a tag-name component.
- 
 
 2141 
                #       Remove the tag name - so that we can compare files
- 
 
 2142 
                #       Save the first instance of changed files
- 
 
 2143 
                #           Others will be in older versions
- 
 
 2144 
                #           and thus of no interest
- 
 
 2145 
                #
- 
 
 2146 
                #   Count the chnage sets that have changes
- 
 
 2147 
                #   Having changes in multiple change sets indicates
- 
 
 2148 
                #   development on a /tags/ - which is BAD
- 
 
 2149 
                #
- 
 
 2150 
                $workSpace->{path}{'DATA'} =~ m~(.+)/((tags|branches|trunk)(/|$).*)~;
- 
 
 2151 
                my $file =  $2;
- 
 
 2152 
                my $full = $file;
- 
 
 2153 
                $file =~ s~^tags/(.+?)/~~;
- 
 
 2154 
 
- 
 
 2155 
                if ( ! exists $workSpace->{files}{$file}  )
- 
 
 2156 
                {
- 
 
 2157 
                    push @{$workSpace->{results}{files}}, $full . '@' . $workSpace->{rev};
- 
 
 2158 
                }
- 
 
 2159 
                $workSpace->{files}{$file}++;
- 
 
 2160 
                $workSpace->{firstFile} = $file unless ( defined $workSpace->{firstFile} );
- 
 
 2161 
 
- 
 
 2162 
                unless ( $workSpace->{changesSeen} )
- 
 
 2163 
                {
- 
 
 2164 
                    unless( $workSpace->{firstFile} eq $file )
- 
 
 2165 
                    {
- 
 
 2166 
                        $workSpace->{results}{changeSets}++;
- 
 
 2167 
                        $workSpace->{changesSeen}++;
- 
 
 2168 
                    }
- 
 
 2169 
                }
- 
 
 2170 
 
- 
 
 2171 
                if ( scalar keys %{$workSpace->{files}} > 1 )
- 
 
 2172 
                {
- 
 
 2173 
                    $workSpace->{results}{multipleChanges} = 1;
- 
 
 2174 
                    Verbose ("backTrackSvnLabel: Changes in multiple versions");
- 
 
 2175 
                }
- 
 
 2176 
            }
- 
 
 2177 
 
- 
 
 2178 
            delete $workSpace->{path};
- 
 
 2179 
        }
- 
 
 2180 
    }
- 
 
 2181 
 
- 
 
 2182 
    #
- 
 
 2183 
    #   Return 0 to keep on going
- 
 
 2184 
    return 0;
1671 
}
 2185 
}
1672 
 
 2186 
 
1673 
#------------------------------------------------------------------------------
 2187 
#------------------------------------------------------------------------------
1674 
1;
 2188 
1;