WebSVN – DevTools – Diff – /core_devl/trunk/TOOLS/LIB/JatsSvn.pm



                    SvnRmView
                    SvnIsaSimpleLabel
                    SvnComment
 
                    SvnUserCmd
 
                    SvnPath2Url
                );
@EXPORT_OK =  qw(
                );
 
%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);

 
    #
    #   Create information about the workspace
    #   This will also validate the path
    #
    my $session = NewSessionByWS ( $path, 0, 1 );
 
    #
    #   Validate the path
    #
    $session->SvnValidateWs ($path, 'SvnRmView');

#                   Requires some rules
#                       * The package is rooted within a 'ttb'
#
# Inputs          : $path                   - Path to WorkSpace
#                   $test                   - No Error on no WS
#                   $slack                  - Less stringent
#
# Returns         : Ref to Session Information
#
sub NewSessionByWS
{
    my ($path, $test, $slack) = @_;
    Debug ("NewSessionByWS", @_);
 
    #
    #   Create a basic Session
    #   Populate it with information that is known

        $url = $1;
        $self->{WSTYPE} = $3;
    }
    else
    {
        #
        #   If we are being slack (ie deleting the workspace)
        #   Then generate a warning, not an error
        #
        my $fnc = $slack ? \&Warning : \&Error;
        $fnc->("SvnLocatePackageRoot. Non standard repository format",
               "Url must contain 'tags' or 'branches' or 'trunk'",
               "Url: $url");
        $self->{WSTYPE} = 'trunk';
    }
 
    #
    #   Insert known information
    #

# Function        : NewSessionByUrl
#
# Description     : Establish a new SVN Session based on a user URL
#
# Inputs          : $uurl                   - Users URL
#                   $ttb_test               - Test and warn for TTB structure
#                   $session                - Optional: Existing session
#
# Returns         : Ref to Session Information
#
sub NewSessionByUrl
{
    my ($uurl, $ttb_test, $self ) = @_;
    Debug ("NewSessionByUrl", @_);
    Error ("No Repostory Path specified") unless ( $uurl );
 
    #
    #   Create a basic Session

 
    #
    #   Examine the UURL and convert a Repository Path into a URL
    #   as provided by configuration information within the environment
    #
    ($self->{URL}, $self->{PKGROOT} ) = SvnPath2Url ($uurl);
 
    #
    #   Create useful information
    #
    SplitPackageUrl($self);
 
    #
    #   Warn of non-standard URLs
    #   These may create problems latter
    #
    if ( $ttb_test )
    {
        Warning("Non standard repository format",
                 "Url should contain 'tags' or 'branches' or 'trunk'",
                 "Url: $self->{PKGROOT}") unless $self->{TAGTYPE};
    }
 
    return $self;
}
 
