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



# Inputs          : $self                   - Instance data
#                   $RepoPath               - Within the repository
#                   $Path                   - Local path
#                   Hash of Options
#                           export          - Bool: Export Only
#                           escrow          - Bool: Less sanity testing
#                           force           - Bool: Force export to overwrite
#                           print           - Bool: Don't print files exported
#                           pretext=aa      - Text: Display before operation
#
# Returns         : Nothing

{
    my $self = shift;
    my $RepoPath = shift;
    my $path = shift;
    my %opt = @_;
 
    Debug ("SvnCo", $RepoPath, $path);
    Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);
 
    #
    #   Set some defaults
    #
    my $cmd = $opt{export} ? 'export' : 'checkout';
    my $print = exists $opt{print} ? $opt{print} : 1;
    $self->{CoText} =  $opt{pretext} || 'Extracting';
 
    #   Define RE to be used to test extraction
    #       Bad news: Some Cots packages have /tags/
    #       Kludge  : Allow /tags/ in escrow mode
    #
    $self->{CoRe} = '((/)(tags|branches|trunk)(/|$))';
    $self->{CoRe} =~ s~tags\|~~ if ( $opt{escrow} );
    
    #
    #   Ensure that the output path does not exist
    #   Do not allow the user to create a local work space
    #   where one already exists
    #

        Verbose2 ("Remove WorkSpace: $path");
        rmtree( $path, IsVerbose(3) );
        rmtree( $path, IsVerbose(3) );
        Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );
    }
 
    #
    #   Cleanup
    #
    delete $self->{CoText};
    delete $self->{CoRe};
    return;
 
    #
    #   Internal routine to scan each the checkout
    #

            {
                Information1 ( $self->{CoText} . ': ' . $data);
            }
        }
 
        #
        #   Detect user attempting to checkout too much of a repo
        #   If the extract contains a 'key' directory then create error
        #
        #   Re is provide by caller such that $1 is the dirpath
        #
        if ( $data =~ m~$self->{CoRe}~ )
        {
            my $bad_dir = $1;
            push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";
            return 1;
        }

# Description     : Check a label
#                       Must not contain a PEG
#                       Must not contain invalid characters (@ or /)
#                       Must not contain a :: sequence (will confuse other tools)
#                       Handle special label of TIMESTAMP
#                           Create a .WIP so that it can be deleted
#
# Inputs          : $label          - to test
#
# Returns         : Will not return on error
#                   Returns label on success

    #
    if ( $label eq 'TIMESTAMP' )
    {
        ::EnvImport ('USER' );
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
        $label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u.WIP",
            $::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );
    }
    return $label;
}
 

#-------------------------------------------------------------------------------
# Function        : setRepoProperty
#
# Description     : Sets a Repository property
#                   This may well fail unless the Repo is setup to allow such
#                   changes and the user is allowed to make such changes
#
# Inputs          : $name
#                   $value
#                   $allowError     - Support for bad repositories
#

