Subversion Repositories DevTools

Rev

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

Rev 267 Rev 341
Line 24... Line 24...
24 
 
 24 
 
25 
require 5.008_002;
 25 
require 5.008_002;
26 
use strict;
 26 
use strict;
27 
use warnings;
 27 
use warnings;
28 
our $GBE_SVN_URL;
 28 
our $GBE_SVN_URL;
- 
 
 29 
our $USER;
29 
use JatsEnv;
 30 
use JatsEnv;
30 
 
 31 
 
31 
package JatsSvn;
 32 
package JatsSvn;
32 
 
 33 
 
33 
use JatsError;
 34 
use JatsError;
Line 143... Line 144...
143 
#
 144 
#
144 
sub SvnCo
 145 
sub SvnCo
145 
{
 146 
{
146 
    my ($self, $RepoPath, $path, @opts) = @_;
 147 
    my ($self, $RepoPath, $path, @opts) = @_;
147 
    my $export = grep (/^--Export/, @opts );
 148 
    my $export = grep (/^--Export/, @opts );
148 
    Debug ("SvnCo");
 149 
    Debug ("SvnCo", $RepoPath, $path);
149 
 
 150 
 
150 
    #
 151 
    #
151 
    #   Ensure that the output path does not exist
 152 
    #   Ensure that the output path does not exist
152 
    #   Do not allow the user to create a local work space
 153 
    #   Do not allow the user to create a local work space
153 
    #   where one already exists
 154 
    #   where one already exists
Line 1133... Line 1134...
1133 
    Error ("Invalid label. Invalid Characters: \"$label\"" ) unless ( $label =~ m~^[-.:0-9a-zA-Z_]+$~ );
 1134 
    Error ("Invalid label. Invalid Characters: \"$label\"" ) unless ( $label =~ m~^[-.:0-9a-zA-Z_]+$~ );
1134 
    Error ("Invalid label. Double :: not allowed: \"$label\"" ) if ( $label =~m~::~ );
 1135 
    Error ("Invalid label. Double :: not allowed: \"$label\"" ) if ( $label =~m~::~ );
1135 
 
 1136 
 
1136 
    #
 1137 
    #
1137 
    #   Allow for a label of TIMESTAMP and have it expand
 1138 
    #   Allow for a label of TIMESTAMP and have it expand
- 
 
 1139 
    #   Create a label based on users name and a date-time hat can be sorted
1138 
    #
 1140 
    #
1139 
    if ( $label eq 'TIMESTAMP' )
 1141 
    if ( $label eq 'TIMESTAMP' )
1140 
    {
 1142 
    {
1141 
        $label = localtime();
 1143 
        ::EnvImport ('USER' );
- 
 
 1144 
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
1142 
        $label =~ s~\s+~_~g;
 1145 
        $label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u",
- 
 
 1146 
            $::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );
1143 
    }
 1147 
    }
1144 
    return $label;
 1148 
    return $label;
1145 
}
 1149 
}
1146 
 
 1150 
 
1147 
#-------------------------------------------------------------------------------
 1151 
#-------------------------------------------------------------------------------
Line 1296... Line 1300...
1296 
 
 1300 
 
1297 
    #
 1301 
    #
1298 
    #   Examine the URL and determine if we have a FULL Url or
 1302 
    #   Examine the URL and determine if we have a FULL Url or
1299 
    #   a path within the 'default' server
 1303 
    #   a path within the 'default' server
1300 
    #
 1304 
    #
- 
 
 1305 
    if ( defined $::GBE_SVN_URL && $uurl =~ m~^$::GBE_SVN_URL(.*)~ )
- 
 
 1306 
    {
- 
 
 1307 
        $uurl = $1;
- 
 
 1308 
    }
- 
 
 1309 
 
