line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# BEGIN BPS TAGGED BLOCK {{{ |
2
|
|
|
|
|
|
|
# COPYRIGHT: |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# This software is Copyright (c) 2003-2008 Best Practical Solutions, LLC |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# (Except where explicitly superseded by other copyright notices) |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# LICENSE: |
11
|
|
|
|
|
|
|
# |
12
|
|
|
|
|
|
|
# |
13
|
|
|
|
|
|
|
# This program is free software; you can redistribute it and/or |
14
|
|
|
|
|
|
|
# modify it under the terms of either: |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# a) Version 2 of the GNU General Public License. You should have |
17
|
|
|
|
|
|
|
# received a copy of the GNU General Public License along with this |
18
|
|
|
|
|
|
|
# program. If not, write to the Free Software Foundation, Inc., 51 |
19
|
|
|
|
|
|
|
# Franklin Street, Fifth Floor, Boston, MA 02110-1301 or visit |
20
|
|
|
|
|
|
|
# their web page on the internet at |
21
|
|
|
|
|
|
|
# http://www.gnu.org/copyleft/gpl.html. |
22
|
|
|
|
|
|
|
# |
23
|
|
|
|
|
|
|
# b) Version 1 of Perl's "Artistic License". You should have received |
24
|
|
|
|
|
|
|
# a copy of the Artistic License with this package, in the file |
25
|
|
|
|
|
|
|
# named "ARTISTIC". The license is also available at |
26
|
|
|
|
|
|
|
# http://opensource.org/licenses/artistic-license.php. |
27
|
|
|
|
|
|
|
# |
28
|
|
|
|
|
|
|
# This work is distributed in the hope that it will be useful, but |
29
|
|
|
|
|
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of |
30
|
|
|
|
|
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
31
|
|
|
|
|
|
|
# General Public License for more details. |
32
|
|
|
|
|
|
|
# |
33
|
|
|
|
|
|
|
# CONTRIBUTION SUBMISSION POLICY: |
34
|
|
|
|
|
|
|
# |
35
|
|
|
|
|
|
|
# (The following paragraph is not intended to limit the rights granted |
36
|
|
|
|
|
|
|
# to you to modify and distribute this software under the terms of the |
37
|
|
|
|
|
|
|
# GNU General Public License and is only of importance to you if you |
38
|
|
|
|
|
|
|
# choose to contribute your changes and enhancements to the community |
39
|
|
|
|
|
|
|
# by submitting them to Best Practical Solutions, LLC.) |
40
|
|
|
|
|
|
|
# |
41
|
|
|
|
|
|
|
# By intentionally submitting any modifications, corrections or |
42
|
|
|
|
|
|
|
# derivatives to this work, or any other work intended for use with SVK, |
43
|
|
|
|
|
|
|
# to Best Practical Solutions, LLC, you confirm that you are the |
44
|
|
|
|
|
|
|
# copyright holder for those contributions and you grant Best Practical |
45
|
|
|
|
|
|
|
# Solutions, LLC a nonexclusive, worldwide, irrevocable, royalty-free, |
46
|
|
|
|
|
|
|
# perpetual, license to use, copy, create derivative works based on |
47
|
|
|
|
|
|
|
# those contributions, and sublicense and distribute those contributions |
48
|
|
|
|
|
|
|
# and any derivatives thereof. |
49
|
|
|
|
|
|
|
# |
50
|
|
|
|
|
|
|
# END BPS TAGGED BLOCK }}} |
51
|
|
|
|
|
|
|
package SVK::Test; |
52
|
176
|
|
|
176
|
|
4293590
|
use strict; |
|
176
|
|
|
|
|
446
|
|
|
176
|
|
|
|
|
13152
|
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# When running tests, don't let the user's .subversion/config |
55
|
|
|
|
|
|
|
# affect results. |
56
|
176
|
|
|
176
|
|
9777
|
BEGIN { $ENV{SVKNOSVNCONFIG} = 1; } |
57
|
|
|
|
|
|
|
|
58
|
176
|
|
|
176
|
|
142446
|
use SVK::Version; our $VERSION = $SVK::VERSION; |
|
176
|
|
|
|
|
16526
|
|
|
176
|
|
|
|
|
8772
|
|
59
|
176
|
|
|
176
|
|
1357
|
use base 'Exporter'; |
|
176
|
|
|
|
|
345
|
|
|
176
|
|
|
|
|
34072
|
|
60
|
|
|
|
|
|
|
|
61
|
176
|
|
|
176
|
|
148770
|
use SVK::Logger; |
|
176
|
|
|
|
|
2090
|
|
|
176
|
|
|
|
|
10123
|
|
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
our @EXPORT = qw(plan_svm new_repos build_test build_floating_test |
64
|
|
|
|
|
|
|
get_copath append_file overwrite_file |
65
|
|
|
|
|
|
|
overwrite_file_raw is_file_content |
66
|
|
|
|
|
|
|
is_file_content_raw _do_run is_output |
67
|
|
|
|
|
|
|
is_sorted_output is_deeply_like is_output_like |
68
|
|
|
|
|
|
|
is_output_unlike is_ancestor status_native status |
69
|
|
|
|
|
|
|
get_editor create_basic_tree waste_rev |
70
|
|
|
|
|
|
|
tree_from_fsroot tree_from_xdroot __ _x not_x _l |
71
|
|
|
|
|
|
|
not_l uri set_editor replace_file glob_mime_samples |
72
|
|
|
|
|
|
|
create_mime_samples chmod_probably_useless |
73
|
|
|
|
|
|
|
add_prop_to_basic_tree |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
catdir HAS_SVN_MIRROR IS_WIN32 install_perl_hook |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
rmtree mkpath @TOCLEAN $output $answer $show_prompt); |
78
|
|
|
|
|
|
|
|
79
|
176
|
|
|
176
|
|
117321
|
use Test::More; |
|
176
|
|
|
|
|
1964083
|
|
|
176
|
|
|
|
|
2608
|
|
80
|
|
|
|
|
|
|
push @EXPORT, @Test::More::EXPORT; |
81
|
|
|
|
|
|
|
sub import { |
82
|
0
|
|
|
0
|
|
|
my $class = shift; |
83
|
|
|
|
|
|
|
|
84
|
0
|
|
|
|
|
|
my $caller = caller; |
85
|
0
|
|
|
|
|
|
my $tb = Test::More->builder; |
86
|
0
|
|
|
|
|
|
$tb->exported_to($caller); |
87
|
|
|
|
|
|
|
|
88
|
0
|
|
|
|
|
|
$class->export_to_level(1, @_); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
my $pid = $$; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
our @TOCLEAN; |
94
|
|
|
|
|
|
|
END { |
95
|
176
|
50
|
|
176
|
|
40741
|
return unless $$ == $pid; |
96
|
0
|
|
|
|
|
|
rm_test($_) for @TOCLEAN; |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
176
|
|
|
176
|
|
282788
|
use SVK; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
100
|
|
|
|
|
|
|
use File::Path; |
101
|
|
|
|
|
|
|
use File::Temp; |
102
|
|
|
|
|
|
|
use SVK::Util qw( dirname catdir tmpdir can_run abs_path $SEP $EOL IS_WIN32 HAS_SVN_MIRROR ); |
103
|
|
|
|
|
|
|
require Storable; |
104
|
|
|
|
|
|
|
use SVK::Path::Checkout; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# Fake standard input |
107
|
|
|
|
|
|
|
our $answer = []; |
108
|
|
|
|
|
|
|
our $output; |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
our $show_prompt = 0; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
BEGIN { |
113
|
|
|
|
|
|
|
no warnings 'redefine'; |
114
|
|
|
|
|
|
|
# override get_prompt in XD so devel::cover is happy for |
115
|
|
|
|
|
|
|
# already-exported symbols being overridden |
116
|
|
|
|
|
|
|
*SVK::Util::get_prompt = *SVK::XD::get_prompt = sub { |
117
|
|
|
|
|
|
|
local $| = 1; |
118
|
|
|
|
|
|
|
print "$_[0]\n" if $show_prompt; |
119
|
|
|
|
|
|
|
$logger->debug("$_[0]"); |
120
|
|
|
|
|
|
|
return $answer unless ref($answer); # compat |
121
|
|
|
|
|
|
|
die "expecting input" unless @$answer; |
122
|
|
|
|
|
|
|
my $ans = shift @$answer; |
123
|
|
|
|
|
|
|
$logger->debug("-> ".($answer->[0]||'')); |
124
|
|
|
|
|
|
|
return $ans unless ref($ans); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
if (ref($ans->[0]) eq 'Regexp') { |
127
|
|
|
|
|
|
|
Carp::cluck "prompt mismatch ($_[0]) vs ($ans->[0])" unless $_[0] =~ m/$ans->[0]/s; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
else { |
130
|
|
|
|
|
|
|
Carp::cluck "prompt mismatch ($_[0]) vs ($ans->[0])" if $_[0] ne $ans->[0]; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
return $ans->[1]; |
133
|
|
|
|
|
|
|
} unless $ENV{DEBUG_INTERACTIVE}; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
# chdir catdir(abs_path(dirname(__FILE__)), '..' ); |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub plan_svm { |
139
|
|
|
|
|
|
|
unless (HAS_SVN_MIRROR) { |
140
|
|
|
|
|
|
|
plan skip_all => "SVN::Mirror not installed"; |
141
|
|
|
|
|
|
|
exit; |
142
|
|
|
|
|
|
|
}; |
143
|
|
|
|
|
|
|
plan @_; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
use Carp; |
147
|
|
|
|
|
|
|
use SVK; |
148
|
|
|
|
|
|
|
use SVK::XD; |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
END { |
151
|
|
|
|
|
|
|
return unless $$ == $pid; |
152
|
|
|
|
|
|
|
$SIG{__WARN__} = sub { 1 }; |
153
|
|
|
|
|
|
|
cleanup_test($_) for @TOCLEAN; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
for (qw/SVKRESOLVE SVKMERGE SVKDIFF SVKPGP SVKLOGOUTPUT LC_CTYPE LC_ALL LANG LC_MESSAGES/) { |
157
|
|
|
|
|
|
|
$ENV{$_} = '' if $ENV{$_}; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
$ENV{LANGUAGE} = $ENV{LANGUAGES} = 'i-default'; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
$ENV{SVKRESOLVE} = 's'; # default for test |
162
|
|
|
|
|
|
|
$ENV{HOME} ||= ( |
163
|
|
|
|
|
|
|
$ENV{HOMEDRIVE} ? catdir(@ENV{qw( HOMEDRIVE HOMEPATH )}) : '' |
164
|
|
|
|
|
|
|
) || (getpwuid($<))[7]; |
165
|
|
|
|
|
|
|
$ENV{USER} ||= ( |
166
|
|
|
|
|
|
|
(defined &Win32::LoginName) ? Win32::LoginName() : '' |
167
|
|
|
|
|
|
|
) || $ENV{USERNAME} || (getpwuid($<))[0]; |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# Make "prove -l" happy; abs_path() returns "undef" if the path |
170
|
|
|
|
|
|
|
# does not exist. This makes perl very unhappy. |
171
|
|
|
|
|
|
|
@INC = grep defined, map abs_path($_), @INC; |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
if ($ENV{DEBUG}) { |
174
|
|
|
|
|
|
|
{ |
175
|
|
|
|
|
|
|
package Tie::StdScalar::Tee; |
176
|
|
|
|
|
|
|
require Tie::Scalar; |
177
|
|
|
|
|
|
|
our @ISA = 'Tie::StdScalar'; |
178
|
|
|
|
|
|
|
sub STORE { print STDOUT $_[1] ; ${$_[0]} = $_[1]; } |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
tie $output => 'Tie::StdScalar::Tee'; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
my $pool = SVN::Pool->new_default; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub new_repos { |
186
|
|
|
|
|
|
|
my $repospath = catdir(tmpdir(), "svk-$$"); |
187
|
|
|
|
|
|
|
my $reposbase = $repospath; |
188
|
|
|
|
|
|
|
my $repos; |
189
|
|
|
|
|
|
|
my $i = 0; |
190
|
|
|
|
|
|
|
while (-e $repospath) { |
191
|
|
|
|
|
|
|
$repospath = $reposbase . '-'. (++$i); |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
my $pool = SVN::Pool->new_default; |
194
|
|
|
|
|
|
|
$repos = SVN::Repos::create("$repospath", undef, undef, undef, |
195
|
|
|
|
|
|
|
{'fs-type' => $ENV{SVNFSTYPE} || 'fsfs'}) |
196
|
|
|
|
|
|
|
or die "failed to create repository at $repospath"; |
197
|
|
|
|
|
|
|
return $repospath; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub build_test { |
201
|
|
|
|
|
|
|
my (@depot) = @_; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
my $depotmap = {map {$_ => (new_repos())[0]} '',@depot}; |
204
|
|
|
|
|
|
|
my $xd = SVK::XD->new (depotmap => $depotmap, |
205
|
|
|
|
|
|
|
svkpath => $depotmap->{''}); |
206
|
|
|
|
|
|
|
my $svk = SVK->new (xd => $xd, $ENV{DEBUG_INTERACTIVE} ? () : (output => \$output)); |
207
|
|
|
|
|
|
|
push @TOCLEAN, [$xd, $svk]; |
208
|
|
|
|
|
|
|
return ($xd, $svk); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub build_floating_test { |
212
|
|
|
|
|
|
|
my ($directory) = @_; |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
my $svkpath = File::Spec->catfile($directory, '.svk'); |
215
|
|
|
|
|
|
|
my $xd = SVK::XD->new (statefile => File::Spec->catfile($svkpath, 'config'), |
216
|
|
|
|
|
|
|
giantlock => File::Spec->catfile($svkpath, 'lock'), |
217
|
|
|
|
|
|
|
svkpath => $svkpath, |
218
|
|
|
|
|
|
|
floating => $directory); |
219
|
|
|
|
|
|
|
$xd->load; |
220
|
|
|
|
|
|
|
my $svk = SVK->new (xd => $xd, $ENV{DEBUG_INTERACTIVE} ? () : (output => \$output)); |
221
|
|
|
|
|
|
|
push @TOCLEAN, [$xd, $svk]; |
222
|
|
|
|
|
|
|
return ($xd, $svk); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
sub get_copath { |
226
|
|
|
|
|
|
|
my ($name) = @_; |
227
|
|
|
|
|
|
|
unless ($name) { |
228
|
|
|
|
|
|
|
$name = lc($0); |
229
|
|
|
|
|
|
|
$name =~ s/\.t$//; |
230
|
|
|
|
|
|
|
$name =~ s/(\W|[_-])+//g; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
my $copath = SVK::Path::Checkout->copath ('t', "checkout/$name"); |
233
|
|
|
|
|
|
|
mkpath [$copath] unless -d $copath; |
234
|
|
|
|
|
|
|
rmtree [$copath] if -e $copath; |
235
|
|
|
|
|
|
|
return ($copath, File::Spec->rel2abs($copath)); |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub rm_test { |
239
|
|
|
|
|
|
|
my ($xd, $svk) = @{+shift}; |
240
|
|
|
|
|
|
|
for my $depot (sort keys %{$xd->{depotmap}}) { |
241
|
|
|
|
|
|
|
my $path = $xd->{depotmap}{$depot}; |
242
|
|
|
|
|
|
|
die if $path eq '/'; |
243
|
|
|
|
|
|
|
rmtree [$path]; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub cleanup_test { |
248
|
|
|
|
|
|
|
my ($xd, $svk) = @{+shift}; |
249
|
|
|
|
|
|
|
for my $depotname (sort keys %{$xd->{depotmap}}) { |
250
|
|
|
|
|
|
|
my $pool = SVN::Pool->new_default; |
251
|
|
|
|
|
|
|
my $depot = eval { $xd->find_depot($depotname) } or next; |
252
|
|
|
|
|
|
|
my @txns = @{ $depot->repos->fs->list_transactions }; |
253
|
|
|
|
|
|
|
if (@txns) { |
254
|
|
|
|
|
|
|
my $how_many = @txns; |
255
|
|
|
|
|
|
|
diag "uncleaned txns ($how_many) on /$depotname/"; |
256
|
|
|
|
|
|
|
if ( $ENV{SVKTESTUNCLEANTXN} ) { |
257
|
|
|
|
|
|
|
for my $txn_name ( sort @txns ) { |
258
|
|
|
|
|
|
|
my $txn = $depot->repos->fs->open_txn($txn_name); |
259
|
|
|
|
|
|
|
my $log = $txn->prop('svn:log'); |
260
|
|
|
|
|
|
|
diag "$txn_name: $log"; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
return unless $ENV{TEST_VERBOSE}; |
266
|
|
|
|
|
|
|
use YAML::Syck; |
267
|
|
|
|
|
|
|
print Dump($xd); |
268
|
|
|
|
|
|
|
for my $depotname (sort keys %{$xd->{depotmap}}) { |
269
|
|
|
|
|
|
|
my $pool = SVN::Pool->new_default; |
270
|
|
|
|
|
|
|
my $depot = eval { $xd->find_depot($depotname) } or next; |
271
|
|
|
|
|
|
|
print "===> depot /$depotname/ (".$depot->repos->fs->get_uuid."):\n"; |
272
|
|
|
|
|
|
|
$svk->log ('-v', "/$depotname/"); |
273
|
|
|
|
|
|
|
# if DEBUG is set, the log command already printed the log to |
274
|
|
|
|
|
|
|
# stdout; if it isn't, we have to do it ourself |
275
|
|
|
|
|
|
|
print ${$svk->{output}} unless $ENV{DEBUG}; |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub append_file { |
280
|
|
|
|
|
|
|
my ($file, $content) = @_; |
281
|
|
|
|
|
|
|
open my ($fh), '>>', $file or die "can't append $file: $!"; |
282
|
|
|
|
|
|
|
print $fh $content; |
283
|
|
|
|
|
|
|
close $fh; |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub overwrite_file { |
287
|
|
|
|
|
|
|
my ($file, $content) = @_; |
288
|
|
|
|
|
|
|
open my ($fh), '>', $file or confess "Cannot overwrite $file: $!"; |
289
|
|
|
|
|
|
|
print $fh $content; |
290
|
|
|
|
|
|
|
close $fh; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
sub overwrite_file_raw { |
294
|
|
|
|
|
|
|
my ($file, $content) = @_; |
295
|
|
|
|
|
|
|
open my ($fh), '>:raw', $file or confess "Cannot overwrite $file: $!"; |
296
|
|
|
|
|
|
|
print $fh $content; |
297
|
|
|
|
|
|
|
close $fh; |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
sub is_file_content { |
301
|
|
|
|
|
|
|
my ($file, $content, $test) = @_; |
302
|
|
|
|
|
|
|
unless (-e $file) { |
303
|
|
|
|
|
|
|
@_ = (undef, $content, $test); |
304
|
|
|
|
|
|
|
goto &is; |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
open my ($fh), '<', $file or confess "Cannot read from $file: $!"; |
307
|
|
|
|
|
|
|
my $actual_content = do { local $/; <$fh> }; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
@_ = ($actual_content, $content, $test); |
310
|
|
|
|
|
|
|
goto &is; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
sub is_file_content_raw { |
314
|
|
|
|
|
|
|
my ($file, $content, $test) = @_; |
315
|
|
|
|
|
|
|
open my ($fh), '<:raw', $file or confess "Cannot read from $file: $!"; |
316
|
|
|
|
|
|
|
local $/; |
317
|
|
|
|
|
|
|
@_ = (<$fh>, $content, $test); |
318
|
|
|
|
|
|
|
goto &is; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
sub _do_run { |
322
|
|
|
|
|
|
|
my ($svk, $cmd, $arg) = @_; |
323
|
|
|
|
|
|
|
my $unlock = SVK::XD->can('unlock'); |
324
|
|
|
|
|
|
|
my $giant_unlock = SVK::XD->can('giant_unlock'); |
325
|
|
|
|
|
|
|
no warnings 'redefine'; |
326
|
|
|
|
|
|
|
my $origxd = Storable::dclone($svk->{xd}->{checkout}); |
327
|
|
|
|
|
|
|
require SVK::Command::Checkout; |
328
|
|
|
|
|
|
|
my $giant_locked = 1; |
329
|
|
|
|
|
|
|
local *SVK::XD::giant_unlock = sub { |
330
|
|
|
|
|
|
|
$giant_locked = 0; |
331
|
|
|
|
|
|
|
goto $giant_unlock; |
332
|
|
|
|
|
|
|
}; |
333
|
|
|
|
|
|
|
local *SVK::XD::unlock = sub { |
334
|
|
|
|
|
|
|
my $self = shift; |
335
|
|
|
|
|
|
|
unless ($giant_locked) { |
336
|
|
|
|
|
|
|
my $newxd = Storable::dclone($self->{checkout}); |
337
|
|
|
|
|
|
|
my @paths = $self->{checkout}->find ('', {lock => $$}); |
338
|
|
|
|
|
|
|
my %empty = (lock => undef, '.conflict' => undef, |
339
|
|
|
|
|
|
|
'.deleted' => undef, |
340
|
|
|
|
|
|
|
SVK::Command::Checkout::detach->_remove_entry, |
341
|
|
|
|
|
|
|
SVK::Command->_schedule_empty); |
342
|
|
|
|
|
|
|
for (@paths) { |
343
|
|
|
|
|
|
|
$origxd->store($_, \%empty, {override_sticky_descendents => 1}); |
344
|
|
|
|
|
|
|
$newxd-> store($_, \%empty, {override_sticky_descendents => 1}); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
diag Carp::longmess.YAML::Syck::Dump({orig => $origxd, new => $newxd, paths => \@paths}) |
347
|
|
|
|
|
|
|
unless eq_hash($origxd, $newxd); |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
$unlock->($self, @_); |
350
|
|
|
|
|
|
|
}; |
351
|
|
|
|
|
|
|
$svk->$cmd (@$arg); |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
sub is_output { |
355
|
|
|
|
|
|
|
my ($svk, $cmd, $arg, $expected, $test) = @_; |
356
|
|
|
|
|
|
|
_do_run($svk, $cmd, $arg); |
357
|
|
|
|
|
|
|
my $cmp = (grep {ref ($_) eq 'Regexp'} @$expected) |
358
|
|
|
|
|
|
|
? \&is_deeply_like : \&is_deeply; |
359
|
|
|
|
|
|
|
my $o = $output; |
360
|
|
|
|
|
|
|
$o =~ s/\r?\n$//; |
361
|
|
|
|
|
|
|
@_ = ([split (/\r?\n/, $o, -1)], $expected, $test || join(' ', map { / / ? qq("$_") : $_ } $cmd, @$arg)); |
362
|
|
|
|
|
|
|
goto &$cmp; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub is_sorted_output { |
366
|
|
|
|
|
|
|
my ($svk, $cmd, $arg, $expected, $test) = @_; |
367
|
|
|
|
|
|
|
_do_run($svk, $cmd, $arg); |
368
|
|
|
|
|
|
|
my $cmp = (grep {ref ($_) eq 'Regexp'} @$expected) |
369
|
|
|
|
|
|
|
? \&is_deeply_like : \&is_deeply; |
370
|
|
|
|
|
|
|
@_ = ([sort split (/\r?\n/, $output)], [sort @$expected], $test || join(' ', $cmd, @$arg)); |
371
|
|
|
|
|
|
|
goto &$cmp; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub is_deeply_like { |
375
|
|
|
|
|
|
|
my ($got, $expected, $test) = @_; |
376
|
|
|
|
|
|
|
for (0..$#{$expected}) { |
377
|
|
|
|
|
|
|
if (ref ($expected->[$_]) eq 'SCALAR' ) { |
378
|
|
|
|
|
|
|
@_ = ($#{$got}, $#{$got}, $test); |
379
|
|
|
|
|
|
|
goto &is; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
elsif (ref ($expected->[$_]) eq 'Regexp' ) { |
382
|
|
|
|
|
|
|
unless ($got->[$_] =~ m/$expected->[$_]/) { |
383
|
|
|
|
|
|
|
diag "Different at $_:\n$got->[$_]\n$expected->[$_]"; |
384
|
|
|
|
|
|
|
@_ = (0, $test); |
385
|
|
|
|
|
|
|
goto &ok; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
else { |
389
|
|
|
|
|
|
|
if ($got->[$_] ne $expected->[$_]) { |
390
|
|
|
|
|
|
|
diag "Different at $_:\n$got->[$_]\n$expected->[$_]"; |
391
|
|
|
|
|
|
|
@_ = (0, $test); |
392
|
|
|
|
|
|
|
goto &ok; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
@_ = ($#{$expected}, $#{$got}, $test); |
397
|
|
|
|
|
|
|
goto &is; |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
sub is_output_like { |
401
|
|
|
|
|
|
|
my ($svk, $cmd, $arg, $expected, $test) = @_; |
402
|
|
|
|
|
|
|
_do_run($svk, $cmd, $arg); |
403
|
|
|
|
|
|
|
@_ = ($output, $expected, $test || join(' ', $cmd, @$arg)); |
404
|
|
|
|
|
|
|
goto &like; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
sub is_output_unlike { |
408
|
|
|
|
|
|
|
my ($svk, $cmd, $arg, $expected, $test) = @_; |
409
|
|
|
|
|
|
|
_do_run($svk, $cmd, $arg); |
410
|
|
|
|
|
|
|
@_ = ($output, $expected, $test || join(' ', $cmd, @$arg)); |
411
|
|
|
|
|
|
|
goto &unlike; |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
sub is_ancestor { |
415
|
|
|
|
|
|
|
my ($svk, $path, @expected) = @_; |
416
|
|
|
|
|
|
|
$svk->info ($path); |
417
|
|
|
|
|
|
|
my (@copied) = $output =~ m/Copied From: (.*?), Rev. (\d+)/mg; |
418
|
|
|
|
|
|
|
@_ = (\@copied, \@expected); |
419
|
|
|
|
|
|
|
goto &is_deeply; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
sub status_native { |
423
|
|
|
|
|
|
|
my $copath = shift; |
424
|
|
|
|
|
|
|
my @ret; |
425
|
|
|
|
|
|
|
while (my ($status, $path) = splice (@_, 0, 2)) { |
426
|
|
|
|
|
|
|
push @ret, join (' ', $status, $copath ? SVK::Path::Checkout->copath($copath, $path) : |
427
|
|
|
|
|
|
|
File::Spec->catfile (File::Spec::Unix->splitdir ($path))); |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
return @ret; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub status { |
433
|
|
|
|
|
|
|
my @ret; |
434
|
|
|
|
|
|
|
while (my ($status, $path) = splice (@_, 0, 2)) { |
435
|
|
|
|
|
|
|
push @ret, join (' ', $status, $path); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
return @ret; |
438
|
|
|
|
|
|
|
} |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
require SVN::Simple::Edit; |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
sub get_editor { |
443
|
|
|
|
|
|
|
my ($repospath, $path, $repos) = @_; |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
return SVN::Simple::Edit->new |
446
|
|
|
|
|
|
|
(_editor => [SVN::Repos::get_commit_editor($repos, |
447
|
|
|
|
|
|
|
"file://$repospath", |
448
|
|
|
|
|
|
|
$path, |
449
|
|
|
|
|
|
|
'svk', 'test init tree', |
450
|
|
|
|
|
|
|
sub {})], |
451
|
|
|
|
|
|
|
base_path => $path, |
452
|
|
|
|
|
|
|
root => $repos->fs->revision_root ($repos->fs->youngest_rev), |
453
|
|
|
|
|
|
|
missing_handler => SVN::Simple::Edit::check_missing ()); |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
sub create_basic_tree { |
457
|
|
|
|
|
|
|
my ($xd, $depotpath) = @_; |
458
|
|
|
|
|
|
|
my $pool = SVN::Pool->new_default; |
459
|
|
|
|
|
|
|
my ($depot, $path) = $xd->find_depotpath($depotpath); |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
local $/ = $EOL; |
462
|
|
|
|
|
|
|
my $edit = get_editor ($depot->repospath, $path, $depot->repos); |
463
|
|
|
|
|
|
|
$edit->open_root (); |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/me'), |
466
|
|
|
|
|
|
|
"first line in me$/2nd line in me$/"); |
467
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/A/be'), |
468
|
|
|
|
|
|
|
"\$Rev\$ \$Revision\$$/\$FileRev\$$/first line in be$/2nd line in be$/"); |
469
|
|
|
|
|
|
|
$edit->change_file_prop ('/A/be', 'svn:keywords', 'Rev URL Revision FileRev'); |
470
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/A/P/pe'), |
471
|
|
|
|
|
|
|
"first line in pe$/2nd line in pe$/"); |
472
|
|
|
|
|
|
|
$edit->add_directory ('/B'); |
473
|
|
|
|
|
|
|
$edit->add_directory ('/C'); |
474
|
|
|
|
|
|
|
$edit->add_directory ('/A/Q'); |
475
|
|
|
|
|
|
|
$edit->change_dir_prop ('/A/Q', 'foo', 'prop on A/Q'); |
476
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/A/Q/qu'), |
477
|
|
|
|
|
|
|
"first line in qu$/2nd line in qu$/"); |
478
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/A/Q/qz'), |
479
|
|
|
|
|
|
|
"first line in qz$/2nd line in qz$/"); |
480
|
|
|
|
|
|
|
$edit->add_directory ('/C/R'); |
481
|
|
|
|
|
|
|
$edit->close_edit (); |
482
|
|
|
|
|
|
|
my $tree = { child => { me => {}, |
483
|
|
|
|
|
|
|
A => { child => { be => {}, |
484
|
|
|
|
|
|
|
P => { child => {pe => {}, |
485
|
|
|
|
|
|
|
}}, |
486
|
|
|
|
|
|
|
Q => { child => {qu => {}, |
487
|
|
|
|
|
|
|
ez => {}, |
488
|
|
|
|
|
|
|
}}, |
489
|
|
|
|
|
|
|
}}, |
490
|
|
|
|
|
|
|
B => {}, |
491
|
|
|
|
|
|
|
C => { child => { R => { child => {}}}} |
492
|
|
|
|
|
|
|
}}; |
493
|
|
|
|
|
|
|
my $rev = $depot->repos->fs->youngest_rev; |
494
|
|
|
|
|
|
|
$edit = get_editor ($depot->repospath, $path, $depot->repos); |
495
|
|
|
|
|
|
|
$edit->open_root (); |
496
|
|
|
|
|
|
|
$edit->modify_file ('/me', "first line in me$/2nd line in me - mod$/"); |
497
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/B/fe'), |
498
|
|
|
|
|
|
|
"file fe added later$/"); |
499
|
|
|
|
|
|
|
$edit->delete_entry ('/A/P'); |
500
|
|
|
|
|
|
|
$edit->copy_directory('/B/S', "file://@{[$depot->repospath]}/${path}/A", $rev); |
501
|
|
|
|
|
|
|
$edit->modify_file ($edit->add_file ('/D/de'), |
502
|
|
|
|
|
|
|
"file de added later$/"); |
503
|
|
|
|
|
|
|
$edit->close_edit (); |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
$tree->{child}{B}{child}{fe} = {}; |
506
|
|
|
|
|
|
|
# XXX: have to clone this... |
507
|
|
|
|
|
|
|
%{$tree->{child}{B}{child}{S}} = (child => {%{$tree->{child}{A}{child}}}, |
508
|
|
|
|
|
|
|
history => '/A:1'); |
509
|
|
|
|
|
|
|
delete $tree->{child}{A}{child}{P}; |
510
|
|
|
|
|
|
|
$tree->{child}{D}{child}{de} = {}; |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
return $tree; |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
sub add_prop_to_basic_tree { |
516
|
|
|
|
|
|
|
my ($xd, $depotpath, $props) = @_; |
517
|
|
|
|
|
|
|
my $pool = SVN::Pool->new_default; |
518
|
|
|
|
|
|
|
my ($depot, $path) = $xd->find_depotpath($depotpath); |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
local $/ = $EOL; |
521
|
|
|
|
|
|
|
my $edit = get_editor ($depot->repospath, $path, $depot->repos); |
522
|
|
|
|
|
|
|
$edit->open_root (); |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
my %prop = %{$props}; |
525
|
|
|
|
|
|
|
for my $key (keys %prop) { |
526
|
|
|
|
|
|
|
$edit->change_dir_prop ('/', $key, $prop{$key}); |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
$edit->close_edit (); |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
sub waste_rev { |
532
|
|
|
|
|
|
|
my ($svk, $path) = @_; |
533
|
|
|
|
|
|
|
$svk->mkdir('-m', 'create', $path); |
534
|
|
|
|
|
|
|
$svk->rm('-m', 'create', $path); |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
sub tree_from_fsroot { |
538
|
|
|
|
|
|
|
# generate a hash describing a given fs root |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
sub tree_from_xdroot { |
542
|
|
|
|
|
|
|
# generate a hash describing the content in an xdroot |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
sub __ ($) { |
546
|
|
|
|
|
|
|
my $path = shift; |
547
|
|
|
|
|
|
|
$path =~ s{/}{$SEP}go; |
548
|
|
|
|
|
|
|
return $path; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
sub _x { IS_WIN32 ? 1 : -x $_[0] } |
552
|
|
|
|
|
|
|
sub not_x { IS_WIN32 ? 1 : not -x $_[0] } |
553
|
|
|
|
|
|
|
sub _l { IS_WIN32 ? 1 : -l $_[0] } |
554
|
|
|
|
|
|
|
sub not_l { IS_WIN32 ? 1 : not -l $_[0] } |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
sub uri { |
557
|
|
|
|
|
|
|
my $file = shift; |
558
|
|
|
|
|
|
|
$file =~ s{^|\\}{/}g if IS_WIN32; |
559
|
|
|
|
|
|
|
return "file://$file"; |
560
|
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
my @unlink; |
563
|
|
|
|
|
|
|
sub set_editor { |
564
|
|
|
|
|
|
|
my $tmp = File::Temp->new( SUFFIX => '.pl', UNLINK => 0 ); |
565
|
|
|
|
|
|
|
print $tmp $_[0]; |
566
|
|
|
|
|
|
|
$tmp->close; |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
my $perl = can_run($^X); |
569
|
|
|
|
|
|
|
my $tmpfile = $tmp->filename; |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
if (defined &Win32::GetShortPathName) { |
572
|
|
|
|
|
|
|
$perl = Win32::GetShortPathName($perl); |
573
|
|
|
|
|
|
|
$tmpfile = Win32::GetShortPathName($tmpfile); |
574
|
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
chmod 0755, $tmpfile; |
577
|
|
|
|
|
|
|
push @unlink, $tmpfile; |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
$ENV{SVN_EDITOR} = "$perl $tmpfile"; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
sub replace_file { |
583
|
|
|
|
|
|
|
my ($file, $from, $to) = @_; |
584
|
|
|
|
|
|
|
my @content; |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
open my $fh, '<', $file or croak "Cannot open $file: $!"; |
587
|
|
|
|
|
|
|
while (<$fh>) { |
588
|
|
|
|
|
|
|
s/$from/$to/g; |
589
|
|
|
|
|
|
|
push @content, $_; |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
close $fh; |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
open $fh, '>', $file or croak "Cannot open $file: $!"; |
594
|
|
|
|
|
|
|
print $fh @content; |
595
|
|
|
|
|
|
|
close $fh; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
# Samples of files with various MIME types |
599
|
|
|
|
|
|
|
{ |
600
|
|
|
|
|
|
|
my %samples = ( |
601
|
|
|
|
|
|
|
'empty.txt' => q{}, |
602
|
|
|
|
|
|
|
'false.bin' => 'LZ Not application/octet-stream', |
603
|
|
|
|
|
|
|
'foo.pl' => "#!/usr/bin/perl\n", |
604
|
|
|
|
|
|
|
'foo.jpg' => "\xff\xd8\xff\xe0\x00this is jpeg", |
605
|
|
|
|
|
|
|
'foo.bin' => "\x1f\xf0\xff\x01\x00\xffthis is binary", |
606
|
|
|
|
|
|
|
'foo.html' => "", |
607
|
|
|
|
|
|
|
'foo.txt' => "test....", |
608
|
|
|
|
|
|
|
'foo.c' => "/*\tHello World\t*/", |
609
|
|
|
|
|
|
|
'not-audio.txt' => "if\n", # reported: alley_cat 2006-06-02 |
610
|
|
|
|
|
|
|
); |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
# Return the names of mime sample files relative to a particular directory |
613
|
|
|
|
|
|
|
sub glob_mime_samples { |
614
|
|
|
|
|
|
|
my ($directory) = @_; |
615
|
|
|
|
|
|
|
my @names; |
616
|
|
|
|
|
|
|
push @names, "$directory/$_" for sort keys %samples; |
617
|
|
|
|
|
|
|
return @names; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
# Create a directory and fill it with files of different MIME types. |
621
|
|
|
|
|
|
|
# The directory must be specified as the first argument. |
622
|
|
|
|
|
|
|
sub create_mime_samples { |
623
|
|
|
|
|
|
|
my ($directory) = @_; |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
mkdir $directory; |
626
|
|
|
|
|
|
|
overwrite_file ("mime/not-audio.txt", "if\n"); # reported: alley_cat 2006-06-02 |
627
|
|
|
|
|
|
|
while ( my ($basename, $content) = each %samples ) { |
628
|
|
|
|
|
|
|
overwrite_file( "$directory/$basename", $content ); |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
sub chmod_probably_useless { |
634
|
|
|
|
|
|
|
return $^O eq 'MSWin32' || Cwd::cwd() =~ m!^/afs/!; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
sub install_perl_hook { |
638
|
|
|
|
|
|
|
my ($repospath, $hook, $content) = @_; |
639
|
|
|
|
|
|
|
$hook = "$repospath/hooks/$hook".(IS_WIN32 ? '.bat' : ''); |
640
|
|
|
|
|
|
|
open my $fh, '>', $hook or die $!; |
641
|
|
|
|
|
|
|
if (IS_WIN32) { |
642
|
|
|
|
|
|
|
print $fh "\@rem = '--*-Perl-*--\n"; |
643
|
|
|
|
|
|
|
print $fh '@echo off'."\n\"$^X\"".' -x -S %0 %*'."\n"; |
644
|
|
|
|
|
|
|
print $fh 'if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul'."\n"; |
645
|
|
|
|
|
|
|
print $fh "goto endofperl\n\@rem ';\n"; |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
print $fh "#!$^X\n" . $content; |
648
|
|
|
|
|
|
|
print $fh "\n__END__\n:endofperl\n" if IS_WIN32; |
649
|
|
|
|
|
|
|
chmod(0755, $hook); |
650
|
|
|
|
|
|
|
return $hook; |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
END { |
654
|
|
|
|
|
|
|
return unless $$ == $pid; |
655
|
|
|
|
|
|
|
unlink $_ for @unlink; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
1; |