| 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 | Tapper::MCP::Net::TAP::BEGIN@3 |
| 1 | 1 | 1 | 11µs | 55µs | Tapper::MCP::Net::TAP::BEGIN@3.13 |
| 1 | 1 | 1 | 11µs | 2.97ms | Tapper::MCP::Net::TAP::BEGIN@7 |
| 1 | 1 | 1 | 10µs | 26µs | Tapper::MCP::Net::TAP::BEGIN@5 |
| 1 | 1 | 1 | 8µs | 13µs | Tapper::MCP::Net::TAP::BEGIN@4 |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::__ANON__[lib/Tapper/MCP/Net/TAP.pm:58] |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::associated_hostname |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::mcp_headerlines |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::prc_headerlines |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::tap_report_away |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::tap_report_create |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::tap_report_send |
| 0 | 0 | 0 | 0s | 0s | Tapper::MCP::Net::TAP::upload_files |
| 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; |