line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright (C) 2007-8 Stephen Vance |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# This library is free software; you can redistribute it and/or |
4
|
|
|
|
|
|
|
# modify it under the terms of the Perl Artistic License. |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# This library is distributed in the hope that it will be useful, |
7
|
|
|
|
|
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
8
|
|
|
|
|
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Perl |
9
|
|
|
|
|
|
|
# Artistic License for more details. |
10
|
|
|
|
|
|
|
# |
11
|
|
|
|
|
|
|
# You should have received a copy of the Perl Artistic License along |
12
|
|
|
|
|
|
|
# with this library; if not, see: |
13
|
|
|
|
|
|
|
# |
14
|
|
|
|
|
|
|
# http://www.perl.com/language/misc/Artistic.html |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# Designed and written by Stephen Vance (steve@vance.com) on behalf |
17
|
|
|
|
|
|
|
# of The MathWorks, Inc. |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
package P4::Server; |
20
|
|
|
|
|
|
|
|
21
|
1
|
|
|
1
|
|
24766
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
52
|
|
22
|
1
|
|
|
1
|
|
7
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
34
|
|
23
|
|
|
|
|
|
|
|
24
|
1
|
|
|
1
|
|
558
|
use Archive::Extract; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
use Error qw( :warndie :try ); |
26
|
|
|
|
|
|
|
use Error::Exception; |
27
|
|
|
|
|
|
|
use File::Path; |
28
|
|
|
|
|
|
|
use File::Temp qw( tempdir );; |
29
|
|
|
|
|
|
|
use IO::File; |
30
|
|
|
|
|
|
|
use IO::Select; |
31
|
|
|
|
|
|
|
use IO::Socket::INET; |
32
|
|
|
|
|
|
|
use IPC::Open3; |
33
|
|
|
|
|
|
|
use IPC::Cmd qw( can_run ); |
34
|
|
|
|
|
|
|
use P4; |
35
|
|
|
|
|
|
|
use Symbol; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
use Exception::Class ( |
38
|
|
|
|
|
|
|
'P4::Server::Exception' => { |
39
|
|
|
|
|
|
|
isa => 'Error::Exception', |
40
|
|
|
|
|
|
|
description => 'Base class for P4::Server-related exceptions', |
41
|
|
|
|
|
|
|
}, |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
'P4::Server::Exception::NoJournalFile' => { |
44
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
45
|
|
|
|
|
|
|
fields => [ 'filename' ], |
46
|
|
|
|
|
|
|
description => 'Supplied journal file does not exist', |
47
|
|
|
|
|
|
|
}, |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
'P4::Server::Exception::FailedExec' => { |
50
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
51
|
|
|
|
|
|
|
fields => [ 'command', 'reason' ], |
52
|
|
|
|
|
|
|
description => 'Process exec failed', |
53
|
|
|
|
|
|
|
}, |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
'P4::Server::Exception::FailedToStart' => { |
56
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
57
|
|
|
|
|
|
|
fields => [ 'command', 'timeout' ], |
58
|
|
|
|
|
|
|
description => 'P4d did not respond to requests before the timeout', |
59
|
|
|
|
|
|
|
}, |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
'P4::Server::Exception::FailedSystem' => { |
62
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
63
|
|
|
|
|
|
|
fields => [ 'command', 'retval' ], |
64
|
|
|
|
|
|
|
description => 'Process system call failed', |
65
|
|
|
|
|
|
|
}, |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
'P4::Server::Exception::P4DQuit' => { |
68
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
69
|
|
|
|
|
|
|
description => 'P4d process quit unexpectedly after starting', |
70
|
|
|
|
|
|
|
}, |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
'P4::Server::Exception::ServerRunning' => { |
73
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
74
|
|
|
|
|
|
|
description => 'Operation not allowed while server is running', |
75
|
|
|
|
|
|
|
}, |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
'P4::Server::Exception::ServerListening' => { |
78
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
79
|
|
|
|
|
|
|
fields => [ 'port' ], |
80
|
|
|
|
|
|
|
description => 'Another server is listening on the port', |
81
|
|
|
|
|
|
|
}, |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
'P4::Server::Exception::NoArchiveFile' => { |
84
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
85
|
|
|
|
|
|
|
fields => [ 'filename' ], |
86
|
|
|
|
|
|
|
description => 'Supplied archive file does not exist', |
87
|
|
|
|
|
|
|
}, |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
'P4::Server::Exception::ArchiveError' => { |
90
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
91
|
|
|
|
|
|
|
description => 'Error using Archive::Extract', |
92
|
|
|
|
|
|
|
}, |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
'P4::Server::Exception::UndefinedRoot' => { |
95
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
96
|
|
|
|
|
|
|
description => 'The server root is not defined when needed', |
97
|
|
|
|
|
|
|
}, |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
'P4::Server::Exception::BadRoot' => { |
100
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
101
|
|
|
|
|
|
|
fields => [ 'dir' ], |
102
|
|
|
|
|
|
|
description => 'The server root directory does not exist', |
103
|
|
|
|
|
|
|
}, |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
'P4::Server::Exception::InvalidExe' => { |
106
|
|
|
|
|
|
|
isa => 'P4::Server::Exception', |
107
|
|
|
|
|
|
|
fields => [ 'role', 'exe' ], |
108
|
|
|
|
|
|
|
description => 'The executable for the role does not work as ' |
109
|
|
|
|
|
|
|
. 'expected', |
110
|
|
|
|
|
|
|
}, |
111
|
|
|
|
|
|
|
); |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
our $VERSION = '0.11'; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
use Class::Std; |
116
|
|
|
|
|
|
|
{ |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
my %p4d_exe_of : ATTR( get => 'p4d_exe' ); |
119
|
|
|
|
|
|
|
my %p4d_timeout_of : ATTR( name => 'p4d_timeout' default => 2 ); |
120
|
|
|
|
|
|
|
my %root_of : ATTR( get => 'root' ); |
121
|
|
|
|
|
|
|
my %port_of : ATTR( get => 'port' set => 'port' ); |
122
|
|
|
|
|
|
|
my %log_of : ATTR( get => 'log' set => 'log' ); |
123
|
|
|
|
|
|
|
my %journal_of : ATTR( get => 'journal' set => 'journal' ); |
124
|
|
|
|
|
|
|
my %pid_of : ATTR( get => 'pid' ); |
125
|
|
|
|
|
|
|
my %cleanup_of : ATTR( get => 'cleanup' set => 'cleanup' ); |
126
|
|
|
|
|
|
|
my $io_writer; |
127
|
|
|
|
|
|
|
my $io_reader; |
128
|
|
|
|
|
|
|
my $io_err = Symbol::gensym(); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
my $dirtemplate = File::Spec->catfile( |
131
|
|
|
|
|
|
|
File::Spec->tmpdir(), |
132
|
|
|
|
|
|
|
'p4server-root-XXXXXX', |
133
|
|
|
|
|
|
|
); |
134
|
|
|
|
|
|
|
my $journaltemplate = File::Spec->catfile( |
135
|
|
|
|
|
|
|
File::Spec->tmpdir(), |
136
|
|
|
|
|
|
|
'p4server-journal-XXXXXX', |
137
|
|
|
|
|
|
|
); |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub BUILD { |
140
|
|
|
|
|
|
|
my ($self, $ident, $arg_ref) = @_; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
$pid_of{$ident} = 0; |
143
|
|
|
|
|
|
|
$self->set_p4d_exe( $arg_ref->{p4d_exe} ); |
144
|
|
|
|
|
|
|
$port_of{$ident} = $arg_ref->{port} ? $arg_ref->{port} : '1666'; |
145
|
|
|
|
|
|
|
$self->set_root( $arg_ref->{root} ); |
146
|
|
|
|
|
|
|
$log_of{$ident} = $arg_ref->{log} ? $arg_ref->{log} : 'log'; |
147
|
|
|
|
|
|
|
$journal_of{$ident} = $arg_ref->{journal} ? $arg_ref->{journal} : 'journal'; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
$cleanup_of{$ident} = 1; |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
return; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub DEMOLISH { |
155
|
|
|
|
|
|
|
my ($self) = @_; |
156
|
|
|
|
|
|
|
my $ident = ident $self; |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# Shut down the server if necessary |
159
|
|
|
|
|
|
|
$self->stop_p4d(); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# Clean up the directory if necessary |
162
|
|
|
|
|
|
|
$self->clean_up_root(); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
return; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub set_root { |
168
|
|
|
|
|
|
|
my ($self, $root) = @_; |
169
|
|
|
|
|
|
|
my $ident = ident $self; |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
if( $pid_of{$ident} != 0 ) { |
172
|
|
|
|
|
|
|
P4::Server::Exception::ServerRunning->throw(); |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
$self->clean_up_root(); |
176
|
|
|
|
|
|
|
$root_of{$ident} = $root; |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
return; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub start_p4d { |
182
|
|
|
|
|
|
|
my ($self) = @_; |
183
|
|
|
|
|
|
|
my $ident = ident $self; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
if( $pid_of{$ident} != 0 ) { |
186
|
|
|
|
|
|
|
P4::Server::Exception::ServerRunning->throw(); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
$self->create_temp_root(); |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
my $dynamic_port = defined( $port_of{$ident} ) ? 0 : 1; |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
my $try_again = 1; |
194
|
|
|
|
|
|
|
while( $try_again ) { |
195
|
|
|
|
|
|
|
if( $dynamic_port ) { |
196
|
|
|
|
|
|
|
$self->_allocate_port(); |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
try { |
200
|
|
|
|
|
|
|
$self->_launch_p4d(); |
201
|
|
|
|
|
|
|
$try_again = 0; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
catch P4::Server::Exception::ServerListening with { |
204
|
|
|
|
|
|
|
my $e = shift; |
205
|
|
|
|
|
|
|
# We want to retry for dynamic ports. Otherwise, rethrow. |
206
|
|
|
|
|
|
|
if( ! $dynamic_port ) { |
207
|
|
|
|
|
|
|
$e->throw(); |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
}; |
210
|
|
|
|
|
|
|
# TODO: Should we catch P4DQuit here? |
211
|
|
|
|
|
|
|
# otherwise let exceptions pass |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
return; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub stop_p4d { |
218
|
|
|
|
|
|
|
my ($self) = @_; |
219
|
|
|
|
|
|
|
my $ident = ident $self; |
220
|
|
|
|
|
|
|
my $pid = $pid_of{$ident}; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
if( $pid ) { |
223
|
|
|
|
|
|
|
kill( 15, $pid ); |
224
|
|
|
|
|
|
|
waitpid( $pid, 0 ); |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
$self->_drain_output( $io_reader, $io_err ); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
$pid_of{$ident} = 0; |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
return; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
sub load_journal_file { |
235
|
|
|
|
|
|
|
my ($self, $journal) = @_; |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
-f $journal |
238
|
|
|
|
|
|
|
or P4::Server::Exception::NoJournalFile->throw( |
239
|
|
|
|
|
|
|
filename => $journal |
240
|
|
|
|
|
|
|
); |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
my $ident = ident $self; |
243
|
|
|
|
|
|
|
my @args = ( |
244
|
|
|
|
|
|
|
$p4d_exe_of{$ident}, |
245
|
|
|
|
|
|
|
'-r', $root_of{$ident}, |
246
|
|
|
|
|
|
|
'-jr', $journal, |
247
|
|
|
|
|
|
|
); |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
my $journal_writer; |
250
|
|
|
|
|
|
|
my $journal_reader; |
251
|
|
|
|
|
|
|
my $journal_err = Symbol::gensym(); |
252
|
|
|
|
|
|
|
my $pid = open3( $journal_writer, $journal_reader, $journal_err, @args ); |
253
|
|
|
|
|
|
|
waitpid( $pid, 0 ); |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
$self->_drain_output( $journal_reader, $journal_err ); |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
return; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub load_journal_string { |
261
|
|
|
|
|
|
|
my ($self, $contents) = @_; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
my $fh = File::Temp->new( TEMPLATE => $journaltemplate );; |
264
|
|
|
|
|
|
|
my $journal = $fh->filename; |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
print $fh $contents; |
267
|
|
|
|
|
|
|
close $fh; |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
$self->load_journal_file( $journal ); |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
return; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
sub create_temp_root { |
275
|
|
|
|
|
|
|
my ($self) = @_; |
276
|
|
|
|
|
|
|
my $ident = ident $self; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
return if( defined( $root_of{$ident} ) ); |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
my $name = tempdir( $dirtemplate, CLEANUP => $cleanup_of{$ident} ); |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
$root_of{ident $self} = $name; |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
return; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub clean_up_root { |
288
|
|
|
|
|
|
|
my ($self) = @_; |
289
|
|
|
|
|
|
|
my $ident = ident $self; |
290
|
|
|
|
|
|
|
my $root = $root_of{$ident}; |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
if( $pid_of{$ident} != 0 ) { |
293
|
|
|
|
|
|
|
P4::Server::Exception::ServerRunning->throw(); |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# Clean up the directory if necessary |
297
|
|
|
|
|
|
|
if( $cleanup_of{$ident} |
298
|
|
|
|
|
|
|
&& defined( $root ) |
299
|
|
|
|
|
|
|
&& -d $root ) { |
300
|
|
|
|
|
|
|
rmtree( $root ); |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
sub set_p4d_exe { |
305
|
|
|
|
|
|
|
my ($self, $exe) = @_; |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
if( ! defined( $exe ) ) { |
308
|
|
|
|
|
|
|
$exe = 'p4d'; |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
if( ! $self->_is_exe_valid( $exe ) ) { |
312
|
|
|
|
|
|
|
P4::Server::Exception::InvalidExe->throw( |
313
|
|
|
|
|
|
|
role => 'p4d', |
314
|
|
|
|
|
|
|
exe => $exe, |
315
|
|
|
|
|
|
|
); |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
$p4d_exe_of{ident $self} = $exe; |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
return; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
sub unpack_archive_to_root_dir { |
324
|
|
|
|
|
|
|
my ($self, $archive) = @_; |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
if( ! -f $archive || ! -r $archive ) { |
327
|
|
|
|
|
|
|
P4::Server::Exception::NoArchiveFile->throw( filename => $archive ); |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
my $root = $self->get_root(); |
331
|
|
|
|
|
|
|
if( ! defined( $root ) ) { |
332
|
|
|
|
|
|
|
P4::Server::Exception::UndefinedRoot->throw(); |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
if( ! -d $root ) { |
336
|
|
|
|
|
|
|
P4::Server::Exception::BadRoot->throw( dir => $root ); |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
my ($result, $error, $files) = $self->_extract_archive( $archive, $root ); |
340
|
|
|
|
|
|
|
# TODO: This is untestable as I have not figured out how to make gunzip or |
341
|
|
|
|
|
|
|
# tar generate an error return. |
342
|
|
|
|
|
|
|
if( ! $result ) { |
343
|
|
|
|
|
|
|
P4::Server::Exception::ArchiveError->throw( |
344
|
|
|
|
|
|
|
error => $error, |
345
|
|
|
|
|
|
|
); |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
return $files; |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
# PRIVATE METHODS |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# To be overridden for test failure injection |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
sub _system { |
356
|
|
|
|
|
|
|
my ($self, @args) = @_; |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
return system( @args ); |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub _is_exe_valid : RESTRICTED { |
362
|
|
|
|
|
|
|
my ($self, $exe) = @_; |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
return defined( can_run( $exe ) ) ? 1 : 0; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
sub _extract_archive : RESTRICTED { |
368
|
|
|
|
|
|
|
my ($self, $archive, $outdir) = @_; |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
local $Archive::Extract::WARN = 0; |
371
|
|
|
|
|
|
|
my $extractor = Archive::Extract->new( archive => $archive ); |
372
|
|
|
|
|
|
|
my $result = $extractor->extract( to => $outdir ); |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
return ($result, $extractor->error(), $extractor->files() ); |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
sub _is_p4d_listening_on : PRIVATE { |
378
|
|
|
|
|
|
|
my ($self, $port) = @_; |
379
|
|
|
|
|
|
|
my $ident = ident $self; |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
my $p4 = P4->new(); |
382
|
|
|
|
|
|
|
$p4->ParseForms(); |
383
|
|
|
|
|
|
|
$p4->Tagged(); |
384
|
|
|
|
|
|
|
$p4->SetPort( $port ); |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# Nothing's listening if we can't connect |
387
|
|
|
|
|
|
|
if( ! $p4->Connect() ) { |
388
|
|
|
|
|
|
|
return 0; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
my @results = $p4->Info(); |
392
|
|
|
|
|
|
|
return ! $p4->ErrorCount(); |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub _spawn_p4d : PROTECTED { |
396
|
|
|
|
|
|
|
my ($self, @args ) = @_; |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
return open3( $io_writer, $io_reader, $io_err, @args ); |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
sub _drain_output : PRIVATE { |
402
|
|
|
|
|
|
|
my ($self, @handles) = @_; |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
my $sel = IO::Select->new( @handles ); |
405
|
|
|
|
|
|
|
my @ready; |
406
|
|
|
|
|
|
|
while( @ready = $sel->can_read( 30 ) ) { |
407
|
|
|
|
|
|
|
for my $fh ( @ready ) { |
408
|
|
|
|
|
|
|
my $buffer; |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# Read length is a magic number but is well more than any 'p4 |
411
|
|
|
|
|
|
|
# info' returns. |
412
|
|
|
|
|
|
|
my $bytes_read = read( $fh, $buffer, 2048 ); |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
if( $bytes_read == 0 ) { |
415
|
|
|
|
|
|
|
$sel->remove( $fh ); |
416
|
|
|
|
|
|
|
close( $fh ); |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
close( $io_writer ); |
422
|
|
|
|
|
|
|
close( $io_reader ); |
423
|
|
|
|
|
|
|
close( $io_err ); |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
sub _launch_p4d : PRIVATE { |
427
|
|
|
|
|
|
|
my ($self) = @_; |
428
|
|
|
|
|
|
|
my $ident = ident $self; |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
my $port = $port_of{$ident}; |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
if( $self->_is_p4d_listening_on( $port ) ) { |
433
|
|
|
|
|
|
|
P4::Server::Exception::ServerListening->throw( |
434
|
|
|
|
|
|
|
port => $port, |
435
|
|
|
|
|
|
|
); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# TODO: Do we check here for the validity of the args? |
439
|
|
|
|
|
|
|
# TODO: Do we check here for the existence of the root? |
440
|
|
|
|
|
|
|
my @args = ( |
441
|
|
|
|
|
|
|
$p4d_exe_of{$ident}, |
442
|
|
|
|
|
|
|
'-q', |
443
|
|
|
|
|
|
|
'-r', $root_of{$ident}, |
444
|
|
|
|
|
|
|
'-p', $port, |
445
|
|
|
|
|
|
|
'-L', $log_of{$ident}, |
446
|
|
|
|
|
|
|
'-J', $journal_of{$ident}, |
447
|
|
|
|
|
|
|
); |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
my $pid; |
450
|
|
|
|
|
|
|
my $process_quit = 0; |
451
|
|
|
|
|
|
|
local $SIG{CHLD} = sub { $process_quit = 1; return; }; |
452
|
|
|
|
|
|
|
try { |
453
|
|
|
|
|
|
|
$pid = $self->_spawn_p4d( @args ); |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
otherwise { |
456
|
|
|
|
|
|
|
my $e = shift; |
457
|
|
|
|
|
|
|
P4::Server::Exception::FailedExec->throw( |
458
|
|
|
|
|
|
|
command => join( ' ', @args ), |
459
|
|
|
|
|
|
|
reason => $e, |
460
|
|
|
|
|
|
|
); |
461
|
|
|
|
|
|
|
}; |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
$pid_of{$ident} = $pid; |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
my $timeout = $self->get_p4d_timeout(); |
466
|
|
|
|
|
|
|
my $start_time = time(); |
467
|
|
|
|
|
|
|
while( ! $process_quit ) { |
468
|
|
|
|
|
|
|
if( $self->_is_p4d_listening_on( $port ) ) { |
469
|
|
|
|
|
|
|
last; |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
if( time() - $start_time > $timeout ) { |
473
|
|
|
|
|
|
|
P4::Server::Exception::FailedToStart->throw( |
474
|
|
|
|
|
|
|
command => join( ' ', @args ), |
475
|
|
|
|
|
|
|
timeout => $timeout, |
476
|
|
|
|
|
|
|
); |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
} |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
if( $process_quit ) { |
481
|
|
|
|
|
|
|
P4::Server::Exception::P4DQuit->throw(); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
return; |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
# This is restricted so it can be overridden for test failure injection. |
488
|
|
|
|
|
|
|
sub _allocate_port : RESTRICTED { |
489
|
|
|
|
|
|
|
my ($self) = @_; |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# TODO: Is there a failure to test here? |
492
|
|
|
|
|
|
|
my $socket = IO::Socket::INET->new( |
493
|
|
|
|
|
|
|
Proto => 'tcp', |
494
|
|
|
|
|
|
|
ReuseAddr => 1, |
495
|
|
|
|
|
|
|
Listen => 5, # Number doesn't matter, but presence does |
496
|
|
|
|
|
|
|
LocalAddr => 'localhost', |
497
|
|
|
|
|
|
|
); |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
$port_of{ident $self} = $socket->sockport(); |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
close( $socket ); |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
return; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
} |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
1; |
509
|
|
|
|
|
|
|
__END__ |