File Coverage

blib/lib/MogileFS/Util.pm
Criterion Covered Total %
statement 41 172 23.8
branch 5 66 7.5
condition 0 6 0.0
subroutine 9 29 31.0
pod 0 22 0.0
total 55 295 18.6


line stmt bran cond sub pod time code
1             package MogileFS::Util;
2 22     22   54069 use strict;
  22         42  
  22         572  
3 22     22   94 use Carp qw(croak);
  22         38  
  22         765  
4 22     22   873 use Time::HiRes;
  22         2121  
  22         98  
5 22     22   8139 use MogileFS::Exception;
  22         47  
  22         618  
6 22     22   6791 use MogileFS::DeviceState;
  22         46  
  22         37455  
7              
8             require Exporter;
9             our @ISA = qw(Exporter);
10             our @EXPORT_OK = qw(
11             error undeferr debug fatal daemonize weighted_list every
12             wait_for_readability wait_for_writeability throw error_code
13             max min first okay_args device_state eurl decode_url_args
14             encode_url_args apply_state_events apply_state_events_list
15             );
16              
17             # Applies monitor-job-supplied state events against the factory singletons.
18             # Sad this couldn't be an object method, but ProcManager doesn't base off
19             # anything common.
20             sub apply_state_events {
21 0     0 0 0 my @events = split(/\s/, ${$_[0]});
  0         0  
22 0         0 shift @events; # pop the :monitor_events part
23 0         0 apply_state_events_list(@events);
24             }
25              
26             sub apply_state_events_list {
27             # This will needlessly fetch domain/class/host most of the time.
28             # Maybe replace with something that "caches" factories?
29 0     0 0 0 my %factories = ( 'domain' => MogileFS::Factory::Domain->get_factory,
30             'class' => MogileFS::Factory::Class->get_factory,
31             'host' => MogileFS::Factory::Host->get_factory,
32             'device' => MogileFS::Factory::Device->get_factory, );
33              
34 0         0 for my $ev (@_) {
35 0         0 my $args = decode_url_args($ev);
36 0         0 my $mode = delete $args->{ev_mode};
37 0         0 my $type = delete $args->{ev_type};
38 0         0 my $id = delete $args->{ev_id};
39              
40             # This special case feels gross, but that's what it is.
41 0 0       0 if ($type eq 'srvset') {
42 0 0       0 my $val = $mode eq 'set' ? $args->{value} : undef;
43 0         0 MogileFS::Config->cache_server_setting($id, $val);
44 0         0 next;
45             }
46              
47 0         0 my $old = $factories{$type}->get_by_id($id);
48 0 0       0 if ($mode eq 'setstate') {
    0          
    0          
49             # Host/Device only.
50             # FIXME: Make objects slightly mutable and directly set fields?
51 0         0 $factories{$type}->set({ %{$old->fields}, %$args });
  0         0  
52             } elsif ($mode eq 'set') {
53             # Re-add any observed data.
54 0 0       0 my $observed = $old ? $old->observed_fields : {};
55 0         0 $factories{$type}->set({ %$args, %$observed });
56             } elsif ($mode eq 'remove') {
57 0 0       0 $factories{$type}->remove($old) if $old;
58             }
59             }
60             }
61              
62             sub every {
63 0     0 0 0 my ($delay, $code) = @_;
64 0         0 my ($worker, $psock_fd);
65 0 0       0 if ($worker = MogileFS::ProcManager->is_child) {
66 0         0 $psock_fd = $worker->psock_fd;
67             }
68             CODERUN:
69 0         0 while (1) {
70 0         0 my $start = Time::HiRes::time();
71 0         0 my $explicit_sleep = undef;
72              
73             # run the code in a loop, so "next" will get out of it.
74 0         0 foreach (1) {
75             $code->(sub {
76 0     0   0 $explicit_sleep = shift;
77 0         0 });
78             }
79              
80 0         0 my $now = Time::HiRes::time();
81 0         0 my $took = $now - $start;
82 0 0       0 my $sleep_for = defined $explicit_sleep ? $explicit_sleep : ($delay - $took);
83              
84             # simple case, not in a child process (this never happens currently)
85 0 0       0 unless ($psock_fd) {
86 0         0 Time::HiRes::sleep($sleep_for);
87 0         0 next;
88             }
89              
90 0 0       0 Time::HiRes::sleep($sleep_for) if $sleep_for > 0;
91             #local $Mgd::POST_SLEEP_DEBUG = 1;
92             # This calls read_from_parent. Workers used to needlessly call
93             # parent_ping constantly.
94 0         0 $worker->parent_ping;
95             }
96             }
97              
98             sub debug {
99 0     0 0 0 my ($msg, $level) = @_;
100 0 0       0 return unless $Mgd::DEBUG >= 1;
101 0         0 $msg =~ s/[\r\n]+//g;
102 0 0       0 if (my $worker = MogileFS::ProcManager->is_child) {
103 0         0 $worker->send_to_parent("debug $msg");
104             } else {
105 0         0 my $dbg = "[debug] $msg";
106 0         0 MogileFS::ProcManager->NoteError(\$dbg);
107 0         0 Mgd::log('debug', $msg);
108             }
109             }
110              
111             our $last_error;
112             sub error {
113 4     4 0 18 my ($errmsg) = @_;
114 4         21 $last_error = $errmsg;
115 4 50       133 if (my $worker = MogileFS::ProcManager->is_child) {
116 0         0 my $msg = "error $errmsg";
117 0         0 $msg =~ s/\s+$//;
118 0         0 $worker->send_to_parent($msg);
119             } else {
120 4         87 MogileFS::ProcManager->NoteError(\$errmsg);
121 4         70 Mgd::log('debug', $errmsg);
122             }
123 4         20 return 0;
124             }
125              
126             # like error(), but returns undef.
127             sub undeferr {
128 0     0 0 0 error(@_);
129 0         0 return undef;
130             }
131              
132             sub last_error {
133 0     0 0 0 return $last_error;
134             }
135              
136             sub fatal {
137 0     0 0 0 my ($errmsg) = @_;
138 0         0 error($errmsg);
139 0         0 die $errmsg;
140             }
141              
142             sub throw {
143 0     0 0 0 my ($errcode) = @_;
144 0         0 MogileFS::Exception->new($errcode)->throw;
145             }
146              
147             sub error_code {
148 0     0 0 0 my ($ex) = @_;
149 0 0       0 return "" unless UNIVERSAL::isa($ex, "MogileFS::Exception");
150 0         0 return $ex->code;
151             }
152              
153             sub daemonize {
154 0     0 0 0 my($pid, $sess_id, $i);
155              
156             ## Fork and exit parent
157 0 0       0 if ($pid = fork) { exit 0; }
  0         0  
158              
159             ## Detach ourselves from the terminal
160 0 0       0 croak "Cannot detach from controlling terminal"
161             unless $sess_id = POSIX::setsid();
162              
163             ## Prevent possibility of acquiring a controlling terminal
164 0         0 $SIG{'HUP'} = 'IGNORE';
165 0 0       0 if ($pid = fork) { exit 0; }
  0         0  
166              
167             ## Change working directory
168 0         0 chdir "/";
169              
170             ## Clear file creation mask
171 0         0 umask 0;
172              
173 0 0       0 print STDERR "Daemon running as pid $$.\n" if $MogileFS::DEBUG;
174              
175             ## Close open file descriptors
176 0         0 close(STDIN);
177 0         0 close(STDOUT);
178 0         0 close(STDERR);
179              
180             ## Reopen STDERR, STDOUT, STDIN to /dev/null
181 0 0       0 if ( $MogileFS::DEBUG ) {
182 0         0 open(STDIN, "+>/tmp/mogilefsd.log");
183             } else {
184 0         0 open(STDIN, "+>/dev/null");
185             }
186 0         0 open(STDOUT, "+>&STDIN");
187 0         0 open(STDERR, "+>&STDIN");
188             }
189              
190             # input:
191             # given an array of arrayrefs of [ item, weight ], returns weighted randomized
192             # list of items (without the weights, not arrayref; just list)
193             #
194             # a weight of 0 means to exclude that item from the results list; i.e. it's not
195             # ever used
196             #
197             # example:
198             # my @items = weighted_list( [ 1, 10 ], [ 2, 20 ], [ 3, 0 ] );
199             #
200             # returns (1, 2) or (2, 1) with the latter far more likely
201             sub weighted_list (@) {
202 130     130 0 512 my @list = grep { $_->[1] > 0 } @_;
  252         439  
203 130         139 my @ret;
204              
205 130         140 my $sum = 0;
206 130         221 $sum += $_->[1] foreach @list;
207              
208             my $getone = sub {
209 252 100   252   447 return shift(@list)->[0]
210             if scalar(@list) == 1;
211              
212 129         315 my $val = rand() * $sum;
213 129         139 my $curval = 0;
214 129         253 for (my $idx = 0; $idx < scalar(@list); $idx++) {
215 223         243 my $item = $list[$idx];
216 223         237 $curval += $item->[1];
217 223 100       377 if ($curval >= $val) {
218 129         191 my ($ret) = splice(@list, $idx, 1);
219 129         161 $sum -= $item->[1];
220 129         348 return $ret->[0];
221             }
222             }
223 130         342 };
224              
225 130         266 push @ret, $getone->() while @list;
226 130         427 return @ret;
227             }
228              
229             # given a file descriptor number and a timeout, wait for that descriptor to
230             # become readable; returns 0 or 1 on if it did or not
231             sub wait_for_readability {
232 0     0 0 0 my ($fileno, $timeout) = @_;
233 0 0 0     0 return 0 unless $fileno && $timeout >= 0;
234              
235 0         0 my $rin = '';
236 0         0 vec($rin, $fileno, 1) = 1;
237 0         0 my $nfound = select($rin, undef, undef, $timeout);
238              
239             # nfound can be undef or 0, both failures, or 1, a success
240 0 0       0 return $nfound ? 1 : 0;
241             }
242              
243             sub wait_for_writeability {
244 0     0 0 0 my ($fileno, $timeout) = @_;
245 0 0 0     0 return 0 unless $fileno && $timeout;
246              
247 0         0 my $rout = '';
248 0         0 vec($rout, $fileno, 1) = 1;
249 0         0 my $nfound = select(undef, $rout, undef, $timeout);
250              
251             # nfound can be undef or 0, both failures, or 1, a success
252 0 0       0 return $nfound ? 1 : 0;
253             }
254              
255             sub max {
256 0     0 0 0 my ($n1, $n2) = @_;
257 0 0       0 return $n1 if $n1 > $n2;
258 0         0 return $n2;
259             }
260              
261             sub min {
262 0     0 0 0 my ($n1, $n2) = @_;
263 0 0       0 return $n1 if $n1 < $n2;
264 0         0 return $n2;
265             }
266              
267             sub first (&@) {
268 0     0 0 0 my $code = shift;
269 0         0 foreach (@_) {
270 0 0       0 return $_ if $code->();
271             }
272 0         0 undef;
273             }
274              
275             sub okay_args {
276 0     0 0 0 my ($href, @okay) = @_;
277 0         0 my %left = %$href;
278 0         0 delete $left{$_} foreach @okay;
279 0 0       0 return 1 unless %left;
280 0         0 Carp::croak("Unknown argument(s): " . join(", ", sort keys %left));
281             }
282              
283             sub device_state {
284 278     278 0 369 my ($state) = @_;
285 278         475 return MogileFS::DeviceState->of_string($state);
286             }
287              
288             sub eurl {
289 0 0   0 0   my $a = defined $_[0] ? $_[0] : "";
290 0           $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
  0            
291 0           $a =~ tr/ /+/;
292 0           return $a;
293             }
294              
295             sub encode_url_args {
296 0     0 0   my $args = shift;
297 0           return join('&', map { eurl($_) . "=" . eurl($args->{$_}) } keys %$args);
  0            
298             }
299              
300             sub decode_url_args {
301 0     0 0   my $a = shift;
302 0 0         my $buffer = ref $a ? $a : \$a;
303 0           my $ret = {};
304              
305 0           my $pair;
306 0           my @pairs = grep { $_ } split(/&/, $$buffer);
  0            
307 0           my ($name, $value);
308 0           foreach $pair (@pairs)
309             {
310 0           ($name, $value) = split(/=/, $pair);
311 0           $value =~ tr/+/ /;
312 0           $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  0            
313 0           $name =~ tr/+/ /;
314 0           $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  0            
315 0 0         $ret->{$name} .= $ret->{$name} ? "\0$value" : $value;
316             }
317 0           return $ret;
318             }
319              
320             1;