Filename | /2home/ss5/local/projects/Tapper/src/Tapper-MCP/lib/Tapper/MCP/Net/TAP.pm |
Statements | Executed 17 statements in 1.05ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 94µs | 149µs | BEGIN@3 | Tapper::MCP::Net::TAP::
1 | 1 | 1 | 11µs | 55µs | BEGIN@3.13 | Tapper::MCP::Net::TAP::
1 | 1 | 1 | 11µs | 2.97ms | BEGIN@7 | Tapper::MCP::Net::TAP::
1 | 1 | 1 | 10µs | 26µs | BEGIN@5 | Tapper::MCP::Net::TAP::
1 | 1 | 1 | 8µs | 13µs | BEGIN@4 | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | __ANON__[lib/Tapper/MCP/Net/TAP.pm:58] | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | associated_hostname | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | mcp_headerlines | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | prc_headerlines | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | tap_report_away | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | tap_report_create | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | tap_report_send | Tapper::MCP::Net::TAP::
0 | 0 | 0 | 0s | 0s | upload_files | Tapper::MCP::Net::TAP::
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 | 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 # 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 # 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 # 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; |