Profile of lib/Tapper/MCP/Net/TAP.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:23:52 2012

Filename | /2home/ss5/local/projects/Tapper/src/Tapper-MCP/lib/Tapper/MCP/Net/TAP.pm
Statements | Executed 17 statements in 1.05ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 94µs | 149µs | Tapper::MCP::Net::TAP::::BEGIN@3Tapper::MCP::Net::TAP::BEGIN@3
1 | 1 | 1 | 11µs | 55µs | Tapper::MCP::Net::TAP::::BEGIN@3.13Tapper::MCP::Net::TAP::BEGIN@3.13
1 | 1 | 1 | 11µs | 2.97ms | Tapper::MCP::Net::TAP::::BEGIN@7Tapper::MCP::Net::TAP::BEGIN@7
1 | 1 | 1 | 10µs | 26µs | Tapper::MCP::Net::TAP::::BEGIN@5Tapper::MCP::Net::TAP::BEGIN@5
1 | 1 | 1 | 8µs | 13µs | Tapper::MCP::Net::TAP::::BEGIN@4Tapper::MCP::Net::TAP::BEGIN@4
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::__ANON__[lib/Tapper/MCP/Net/TAP.pm:58]Tapper::MCP::Net::TAP::__ANON__[lib/Tapper/MCP/Net/TAP.pm:58]
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::associated_hostnameTapper::MCP::Net::TAP::associated_hostname
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::mcp_headerlinesTapper::MCP::Net::TAP::mcp_headerlines
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::prc_headerlinesTapper::MCP::Net::TAP::prc_headerlines
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::tap_report_awayTapper::MCP::Net::TAP::tap_report_away
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::tap_report_createTapper::MCP::Net::TAP::tap_report_create
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::tap_report_sendTapper::MCP::Net::TAP::tap_report_send
0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::::upload_filesTapper::MCP::Net::TAP::upload_files

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

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Tapper::MCP::Net::TAP;
2 |  |  |  |  |
3 | 6 | 99µs | 3 | 248µs | # spent 55µs (11+44) within Tapper::MCP::Net::TAP::BEGIN@3.13 which was called: # once (11µs+44µs) by Tapper::MCP::Net::TAP::BEGIN@3 at line 3 # spent 149µs (94+55) within Tapper::MCP::Net::TAP::BEGIN@3 which was called: # once (94µs+55µs) by Module::Runtime::require_module at line 3 use 5.010; # spent 149µs making 1 call to Tapper::MCP::Net::TAP::BEGIN@3 # spent 55µs making 1 call to Tapper::MCP::Net::TAP::BEGIN@3.13 # spent 44µs making 1 call to feature::import
4 | 3 | 19µs | 2 | 17µs | # spent 13µs (8+4) within Tapper::MCP::Net::TAP::BEGIN@4 which was called: # once (8µs+4µs) by Module::Runtime::require_module at line 4 use strict; # spent 13µs making 1 call to Tapper::MCP::Net::TAP::BEGIN@4 # spent 4µs making 1 call to strict::import
5 | 3 | 19µs | 2 | 42µs | # spent 26µs (10+16) within Tapper::MCP::Net::TAP::BEGIN@5 which was called: # once (10µs+16µs) by Module::Runtime::require_module at line 5 use warnings; # spent 26µs making 1 call to Tapper::MCP::Net::TAP::BEGIN@5 # spent 16µs making 1 call to warnings::import
6 |  |  |  |  |
7 | 3 | 907µs | 2 | 5.92ms | # spent 2.97ms (11µs+2.96) within Tapper::MCP::Net::TAP::BEGIN@7 which was called: # once (11µs+2.96ms) by Module::Runtime::require_module at line 7 use Moose::Role; # spent 2.97ms making 1 call to Tapper::MCP::Net::TAP::BEGIN@7 # spent 2.96ms making 1 call to Moose::Exporter::__ANON__[Moose/Exporter.pm:492]
8 |  |  |  |  |
9 | 1 | 2µs | 1 | 218µs | requires 'testrun', 'cfg', 'log'; # spent 218µs making 1 call to Moose::Role::requires
10 |  |  |  |  |
11 |  |  |  |  | =head2 prc_headerlines
12 |  |  |  |  |
13 |  |  |  |  | Generate header lines for the TAP report containing the results of the
14 |  |  |  |  | PRC with the number provided as argument.
15 |  |  |  |  |
16 |  |  |  |  | =cut
17 |  |  |  |  |
18 |  |  |  |  | sub prc_headerlines {
19 |  |  |  |  | my ($self, $prc_number) = @_;
20 |  |  |  |  |
21 |  |  |  |  | my $hostname = $self->associated_hostname;
22 |  |  |  |  |
23 |  |  |  |  | my $testrun_id = $self->testrun->id;
24 |  |  |  |  | my $suitename = ($prc_number > 0) ? "Guest-Overview-$prc_number" : "PRC0-Overview";
25 |  |  |  |  |
26 |  |  |  |  | my $headerlines = [
27 |  |  |  |  | "# Tapper-reportgroup-testrun: $testrun_id",
28 |  |  |  |  | "# Tapper-suite-name: $suitename",
29 |  |  |  |  | "# Tapper-suite-version: $Tapper::MCP::VERSION",
30 |  |  |  |  | "# Tapper-machine-name: $hostname",
31 |  |  |  |  | "# Tapper-section: prc-state-details",
32 |  |  |  |  | "# Tapper-reportgroup-primary: 0",
33 |  |  |  |  | ];
34 |  |  |  |  | return $headerlines;
35 |  |  |  |  | }
36 |  |  |  |  |
37 |  |  |  |  |
38 |  |  |  |  | =head2 tap_report_away
39 |  |  |  |  |
40 |  |  |  |  | Actually send the tap report to receiver.
41 |  |  |  |  |
42 |  |  |  |  | @param string - report to be sent
43 |  |  |  |  |
44 |  |  |  |  | @return success - (0, report id)
45 |  |  |  |  | @return error - (1, error string)
46 |  |  |  |  |
47 |  |  |  |  | =cut
48 |  |  |  |  |
49 |  |  |  |  | sub tap_report_away
50 |  |  |  |  | {
51 |  |  |  |  | my ($self, $tap) = @_;
52 |  |  |  |  | my $reportid;
53 |  |  |  |  | if (my $sock = IO::Socket::INET->new(PeerAddr => $self->cfg->{report_server},
54 |  |  |  |  | PeerPort => $self->cfg->{report_port},
55 |  |  |  |  | Proto => 'tcp')) {
56 |  |  |  |  | eval{
57 |  |  |  |  | my $timeout = 100;
58 |  |  |  |  | local $SIG{ALRM}=sub{die("timeout for sending tap report ($timeout seconds) reached.");};
59 |  |  |  |  | alarm($timeout);
60 |  |  |  |  | ($reportid) = <$sock> =~m/(\d+)$/g;
61 |  |  |  |  | $sock->print($tap);
62 |  |  |  |  | };
63 |  |  |  |  | alarm(0);
64 |  |  |  |  | $self->log->error($@) if $@;
65 |  |  |  |  | close $sock;
66 |  |  |  |  | } else {
67 |  |  |  |  | return(1,"Can not connect to report server: $!");
68 |  |  |  |  | }
69 |  |  |  |  | return (0,$reportid);
70 |  |  |  |  |
71 |  |  |  |  | }
72 |  |  |  |  |
73 |  |  |  |  | =head2 tap_report_send
74 |  |  |  |  |
75 |  |  |  |  | Send information of current test run status to report framework using TAP
76 |  |  |  |  | protocol.
77 |  |  |  |  |
78 |  |  |  |  | @param array - report array
79 |  |  |  |  | @param array - header lines
80 |  |  |  |  |
81 |  |  |  |  | @return success - (0, report id)
82 |  |  |  |  | @return error - (1, error string)
83 |  |  |  |  |
84 |  |  |  |  | =cut
85 |  |  |  |  |
86 |  |  |  |  | sub tap_report_send
87 |  |  |  |  | {
88 |  |  |  |  | my ($self, $reportlines, $headerlines) = @_;
89 |  |  |  |  | my $tap = $self->tap_report_create($reportlines, $headerlines);
90 |  |  |  |  | $self->log->debug($tap);
91 |  |  |  |  | return $self->tap_report_away($tap);
92 |  |  |  |  | }
93 |  |  |  |  |
94 |  |  |  |  | =head2 associated_hostname
95 |  |  |  |  |
96 |  |  |  |  | Return the name of the host associated to this testrun or 'No hostname
97 |  |  |  |  | set'.
98 |  |  |  |  |
99 |  |  |  |  | @return string - hostname
100 |  |  |  |  |
101 |  |  |  |  | =cut
102 |  |  |  |  |
103 |  |  |  |  | sub associated_hostname
104 |  |  |  |  | {
105 |  |  |  |  | my ($self) = @_;
106 |  |  |  |  | my $hostname;
107 |  |  |  |  |
108 |  |  |  |  | eval {
109 |  |  |  |  | # parts of this chain may not exists and thus thow an exception
110 |  |  |  |  | $hostname = $self->testrun->testrun_scheduling->host->name;
111 |  |  |  |  | };
112 |  |  |  |  | return ($hostname // 'No hostname set');
113 |  |  |  |  | }
114 |  |  |  |  |
115 |  |  |  |  |
116 |  |  |  |  | =head2 suite_headerlines
117 |  |  |  |  |
118 |  |  |  |  | Generate TAP header lines for the main MCP report.
119 |  |  |  |  |
120 |  |  |  |  | @param int - testrun id
121 |  |  |  |  |
122 |  |  |  |  | @return array ref - header lines
123 |  |  |  |  |
124 |  |  |  |  | =cut
125 |  |  |  |  |
126 |  |  |  |  | sub mcp_headerlines {
127 |  |  |  |  | my ($self) = @_;
128 |  |  |  |  |
129 |  |  |  |  | my $topic = $self->testrun->topic_name() || $self->testrun->shortname();
130 |  |  |  |  | $topic =~ s/\s+/-/g;
131 |  |  |  |  | my $hostname = $self->associated_hostname();
132 |  |  |  |  | my $testrun_id = $self->testrun->id;
133 |  |  |  |  |
134 |  |  |  |  | my $headerlines = [
135 |  |  |  |  | "# Tapper-reportgroup-testrun: $testrun_id",
136 |  |  |  |  | "# Tapper-suite-name: Topic-$topic",
137 |  |  |  |  | "# Tapper-suite-version: $Tapper::MCP::VERSION",
138 |  |  |  |  | "# Tapper-machine-name: $hostname",
139 |  |  |  |  | "# Tapper-section: MCP overview",
140 |  |  |  |  | "# Tapper-reportgroup-primary: 1",
141 |  |  |  |  | ];
142 |  |  |  |  | return $headerlines;
143 |  |  |  |  | }
144 |  |  |  |  |
145 |  |  |  |  | =head2 tap_report_create
146 |  |  |  |  |
147 |  |  |  |  | Create a report string from a report in array form. Since the function only
148 |  |  |  |  | does data transformation, no error should ever occur.
149 |  |  |  |  |
150 |  |  |  |  | @param array ref - report array
151 |  |  |  |  | @param array ref - header lines
152 |  |  |  |  |
153 |  |  |  |  | @return report string
154 |  |  |  |  |
155 |  |  |  |  | =cut
156 |  |  |  |  |
157 |  |  |  |  | sub tap_report_create
158 |  |  |  |  | {
159 |  |  |  |  | my ($self, $reportlines, $headerlines) = @_;
160 |  |  |  |  | my @reportlines = @$reportlines;
161 |  |  |  |  | my $message;
162 |  |  |  |  | $message .= "1..".($#reportlines+1)."\n";
163 |  |  |  |  |
164 |  |  |  |  | foreach my $line (map { chomp; $_ } @$headerlines) {
165 |  |  |  |  | $message .= "$line\n";
166 |  |  |  |  | }
167 |  |  |  |  |
168 |  |  |  |  | # @reportlines starts with 0, reports start with 1
169 |  |  |  |  | for (my $i=1; $i<=$#reportlines+1; $i++) {
170 |  |  |  |  | $message .= "not " if $reportlines[$i-1]->{error};
171 |  |  |  |  | $message .="ok $i - ";
172 |  |  |  |  | $message .= $reportlines[$i-1]->{msg} if $reportlines[$i-1]->{msg};
173 |  |  |  |  | $message .="\n";
174 |  |  |  |  |
175 |  |  |  |  | $message .= "# ".$reportlines[$i-1]->{comment}."\n"
176 |  |  |  |  | if $reportlines[$i-1]->{comment};
177 |  |  |  |  | }
178 |  |  |  |  | return ($message);
179 |  |  |  |  | }
180 |  |  |  |  |
181 |  |  |  |  |
182 |  |  |  |  | =head2 upload_files
183 |  |  |  |  |
184 |  |  |  |  | Upload files written in one stage of the testrun to report framework.
185 |  |  |  |  |
186 |  |  |  |  | @param int - report id
187 |  |  |  |  | @param int - testrun id
188 |  |  |  |  |
189 |  |  |  |  | @return success - 0
190 |  |  |  |  | @return error - error string
191 |  |  |  |  |
192 |  |  |  |  | =cut
193 |  |  |  |  |
194 |  |  |  |  | sub upload_files
195 |  |  |  |  | {
196 |  |  |  |  | my ($self, $reportid, $testrunid) = @_;
197 |  |  |  |  | my $host = $self->cfg->{report_server};
198 |  |  |  |  | my $port = $self->cfg->{report_api_port};
199 |  |  |  |  |
200 |  |  |  |  | my $outputdir = $self->cfg->{paths}{output_dir};
201 |  |  |  |  | my $path = "$outputdir/$testrunid/";
202 |  |  |  |  | return 0 unless -d $path;
203 |  |  |  |  | my @files=`find $path -type f`;
204 |  |  |  |  | $self->log->debug(@files);
205 |  |  |  |  | foreach my $file(@files) {
206 |  |  |  |  | chomp $file;
207 |  |  |  |  | my $reportfile=$file;
208 |  |  |  |  | $reportfile =~ s|^$path||;
209 |  |  |  |  | $reportfile =~ s|^./||;
210 |  |  |  |  | $reportfile =~ s|[^A-Za-z0-9_-]|_|g;
211 |  |  |  |  | my $cmdline = "#! upload $reportid ";
212 |  |  |  |  | $cmdline .= $reportfile;
213 |  |  |  |  | $cmdline .= " plain\n";
214 |  |  |  |  |
215 |  |  |  |  | my $server = IO::Socket::INET->new(PeerAddr => $host,
216 |  |  |  |  | PeerPort => $port);
217 |  |  |  |  | return "Cannot open remote receiver $host:$port" if not $server;
218 |  |  |  |  |
219 |  |  |  |  | open(my $FH, "<",$file) or do{$self->log->warn("Can't open $file:$!"); $server->close();next;};
220 |  |  |  |  | $server->print($cmdline);
221 |  |  |  |  | while (my $line = <$FH>) {
222 |  |  |  |  | $server->print($line);
223 |  |  |  |  | }
224 |  |  |  |  | close($FH);
225 |  |  |  |  | $server->close();
226 |  |  |  |  | }
227 |  |  |  |  | system(qq{find "$outputdir" -maxdepth 1 -type d -mtime +30 -exec rm -fr \\{\\} \\;});
228 |  |  |  |  | return 0;
229 |  |  |  |  | }
230 |  |  |  |  |
231 |  |  |  |  |
232 | 1 | 5µs |  |  | 1;