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
}