#-------------------------------------------------------------------------------
# Function        : SvnPath2Url
#
# Description     : Convert a repository path to a Full Url
#                   Also handles Full Url
#
# Inputs          : $rpath             - Repository Path
#                                        May be a full URL
#
# Returns         : List context
#                   Two items that can be joined
#                   URL                - URL
#                   PKG_ROOT           - Package Root
#
#                   Scalar context: Joined URL and Package Root
#                                   Fully formed URL
#
sub SvnPath2Url
{
    my ($rpath) = @_;
    my $processed = 0;
    my $url;
    my $pkgroot;
 
    #
    #   Examine the argument and convert a Repository Path into a URL
    #   as provided by configuration information within the environment
    #
    $rpath =~ m~(.+?)/(.*)~;
    my $fe = $1 || $rpath;
    my $rest = $2 || '';
 
    if ( $SVN_URLS{$fe} )
    {
        $url = $SVN_URLS{$fe};
        $pkgroot = $rest;
        $processed = 1;
    }
 
    if ( ! $processed )
    {

        #   Examine the URL and determine if we have a FULL Url or
        #   a path within the 'default' server
        #
        foreach my $key ( @SVN_URLS_LIST )
        {
            if ( $rpath =~ m~^$SVN_URLS{$key}(.*)~ )
            {
                $url = $SVN_URLS{$key};
                $pkgroot = $1;
                $processed = 1;
                last;
            }
        }
    }

    #   Last attempt
    #   Treat as a raw URL - some operations won't be allowed
    #
    if ( ! $processed )
    {
        if ( $rpath =~ m~^((file|http|https|svn):///?([^/]+)/)(.+)~ )
        {
            #       http://server/
            #       https://server/
            #       svn://server/
            #       file://This/Isa/Bad/Guess
            #
            $url = $1;
            $pkgroot = $4;
        }
        elsif ($SVN_URLS{''})
        {
            $url = $SVN_URLS{''};
            $pkgroot = $rpath;
        }
        else
        {
            #
            #   User default (site configured) Repo Root

                   "Configure GBE_SVN_URL_" . uc($fe) );
        }
    }
 
    #
    #   May want two elements, may want one
    #
    return $url, $pkgroot if ( wantarray );
    return $url . $pkgroot;
}
 
 
#-------------------------------------------------------------------------------
# Function        : SplitPackageUrl
#
# Description     : Slip the package URL into a few useful bits
#

#                   Type
#                   WsType
#                   Path
#                   Version
#                   RmRef
 
#
# Description     : Accessor functions
#
# Inputs          : $self       - Instance data
#                                 self (is $_[0])

sub Path    { return $_[0]->{PATH} ; }
sub Version { return $_[0]->{VERSION} ; }
sub RmRef   { return $_[0]->{RMREF} ; }
 
#-------------------------------------------------------------------------------
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
# Function        : Print
#
# Description     : Debug display the URL
#
# Inputs          : $self           - Instance data

Rev 353	Rev 361
Line 52...	Line 52...
52	`SvnRmView`	52	`SvnRmView`
53	`SvnIsaSimpleLabel`	53	`SvnIsaSimpleLabel`
54	`SvnComment`	54	`SvnComment`
55		55
56	`SvnUserCmd`	56	`SvnUserCmd`
-		57
-		58	`SvnPath2Url`
57	`);`	59	`);`
58	`@EXPORT_OK = qw(`	60	`@EXPORT_OK = qw(`
59	`);`	61	`);`
60		62
61	`%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);`	63	`%EXPORT_TAGS = (All => [@EXPORT, @EXPORT_OK]);`
Line 483...	Line 485...
483		485
484	`#`	486	`#`
485	`# Create information about the workspace`	487	`# Create information about the workspace`
486	`# This will also validate the path`	488	`# This will also validate the path`
487	`#`	489	`#`
488	`my $session = NewSessionByWS ( $path );`	490	`my $session = NewSessionByWS ( $path, 0, 1 );`
489		491
490	`#`	492	`#`
491	`# Validate the path`	493	`# Validate the path`
492	`#`	494	`#`
493	`$session->SvnValidateWs ($path, 'SvnRmView');`	495	`$session->SvnValidateWs ($path, 'SvnRmView');`
Line 1125...	Line 1127...
1125	`# Requires some rules`	1127	`# Requires some rules`
1126	`# * The package is rooted within a 'ttb'`	1128	`# * The package is rooted within a 'ttb'`
1127	`#`	1129	`#`
1128	`# Inputs : $path - Path to WorkSpace`	1130	`# Inputs : $path - Path to WorkSpace`
1129	`# $test - No Error on no WS`	1131	`# $test - No Error on no WS`
-		1132	`# $slack - Less stringent`
1130	`#`	1133	`#`
1131	`# Returns : Ref to Session Information`	1134	`# Returns : Ref to Session Information`
1132	`#`	1135	`#`
1133	`sub NewSessionByWS`	1136	`sub NewSessionByWS`
1134	`{`	1137	`{`
1135	`my ($path, $test) = @_;`	1138	`my ($path, $test, $slack) = @_;`
1136	`Debug ("NewSessionByWS", @_);`	1139	`Debug ("NewSessionByWS", @_);`
1137		1140
1138	`#`	1141	`#`
1139	`# Create a basic Session`	1142	`# Create a basic Session`
1140	`# Populate it with information that is known`	1143	`# Populate it with information that is known`
Line 1193...	Line 1196...
1193	`$url = $1;`	1196	`$url = $1;`
1194	`$self->{WSTYPE} = $3;`	1197	`$self->{WSTYPE} = $3;`
1195	`}`	1198	`}`
1196	`else`	1199	`else`
1197	`{`	1200	`{`
-		1201	`#`
-		1202	`# If we are being slack (ie deleting the workspace)`
-		1203	`# Then generate a warning, not an error`
-		1204	`#`
-		1205	`my $fnc = $slack ? \&Warning : \&Error;`
1198	`Error ("SvnLocatePackageRoot. Non standard repository format",`	1206	`$fnc->("SvnLocatePackageRoot. Non standard repository format",`
-		1207	`"Url must contain 'tags' or 'branches' or 'trunk'",`
1199	`"Url: $url");`	1208	`"Url: $url");`
-		1209	`$self->{WSTYPE} = 'trunk';`
1200	`}`	1210	`}`
1201		1211
1202	`#`	1212	`#`
1203	`# Insert known information`	1213	`# Insert known information`
1204	`#`	1214	`#`
Line 1216...	Line 1226...
1216	`# Function : NewSessionByUrl`	1226	`# Function : NewSessionByUrl`
1217	`#`	1227	`#`
1218	`# Description : Establish a new SVN Session based on a user URL`	1228	`# Description : Establish a new SVN Session based on a user URL`
1219	`#`	1229	`#`
1220	`# Inputs : $uurl - Users URL`	1230	`# Inputs : $uurl - Users URL`
-		1231	`# $ttb_test - Test and warn for TTB structure`
1221	`# $session - Optional: Existing session`	1232	`# $session - Optional: Existing session`
1222	`#`	1233	`#`
1223	`# Returns : Ref to Session Information`	1234	`# Returns : Ref to Session Information`
1224	`#`	1235	`#`
1225	`sub NewSessionByUrl`	1236	`sub NewSessionByUrl`
1226	`{`	1237	`{`
1227	`my ($uurl, $self ) = @_;`	1238	`my ($uurl, $ttb_test, $self ) = @_;`
1228	`Debug ("NewSessionByUrl", @_);`	1239	`Debug ("NewSessionByUrl", @_);`
1229	`Error ("No Repostory Path specified") unless ( $uurl );`	1240	`Error ("No Repostory Path specified") unless ( $uurl );`
1230		1241
1231	`#`	1242	`#`
1232	`# Create a basic Session`	1243	`# Create a basic Session`
Line 1236...	Line 1247...
1236		1247
1237	`#`	1248	`#`
1238	`# Examine the UURL and convert a Repository Path into a URL`	1249	`# Examine the UURL and convert a Repository Path into a URL`
1239	`# as provided by configuration information within the environment`	1250	`# as provided by configuration information within the environment`
1240	`#`	1251	`#`
-		1252	`($self->{URL}, $self->{PKGROOT} ) = SvnPath2Url ($uurl);`
-		1253
-		1254	`#`
-		1255	`# Create useful information`
-		1256	`#`
1241	`$uurl =~ m~(.+?)/(.*)~;`	1257	`SplitPackageUrl($self);`
-		1258
-		1259	`#`
-		1260	`# Warn of non-standard URLs`
-		1261	`# These may create problems latter`
-		1262	`#`
1242	`my $fe = $1 \|\| $uurl;`	1263	`if ( $ttb_test )`
-		1264	`{`
-		1265	`Warning("Non standard repository format",`
-		1266	`"Url should contain 'tags' or 'branches' or 'trunk'",`
-		1267	`"Url: $self->{PKGROOT}") unless $self->{TAGTYPE};`
-		1268	`}`
-		1269
-		1270	`return $self;`
-		1271	`}`
-		1272
-		1273	`#-------------------------------------------------------------------------------`
-		1274	`# Function : SvnPath2Url`
-		1275	`#`
-		1276	`# Description : Convert a repository path to a Full Url`
-		1277	`# Also handles Full Url`
-		1278	`#`
-		1279	`# Inputs : $rpath - Repository Path`
-		1280	`# May be a full URL`
-		1281	`#`
-		1282	`# Returns : List context`
-		1283	`# Two items that can be joined`
-		1284	`# URL - URL`
-		1285	`# PKG_ROOT - Package Root`
-		1286	`#`
-		1287	`# Scalar context: Joined URL and Package Root`
-		1288	`# Fully formed URL`
-		1289	`#`
-		1290	`sub SvnPath2Url`
-		1291	`{`
1243	`my $rest = $2 \|\| '';`	1292	`my ($rpath) = @_;`
1244	`my $processed = 0;`	1293	`my $processed = 0;`
-		1294	`my $url;`
-		1295	`my $pkgroot;`
-		1296
-		1297	`#`
-		1298	`# Examine the argument and convert a Repository Path into a URL`
-		1299	`# as provided by configuration information within the environment`
-		1300	`#`
-		1301	`$rpath =~ m~(.+?)/(.*)~;`
-		1302	`my $fe = $1 \|\| $rpath;`
-		1303	`my $rest = $2 \|\| '';`
-		1304
1245	`if ( $SVN_URLS{$fe} )`	1305	`if ( $SVN_URLS{$fe} )`
1246	`{`	1306	`{`
1247	`$self->{URL} = $SVN_URLS{$fe};`	1307	`$url = $SVN_URLS{$fe};`
1248	`$self->{PKGROOT} = $rest;`	1308	`$pkgroot = $rest;`
1249	`$processed = 1;`	1309	`$processed = 1;`
1250	`}`	1310	`}`
1251		1311
1252	`if ( ! $processed )`	1312	`if ( ! $processed )`
1253	`{`	1313	`{`
Line 1255...	Line 1315...
1255	`# Examine the URL and determine if we have a FULL Url or`	1315	`# Examine the URL and determine if we have a FULL Url or`
1256	`# a path within the 'default' server`	1316	`# a path within the 'default' server`
1257	`#`	1317	`#`
1258	`foreach my $key ( @SVN_URLS_LIST )`	1318	`foreach my $key ( @SVN_URLS_LIST )`
1259	`{`	1319	`{`
1260	`if ( $uurl =~ m~^$SVN_URLS{$key}(.*)~ )`	1320	`if ( $rpath =~ m~^$SVN_URLS{$key}(.*)~ )`
1261	`{`	1321	`{`
1262	`$self->{URL} = $SVN_URLS{$key};`	1322	`$url = $SVN_URLS{$key};`
1263	`$self->{PKGROOT} = $1;`	1323	`$pkgroot = $1;`
1264	`$processed = 1;`	1324	`$processed = 1;`
1265	`last;`	1325	`last;`
1266	`}`	1326	`}`
1267	`}`	1327	`}`
1268	`}`	1328	`}`
Line 1271...	Line 1331...
1271	`# Last attempt`	1331	`# Last attempt`
1272	`# Treat as a raw URL - some operations won't be allowed`	1332	`# Treat as a raw URL - some operations won't be allowed`
1273	`#`	1333	`#`
1274	`if ( ! $processed )`	1334	`if ( ! $processed )`
1275	`{`	1335	`{`
1276	`if ( $uurl =~ m~^((file\|http\|https\|svn):///?([^/]+)/)(.+)~ )`	1336	`if ( $rpath =~ m~^((file\|http\|https\|svn):///?([^/]+)/)(.+)~ )`
1277	`{`	1337	`{`
1278	`# http://server/`	1338	`# http://server/`
1279	`# https://server/`	1339	`# https://server/`
1280	`# svn://server/`	1340	`# svn://server/`
1281	`# file://This/Isa/Bad/Guess`	1341	`# file://This/Isa/Bad/Guess`
1282	`#`	1342	`#`
1283	`$self->{URL} = $1;`	1343	`$url = $1;`
1284	`$self->{PKGROOT} = $4;`	1344	`$pkgroot = $4;`
1285	`}`	1345	`}`
1286	`elsif ($SVN_URLS{''})`	1346	`elsif ($SVN_URLS{''})`
1287	`{`	1347	`{`
1288	`$self->{URL} = $SVN_URLS{''};`	1348	`$url = $SVN_URLS{''};`
1289	`$self->{PKGROOT} = $uurl;`	1349	`$pkgroot = $rpath;`
1290	`}`	1350	`}`
1291	`else`	1351	`else`
1292	`{`	1352	`{`
1293	`#`	1353	`#`
1294	`# User default (site configured) Repo Root`	1354	`# User default (site configured) Repo Root`
Line 1297...	Line 1357...
1297	`"Configure GBE_SVN_URL_" . uc($fe) );`	1357	`"Configure GBE_SVN_URL_" . uc($fe) );`
1298	`}`	1358	`}`
1299	`}`	1359	`}`
1300		1360
1301	`#`	1361	`#`
1302	`# Create useful information`	1362	`# May want two elements, may want one`
1303	`#`	1363	`#`
1304	`SplitPackageUrl($self);`	1364	`return $url, $pkgroot if ( wantarray );`
1305	`return $self;`	1365	`return $url . $pkgroot;`
1306	`}`	1366	`}`
1307		1367
-		1368
1308	`#-------------------------------------------------------------------------------`	1369	`#-------------------------------------------------------------------------------`
1309	`# Function : SplitPackageUrl`	1370	`# Function : SplitPackageUrl`
1310	`#`	1371	`#`
1311	`# Description : Slip the package URL into a few useful bits`	1372	`# Description : Slip the package URL into a few useful bits`
1312	`#`	1373	`#`
Line 1368...	Line 1429...
1368	`# Type`	1429	`# Type`
1369	`# WsType`	1430	`# WsType`
1370	`# Path`	1431	`# Path`
1371	`# Version`	1432	`# Version`
1372	`# RmRef`	1433	`# RmRef`
1373	`# Url`	-
1374	`#`	1434	`#`
1375	`# Description : Accessor functions`	1435	`# Description : Accessor functions`
1376	`#`	1436	`#`
1377	`# Inputs : $self - Instance data`	1437	`# Inputs : $self - Instance data`
1378	`# self (is $_[0])`	1438	`# self (is $_[0])`
Line 1387...	Line 1447...
1387	`sub Path { return $_[0]->{PATH} ; }`	1447	`sub Path { return $_[0]->{PATH} ; }`
1388	`sub Version { return $_[0]->{VERSION} ; }`	1448	`sub Version { return $_[0]->{VERSION} ; }`
1389	`sub RmRef { return $_[0]->{RMREF} ; }`	1449	`sub RmRef { return $_[0]->{RMREF} ; }`
1390		1450
1391	`#-------------------------------------------------------------------------------`	1451	`#-------------------------------------------------------------------------------`
1392	`# Function : Url`	-
1393	`#`	-
1394	`# Description : Accessor function`	-
1395	`# Return URL or prepend URL to user tag`	-
1396	`# If user tag has a protocol, then don't prepend`	-
1397	`#`	-
1398	`# Inputs : $self - Class ref`	-
1399	`# $utag - Option user suffix`	-
1400	`#`	-
1401	`# Returns : Well formed Url`	-
1402	`#`	-
1403	`sub Url`	-
1404	`{`	-
1405	`my ( $self, $utag ) = @_;`	-
1406	`if ( $utag =~ m~^(file\|http\|https\|svn)://([^/]+)~ )`	-
1407	`{`	-
1408	`return $utag;`	-
1409	`}`	-
1410	`return $self->{URL} . ($utag \|\| '') ;`	-
1411	`}`	-
1412		-
1413		-
1414	`#-------------------------------------------------------------------------------`	-
1415	`# Function : Print`	1452	`# Function : Print`
1416	`#`	1453	`#`
1417	`# Description : Debug display the URL`	1454	`# Description : Debug display the URL`
1418	`#`	1455	`#`
1419	`# Inputs : $self - Instance data`	1456	`# Inputs : $self - Instance data`

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/LIB/JatsSvn.pm – Rev 353 → 361