#
sub setRepoProperty
{
    my ($self, $name, $value, $allowError ) = @_;
    my $retval = 0;
    my $rv;
 
    Debug ( "setRepoProperty", $name, $value );
    #
    #   Ensure that the Repo version is known
    #   This should be set by a previous operation

    unless ( defined $self->{REVNO} )
    {
        Error ("setRepoProperty. Release Revision Number not known");
    }
 
 
 
    #
    #   Execute the command
    #   Appears tp fail random;y - so try a few times
    #
    for (my $ii = 0; $ii < 3; $ii++ )
    {
    $rv = $self->SvnCmd ( 'propset' , $name, '--revprop', '-r',  $self->{REVNO}, $value, $self->Full,
                            {
                                'credentials' => 1,
                                'nosavedata' => 1,
                            }
                       );
        last unless ( $rv );
        Warning("setRepoProperty: Failure attempt: $ii");
DebugDumpData('setRepoProperty Failure', $self );
        sleep (1);
    }
 
    if ($rv)
    {
        #
        #   Property NOT set
        #
        if ( $allowError )

Rev 2054	Rev 2429
Line 77...	Line 77...
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	`# Hash of Options`	80	`# Hash of Options`
81	`# export - Bool: Export Only`	81	`# export - Bool: Export Only`
-		82	`# escrow - Bool: Less sanity testing`
82	`# force - Bool: Force export to overwrite`	83	`# force - Bool: Force export to overwrite`
83	`# print - Bool: Don't print files exported`	84	`# print - Bool: Don't print files exported`
84	`# pretext=aa - Text: Display before operation`	85	`# pretext=aa - Text: Display before operation`
85	`#`	86	`#`
86	`# Returns : Nothing`	87	`# Returns : Nothing`
Line 89...	Line 90...
89	`{`	90	`{`
90	`my $self = shift;`	91	`my $self = shift;`
91	`my $RepoPath = shift;`	92	`my $RepoPath = shift;`
92	`my $path = shift;`	93	`my $path = shift;`
93	`my %opt = @_;`	94	`my %opt = @_;`
94		95
95	`Debug ("SvnCo", $RepoPath, $path);`	96	`Debug ("SvnCo", $RepoPath, $path);`
96	`Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);`	97	`Error ("SvnCi: Odd number of args") unless ((@_ % 2) == 0);`
97		98
98	`#`	99	`#`
99	`# Set some defaults`	100	`# Set some defaults`
100	`#`	101	`#`
101	`my $cmd = $opt{export} ? 'export' : 'checkout';`	102	`my $cmd = $opt{export} ? 'export' : 'checkout';`
102	`my $print = exists $opt{print} ? $opt{print} : 1;`	103	`my $print = exists $opt{print} ? $opt{print} : 1;`
103	`$self->{CoText} = $opt{pretext} \|\| 'Extracting';`	104	`$self->{CoText} = $opt{pretext} \|\| 'Extracting';`
104		105
-		106	`# Define RE to be used to test extraction`
-		107	`# Bad news: Some Cots packages have /tags/`
-		108	`# Kludge : Allow /tags/ in escrow mode`
-		109	`#`
-		110	`$self->{CoRe} = '((/)(tags\|branches\|trunk)(/\|$))';`
-		111	`$self->{CoRe} =~ s~tags\\|~~ if ( $opt{escrow} );`
-		112
105	`#`	113	`#`
106	`# Ensure that the output path does not exist`	114	`# Ensure that the output path does not exist`
107	`# Do not allow the user to create a local work space`	115	`# Do not allow the user to create a local work space`
108	`# where one already exists`	116	`# where one already exists`
109	`#`	117	`#`
Line 139...	Line 147...
139	`Verbose2 ("Remove WorkSpace: $path");`	147	`Verbose2 ("Remove WorkSpace: $path");`
140	`rmtree( $path, IsVerbose(3) );`	148	`rmtree( $path, IsVerbose(3) );`
141	`rmtree( $path, IsVerbose(3) );`	149	`rmtree( $path, IsVerbose(3) );`
142	`Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );`	150	`Error ("Checking out Workspace", @{$self->{ERROR_LIST}}, @co_list );`
143	`}`	151	`}`
-		152
-		153	`#`
-		154	`# Cleanup`
-		155	`#`
-		156	`delete $self->{CoText};`
-		157	`delete $self->{CoRe};`
144	`return;`	158	`return;`
145		159
146	`#`	160	`#`
147	`# Internal routine to scan each the checkout`	161	`# Internal routine to scan each the checkout`
148	`#`	162	`#`
Line 171...	Line 185...
171	`{`	185	`{`
172	`Information1 ( $self->{CoText} . ': ' . $data);`	186	`Information1 ( $self->{CoText} . ': ' . $data);`
173	`}`	187	`}`
174	`}`	188	`}`
175		189
-		190	`#`
-		191	`# Detect user attempting to checkout too much of a repo`
-		192	`# If the extract contains a 'key' directory then create error`
-		193	`#`
-		194	`# Re is provide by caller such that $1 is the dirpath`
-		195	`#`
176	`if ( $data =~ m~((/)(tags\|branches\|trunk)(/\|$))~ )`	196	`if ( $data =~ m~$self->{CoRe}~ )`
177	`{`	197	`{`
178	`my $bad_dir = $1;`	198	`my $bad_dir = $1;`
179	`push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";`	199	`push @{$self->{ERROR_LIST}}, "Checkout does not describe the root of a package. Contains: $bad_dir";`
180	`return 1;`	200	`return 1;`
181	`}`	201	`}`
Line 1347...	Line 1367...
1347	`# Description : Check a label`	1367	`# Description : Check a label`
1348	`# Must not contain a PEG`	1368	`# Must not contain a PEG`
1349	`# Must not contain invalid characters (@ or /)`	1369	`# Must not contain invalid characters (@ or /)`
1350	`# Must not contain a :: sequence (will confuse other tools)`	1370	`# Must not contain a :: sequence (will confuse other tools)`
1351	`# Handle special label of TIMESTAMP`	1371	`# Handle special label of TIMESTAMP`
-		1372	`# Create a .WIP so that it can be deleted`
1352	`#`	1373	`#`
1353	`# Inputs : $label - to test`	1374	`# Inputs : $label - to test`
1354	`#`	1375	`#`
1355	`# Returns : Will not return on error`	1376	`# Returns : Will not return on error`
1356	`# Returns label on success`	1377	`# Returns label on success`
Line 1374...	Line 1395...
1374	`#`	1395	`#`
1375	`if ( $label eq 'TIMESTAMP' )`	1396	`if ( $label eq 'TIMESTAMP' )`
1376	`{`	1397	`{`
1377	`::EnvImport ('USER' );`	1398	`::EnvImport ('USER' );`
1378	`my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);`	1399	`my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);`
1379	`$label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u",`	1400	`$label = sprintf("%s_%4.4u.%2.2u.%2.2u.%2.2u%2.2u%2.2u.WIP",`
1380	`$::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );`	1401	`$::USER, $year+1900, $mon+1, $mday, $hour, $min, $sec );`
1381	`}`	1402	`}`
1382	`return $label;`	1403	`return $label;`
1383	`}`	1404	`}`
1384		1405
Line 1845...	Line 1866...
1845	`#-------------------------------------------------------------------------------`	1866	`#-------------------------------------------------------------------------------`
1846	`# Function : setRepoProperty`	1867	`# Function : setRepoProperty`
1847	`#`	1868	`#`
1848	`# Description : Sets a Repository property`	1869	`# Description : Sets a Repository property`
1849	`# This may well fail unless the Repo is setup to allow such`	1870	`# This may well fail unless the Repo is setup to allow such`
1850	`# chnages and the user is allowed to make such changes`	1871	`# changes and the user is allowed to make such changes`
1851	`#`	1872	`#`
1852	`# Inputs : $name`	1873	`# Inputs : $name`
1853	`# $value`	1874	`# $value`
1854	`# $allowError - Support for bad repositories`	1875	`# $allowError - Support for bad repositories`
1855	`#`	1876	`#`
Line 1858...	Line 1879...
1858	`#`	1879	`#`
1859	`sub setRepoProperty`	1880	`sub setRepoProperty`
1860	`{`	1881	`{`
1861	`my ($self, $name, $value, $allowError ) = @_;`	1882	`my ($self, $name, $value, $allowError ) = @_;`
1862	`my $retval = 0;`	1883	`my $retval = 0;`
-		1884	`my $rv;`
1863		1885
1864	`Debug ( "setRepoProperty", $name, $value );`	1886	`Debug ( "setRepoProperty", $name, $value );`
1865	`#`	1887	`#`
1866	`# Ensure that the Repo version is known`	1888	`# Ensure that the Repo version is known`
1867	`# This should be set by a previous operation`	1889	`# This should be set by a previous operation`
Line 1869...	Line 1891...
1869	`unless ( defined $self->{REVNO} )`	1891	`unless ( defined $self->{REVNO} )`
1870	`{`	1892	`{`
1871	`Error ("setRepoProperty. Release Revision Number not known");`	1893	`Error ("setRepoProperty. Release Revision Number not known");`
1872	`}`	1894	`}`
1873		1895
-		1896
-		1897
1874	`#`	1898	`#`
1875	`# Execute the command`	1899	`# Execute the command`
-		1900	`# Appears tp fail random;y - so try a few times`
1876	`#`	1901	`#`
-		1902	`for (my $ii = 0; $ii < 3; $ii++ )`
-		1903	`{`
1877	`if ( $self->SvnCmd ( 'propset' , $name, '--revprop', '-r', $self->{REVNO}, $value, $self->Full,`	1904	`$rv = $self->SvnCmd ( 'propset' , $name, '--revprop', '-r', $self->{REVNO}, $value, $self->Full,`
1878	`{`	1905	`{`
1879	`'credentials' => 1,`	1906	`'credentials' => 1,`
1880	`'nosavedata' => 1,`	1907	`'nosavedata' => 1,`
1881	`}`	1908	`}`
1882	`) )`	1909	`);`
-		1910	`last unless ( $rv );`
-		1911	`Warning("setRepoProperty: Failure attempt: $ii");`
-		1912	`DebugDumpData('setRepoProperty Failure', $self );`
-		1913	`sleep (1);`
-		1914	`}`
-		1915
-		1916	`if ($rv)`
1883	`{`	1917	`{`
1884	`#`	1918	`#`
1885	`# Property NOT set`	1919	`# Property NOT set`
1886	`#`	1920	`#`
1887	`if ( $allowError )`	1921	`if ( $allowError )`

Subversion Repositories DevTools

(root)/core_devl/trunk/TOOLS/LIB/JatsSvn.pm – Rev 2054 → 2429