← Index
NYTProf Performance Profile   « line view »
For webmerge/scripts/webmerge.pl
  Run on Mon Oct 7 02:42:42 2013
Reported on Mon Oct 7 03:03:23 2013

Filename/home/ocbnet/domain/ocbnet.ch/vhost/webmerge/htdocs/webmerge/scripts/modules/Fork/Queue.pm
StatementsExecuted 7 statements in 3.48ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11114.9ms69.6msFork::Queue::::BEGIN@8Fork::Queue::BEGIN@8
11184µs183µsFork::Queue::::BEGIN@5Fork::Queue::BEGIN@5
11168µs100µsFork::Queue::::BEGIN@6Fork::Queue::BEGIN@6
0000s0sFork::Queue::::can_dequeueFork::Queue::can_dequeue
0000s0sFork::Queue::::dequeueFork::Queue::dequeue
0000s0sFork::Queue::::enqueueFork::Queue::enqueue
0000s0sFork::Queue::::mksockpairFork::Queue::mksockpair
0000s0sFork::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)
3package Fork::Queue;
4
52148µs2281µ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
62138µs2131µ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
823.18ms2107ms
# 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
10sub 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
19sub 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
31sub 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#
48sub 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#
75sub 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}
88114µs1;
89#
90#