Profile of webmerge/scripts/modules/Fork/Queue.pm

Filename	/home/ocbnet/domain/ocbnet.ch/vhost/webmerge/htdocs/webmerge/scripts/modules/Fork/Queue.pm
Statements	Executed 7 statements in 3.48ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	14.9ms	69.6ms	Fork::Queue::::BEGIN@8Fork::Queue::BEGIN@8
1	1	1	84µs	183µs	Fork::Queue::::BEGIN@5Fork::Queue::BEGIN@5
1	1	1	68µs	100µs	Fork::Queue::::BEGIN@6Fork::Queue::BEGIN@6
0	0	0	0s	0s	Fork::Queue::::can_dequeueFork::Queue::can_dequeue
0	0	0	0s	0s	Fork::Queue::::dequeueFork::Queue::dequeue
0	0	0	0s	0s	Fork::Queue::::enqueueFork::Queue::enqueue
0	0	0	0s	0s	Fork::Queue::::mksockpairFork::Queue::mksockpair
0	0	0	0s	0s	Fork::Queue::::newFork::Queue::new

Call graph for these subroutines as a Graphviz dot language file.

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 use strict; # 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 use warnings; # 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 use Socket; # 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					#