Filename | /home/ocbnet/domain/ocbnet.ch/vhost/webmerge/htdocs/webmerge/scripts/modules/Fork/Queue.pm |
Statements | Executed 7 statements in 3.48ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 14.9ms | 69.6ms | BEGIN@8 | Fork::Queue::
1 | 1 | 1 | 84µs | 183µs | BEGIN@5 | Fork::Queue::
1 | 1 | 1 | 68µs | 100µs | BEGIN@6 | Fork::Queue::
0 | 0 | 0 | 0s | 0s | can_dequeue | Fork::Queue::
0 | 0 | 0 | 0s | 0s | dequeue | Fork::Queue::
0 | 0 | 0 | 0s | 0s | enqueue | Fork::Queue::
0 | 0 | 0 | 0s | 0s | mksockpair | Fork::Queue::
0 | 0 | 0 | 0s | 0s | new | Fork::Queue::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # from http://www.perlmonks.org/?node_id=49335 | ||||
2 | # 26.06.2012 added can_dequeue function (mgr@rtp.ch) | ||||
3 | package Fork::Queue; | ||||
4 | |||||
5 | 2 | 148µs | 2 | 281µs | # spent 183µs (84+98) within Fork::Queue::BEGIN@5 which was called:
# once (84µs+98µs) by RTP::Webmerge::Watchdog::BEGIN@30 at line 5 # spent 183µs making 1 call to Fork::Queue::BEGIN@5
# spent 98µs making 1 call to strict::import |
6 | 2 | 138µs | 2 | 131µs | # spent 100µs (68+31) within Fork::Queue::BEGIN@6 which was called:
# once (68µs+31µs) by RTP::Webmerge::Watchdog::BEGIN@30 at line 6 # spent 100µs making 1 call to Fork::Queue::BEGIN@6
# spent 32µs making 1 call to warnings::import |
7 | |||||
8 | 2 | 3.18ms | 2 | 107ms | # spent 69.6ms (14.9+54.7) within Fork::Queue::BEGIN@8 which was called:
# once (14.9ms+54.7ms) by RTP::Webmerge::Watchdog::BEGIN@30 at line 8 # spent 69.6ms making 1 call to Fork::Queue::BEGIN@8
# spent 36.9ms making 1 call to Exporter::import |
9 | |||||
10 | sub new { | ||||
11 | my($this) = @_; | ||||
12 | my $class = ref($this) || $this; | ||||
13 | my $self = {}; | ||||
14 | bless $self, $class; | ||||
15 | $self->mksockpair(); | ||||
16 | return $self; | ||||
17 | } | ||||
18 | # make the socketpair | ||||
19 | sub mksockpair { | ||||
20 | my($self)=@_; | ||||
21 | socketpair(my $reader, my $writer, AF_UNIX, SOCK_STREAM, PF_UNSPEC); | ||||
22 | if ($^O ne "MSWin32") | ||||
23 | { | ||||
24 | shutdown($reader,1); | ||||
25 | shutdown($writer,0); | ||||
26 | } | ||||
27 | $self->{'READER'}=$reader; | ||||
28 | $self->{'WRITER'}=$writer; | ||||
29 | } | ||||
30 | # method to put something on the queue | ||||
31 | sub enqueue { | ||||
32 | my($self,@data)=@_; | ||||
33 | my($header,$buffer,$tosend); | ||||
34 | my($handle)=$self->{'WRITER'}; | ||||
35 | foreach my $item (@data) { | ||||
36 | $header=pack("N",length($item)); | ||||
37 | $buffer=$header . $item; | ||||
38 | $tosend=length($buffer); | ||||
39 | my $rv = print $handle $buffer; | ||||
40 | die "write error : $!" unless defined $rv; | ||||
41 | die "write disconnected" if $rv eq 0; | ||||
42 | $handle->flush; | ||||
43 | } | ||||
44 | } | ||||
45 | # | ||||
46 | # method to pull something off the queue | ||||
47 | # | ||||
48 | sub dequeue { | ||||
49 | my($self)=@_; | ||||
50 | my($header,$data); | ||||
51 | my($toread)=4; | ||||
52 | my($bytes_read)=0; | ||||
53 | my($handle)=$self->{'READER'}; | ||||
54 | # read 4 byte header | ||||
55 | while ($bytes_read < $toread) { | ||||
56 | my $rv=read($handle,$header,$toread); | ||||
57 | die "read error : $!" unless defined $rv; | ||||
58 | die "read disconnected" if $rv eq 0; | ||||
59 | $bytes_read+=$rv; | ||||
60 | } | ||||
61 | $toread=unpack("N",$header); | ||||
62 | $bytes_read=0; | ||||
63 | # read the actual data | ||||
64 | while ($bytes_read < $toread) { | ||||
65 | my $rv=read($handle,$data,$toread,0); | ||||
66 | die "read error : $!" unless defined $rv; | ||||
67 | die "read disconnected" if $rv eq 0; | ||||
68 | $bytes_read+=$rv; | ||||
69 | } | ||||
70 | return $data; | ||||
71 | } | ||||
72 | # | ||||
73 | # method to check if something can be dequeued | ||||
74 | # | ||||
75 | sub can_dequeue { | ||||
76 | my($self,$timeout)=@_; | ||||
77 | my($handle)=$self->{'READER'}; | ||||
78 | if (defined(my $fileno = $handle->fileno())) { | ||||
79 | vec(my $rbit = '', $fileno, 1) = 1; # enable fd in vector table | ||||
80 | vec(my $ebit = '', $fileno, 1) = 1; # enable fd in vector table | ||||
81 | my $rv = select($rbit, undef, $ebit, $timeout); # select for readable handles | ||||
82 | die "can dequeue errors" if vec($ebit, $fileno, 1); | ||||
83 | return vec($rbit, $fileno, 1); # check fd in vector table | ||||
84 | } else { return undef; } | ||||
85 | # my($io) = IO::Select->new($handle); | ||||
86 | # return $io->can_read($timeout); | ||||
87 | } | ||||
88 | 1 | 14µs | 1; | ||
89 | # | ||||
90 | # |