1301 
    if ( $uurl =~ m~^((file|http|svn):///?([^/]+)/)(.+)~ )
 1310 
    if ( $uurl =~ m~^((file|http|https|svn):///?([^/]+)/)(.+)~ )
1302 
    {
 1311 
    {
1303 
        #       http://server/
 1312 
        #       http://server/
- 
 
 1313 
        #       https://server/
1304 
        #       svn://server/
 1314 
        #       svn://server/
1305 
        #       file://This/Isa/Bad/Guess
 1315 
        #       file://This/Isa/Bad/Guess
1306 
        #
 1316 
        #
1307 
        $self->{NAMEDSERVER} = 1;
 1317 
        $self->{NAMEDSERVER} = 1;
1308 
        $self->{PROTOCOL} = $2;
 1318 
        $self->{PROTOCOL} = $2;
Line 1344... Line 1354...
1344 
    Debug ("SplitPackageUrl", @_);
 1354 
    Debug ("SplitPackageUrl", @_);
1345 
 
 1355 
 
1346 
    #
 1356 
    #
1347 
    #   Remove any protocol that may be present
 1357 
    #   Remove any protocol that may be present
1348 
    #       http://server/
 1358 
    #       http://server/
- 
 
 1359 
    #       https://server/
1349 
    #       svn://server/
 1360 
    #       svn://server/
1350 
    #       file://This/Isa/Bad/Guess
 1361 
    #       file://This/Isa/Bad/Guess
1351 
    #
 1362 
    #
1352 
    if ( $self->{URL} =~ m~^(file|http|svn)://([^/]+)~ )
 1363 
    if ( $self->{URL} =~ m~^(file|http|https|svn)://([^/]+)~ )
1353 
    {
 1364 
    {
1354 
        $self->{PROTOCOL} = $1;
 1365 
        $self->{PROTOCOL} = $1;
1355 
        $self->{SERVER} = $2;
 1366 
        $self->{SERVER} = $2;
1356 
    }
 1367 
    }
1357 
 
 1368 
 
1358 
    if ( $self->{PROTOCOL} eq 'svn' && $self->{PKGROOT} =~ m~([^/]+)/~ )
 - 
 
1359 
    {
 - 
 
1360 
        $self->{REPO} = $1;
 - 
 
1361 
    }
 - 
 
1362
- 
 
1363
- 
 
1364 
    if ( $self->{PKGROOT} =~ m~(.*)(@\d+)$~ )
 1369 
    if ( $self->{PKGROOT} =~ m~(.*)(@\d+)$~ )
1365 
    {
 1370 
    {
1366 
        $self->{PEG} = $2;
 1371 
        $self->{PEG} = $2;
1367 
    }
 1372 
    }
1368 
 
 1373 
 
Line 1378... Line 1383...
1378 
    if (  $self->{PKGROOT} =~ m~/?(.*)/(tags|branches|trunk)(/|$|@)(.*)$~ )
 1383 
    if (  $self->{PKGROOT} =~ m~/?(.*)/(tags|branches|trunk)(/|$|@)(.*)$~ )
1379 
    {
 1384 
    {
1380 
        $self->{PATH}         = $1;
 1385 
        $self->{PATH}         = $1;
1381 
        $self->{TAGTYPE}      = $2;
 1386 
        $self->{TAGTYPE}      = $2;
1382 
        $self->{VERSION}      = $4;
 1387 
        $self->{VERSION}      = $4;
1383 
 
 - 
 
1384 
        my $package = $self->{PATH};
 - 
 
1385 
        $package =~ s~.*/~~;
 - 
 
1386 
        $self->{PACKAGE}      = $package
 - 
 
1387 
    }
 1388 
    }
1388 
    else
 1389 
    else
1389 
    {
 1390 
    {
1390 
        $self->{PATH} = $self->{PKGROOT};
 1391 
        $self->{PATH} = $self->{PKGROOT};
1391 
    }
 1392 
    }
Line 1398... Line 1399...
1398 
#                   FullWs
 1399 
#                   FullWs
1399 
#                   Repo
 1400 
#                   Repo
1400 
#                   Peg
 1401 
#                   Peg
1401 
#                   Type
 1402 
#                   Type
1402 
#                   WsType
 1403 
#                   WsType
1403 
#                   Package
 - 
 
1404 
#                   Path
 1404 
#                   Path
1405 
#                   Version
 1405 
#                   Version
1406 
#                   RmRef
 1406 
#                   RmRef
1407 
#                   Url
 1407 
#                   Url
1408 
#
 1408 
#
Line 1411... Line 1411...
1411 
# Inputs          : $self       - Instance data
 1411 
# Inputs          : $self       - Instance data
1412 
#                                 self (is $_[0])
 1412 
#                                 self (is $_[0])
1413 
#
 1413 
#
1414 
# Returns         : Data Item
 1414 
# Returns         : Data Item
1415 
#
 1415 
#
1416 
sub Url     { return $_[0]->{URL} . ($_[1] || '') ; }
 - 
 
1417 
sub Full    { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }
 1416 
sub Full    { return $_[0]->{URL} . $_[0]->{PKGROOT} ; }
1418 
sub FullWs  { return $_[0]->{URL} . $_[0]->{WSURL} ; }
 1417 
sub FullWs  { return $_[0]->{URL} . $_[0]->{WSURL} ; }
1419 
sub Peg     { return $_[0]->{PEG} ; }
 1418 
sub Peg     { return $_[0]->{PEG} ; }
1420 
sub Type    { return $_[0]->{TAGTYPE} || '' ; }
 1419 
sub Type    { return $_[0]->{TAGTYPE} || '' ; }
1421 
sub WsType  { return $_[0]->{WSTYPE}  || '' ; }
 1420 
sub WsType  { return $_[0]->{WSTYPE}  || '' ; }
1422 
sub Package { return $_[0]->{PACKAGE} ; }
 - 
 
1423 
sub Path    { return $_[0]->{PATH} ; }
 1421 
sub Path    { return $_[0]->{PATH} ; }
1424 
sub Version { return $_[0]->{VERSION} ; }
 1422 
sub Version { return $_[0]->{VERSION} ; }
1425 
sub RmRef   { return $_[0]->{RMREF} ; }
 1423 
sub RmRef   { return $_[0]->{RMREF} ; }
1426 
 
 1424 
 
1427 
#-------------------------------------------------------------------------------
 1425 
#-------------------------------------------------------------------------------
- 
 
 1426 
# Function        : Url
- 
 
 1427 
#
- 
 
 1428 
# Description     : Accessor function
- 
 
 1429 
#                   Return URL or prepend URL to user tag
- 
 
 1430 
#                   If user tag has a protocol, then don't prepend
- 
 
 1431 
#
- 
 
 1432 
# Inputs          : $self           - Class ref
- 
 
 1433 
#                   $utag           - Option user suffix
- 
 
 1434 
#
- 
 
 1435 
# Returns         : Well formed Url
- 
 
 1436 
#
- 
 
 1437 
sub Url
- 
 
 1438 
{
- 
 
 1439 
    my ( $self, $utag ) = @_;
- 
 
 1440 
    if ( $utag =~ m~^(file|http|https|svn)://([^/]+)~ )
- 
 
 1441 
    {
- 
 
 1442 
        return $utag;
- 
 
 1443 
    }
- 
 
 1444 
    return $self->{URL} . ($utag || '') ;
- 
 
 1445 
}
- 
 
 1446 
 
- 
 
 1447 
 
- 
 
 1448 
#-------------------------------------------------------------------------------
1428 
# Function        : Print
 1449 
# Function        : Print
1429 
#
 1450 
#
1430 
# Description     : Debug display the URL
 1451 
# Description     : Debug display the URL
1431 
#
 1452 
#
1432 
# Inputs          : $self           - Instance data
 1453 
# Inputs          : $self           - Instance data
Line 1446... Line 1467...
1446 
    print $indent . "PROTOCOL:" . $self->{PROTOCOL} . "\n";
 1467 
    print $indent . "PROTOCOL:" . $self->{PROTOCOL} . "\n";
1447 
    print $indent . "SERVER  :" . $self->{SERVER} . "\n";
 1468 
    print $indent . "SERVER  :" . $self->{SERVER} . "\n";
1448 
    print $indent . "URL     :" . $self->{URL} . "\n";
 1469 
    print $indent . "URL     :" . $self->{URL} . "\n";
1449 
    print $indent . "PKGROOT :" . $self->{PKGROOT} . "\n";
 1470 
    print $indent . "PKGROOT :" . $self->{PKGROOT} . "\n";
1450 
    print $indent . "PATH    :" . $self->{PATH} . "\n";
 1471 
    print $indent . "PATH    :" . $self->{PATH} . "\n";
1451 
    print $indent . "PACKAGE :" . $self->{PACKAGE} . "\n";
 - 
 
1452 
    print $indent . "TAGTYPE :" . $self->{TAGTYPE} . "\n";
 1472 
    print $indent . "TAGTYPE :" . $self->{TAGTYPE} . "\n";
1453 
    print $indent . "VERSION :" . $self->{VERSION} . "\n";
 1473 
    print $indent . "VERSION :" . $self->{VERSION} . "\n";
1454 
    print $indent . "PEG     :" . $self->{PEG} . "\n";
 1474 
    print $indent . "PEG     :" . $self->{PEG} . "\n";
1455 
    print $indent . "FULL    :" . $self->Full . "\n";
 1475 
    print $indent . "FULL    :" . $self->Full . "\n";
1456 
}
 1476 
}