File Coverage

blib/lib/Test/Reporter/Transport/Socket.pm
Criterion Covered Total %
statement 44 170 25.8
branch 6 74 8.1
condition 3 64 4.6
subroutine 12 18 66.6
pod 2 2 100.0
total 67 328 20.4


line stmt bran cond sub pod time code
1             package Test::Reporter::Transport::Socket;
2             $Test::Reporter::Transport::Socket::VERSION = '1.02';
3             # ABSTRACT: Simple socket transport for Test::Reporter
4              
5 1     1   841 use strict;
  1         2  
  1         29  
6 1     1   5 use warnings;
  1         2  
  1         24  
7 1     1   5 use Carp ();
  1         2  
  1         17  
8 1     1   754 use Storable qw[nfreeze];
  1         3503  
  1         63  
9 1     1   7 use base qw[Test::Reporter::Transport];
  1         2  
  1         574  
10              
11             my @required_args = qw/host port/;
12              
13             my $sockclass;
14              
15             BEGIN {
16 1     1   267 eval {
17 1         667 require IO::Socket::IP;
18 1         37181 $sockclass = 'IO::Socket::IP';
19             };
20 1 50       605 if ( !$sockclass ) {
21 0         0 require IO::Socket::INET;
22 0         0 $sockclass = 'IO::Socket::INET';
23             }
24             }
25              
26             sub new {
27 4     4 1 1659 my $class = shift;
28 4 50       16 Carp::confess __PACKAGE__ . " requires transport args in key/value pairs\n"
29             if @_ % 2;
30 4         14 my %args = @_;
31 4         21 $args{lc $_} = delete $args{$_} for keys %args;
32              
33 4         9 for my $k ( @required_args ) {
34             Carp::confess __PACKAGE__ . " requires $k argument\n"
35 7 100       288 unless exists $args{$k};
36             }
37              
38 3 100 100     12 if ( ref $args{host} eq 'ARRAY' and !scalar @{ $args{host} } ) {
  2         10  
39 1         152 Carp::confess __PACKAGE__ . " requires 'host' argument to have elements if it is an arrayref\n";
40             }
41              
42 2         7 return bless \%args => $class;
43             }
44              
45             sub send {
46 0     0 1   my ($self, $report) = @_;
47              
48 0 0         unless ( eval { $report->distfile } ) {
  0            
49 0           Carp::confess __PACKAGE__ . ": requires the 'distfile' parameter to be set\n"
50             . "Please update your CPAN testing software to a version that provides \n"
51             . "this information to Test::Reporter. Report will not be sent.\n";
52             }
53              
54             # Open the socket to the given host:port
55             # confess on failure.
56              
57 0           my $sock;
58              
59 0 0         foreach my $host ( ( ref $self->{host} eq 'ARRAY' ? @{ $self->{host} } : $self->{host} ) ) {
  0            
60             $sock = $sockclass->new(
61             PeerAddr => $host,
62             PeerPort => $self->{port},
63 0           Proto => 'tcp'
64             );
65 0 0         last if $sock;
66             }
67              
68 0 0         unless ( $sock ) {
69 0           Carp::confess __PACKAGE__ . ": could not connect to '$self->{host}' '$!'\n";
70             }
71              
72             # Get facts about Perl config that Test::Reporter doesn't capture
73             # Unfortunately we can't do this from the current perl in case this
74             # is a report regenerated from a file and isn't the perl that the report
75             # was run on
76 0           my $perlv = $report->{_perl_version}->{_myconfig};
77 0           my $config = TRTS::Config::Perl::V::summary(TRTS::Config::Perl::V::plv2hash($perlv));
78 0   0       my $perl_version = $report->{_perl_version}{_version} || $config->{version};
79              
80             my $data = {
81             distfile => $report->distfile,
82             grade => $report->grade,
83             osname => $config->{osname},
84             osversion => $report->{_perl_version}{_osvers},
85             archname => $report->{_perl_version}{_archname},
86 0           perl_version => $perl_version,
87             textreport => $report->report
88             };
89              
90 0           my $froze;
91 0           eval { $froze = nfreeze( $data ); };
  0            
92              
93 0 0         Carp::confess __PACKAGE__ . ": Could not freeze data '$@'\n"
94             unless $froze;
95              
96             # Thanks to Tony Cook for this
97              
98 0           while ( length( $froze ) ) {
99 0 0         my $sent = $sock->send( $froze ) or Carp::confess "Could not send data '$!'\n";
100 0           substr( $froze, 0, $sent, '' );
101             }
102              
103 0           close $sock;
104 0           return 1;
105             }
106              
107             package TRTS::Config::Perl::V;
108             $TRTS::Config::Perl::V::VERSION = '1.02';
109 1     1   11 use strict;
  1         3  
  1         24  
110 1     1   5 use warnings;
  1         3  
  1         56  
111              
112 1     1   7 use Config;
  1         2  
  1         45  
113 1     1   6 use Exporter;
  1         2  
  1         54  
114 1     1   7 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
  1         2  
  1         2459  
115             @ISA = qw( Exporter );
116             @EXPORT_OK = qw( plv2hash summary myconfig signature );
117             %EXPORT_TAGS = (
118             'all' => [ @EXPORT_OK ],
119             'sig' => [ "signature" ],
120             );
121              
122             # Characteristics of this binary (from libperl):
123             # Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
124             # USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
125              
126             # The list are as the perl binary has stored it in PL_bincompat_options
127             # search for it in
128             # perl.c line 1643 S_Internals_V ()
129             # perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c
130             # perl.h line 4566 PL_bincompat_options
131             # perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h
132             my %BTD = map {( $_ => 0 )} qw(
133              
134             DEBUGGING
135             NO_HASH_SEED
136             NO_MATHOMS
137             NO_TAINT_SUPPORT
138             PERL_BOOL_AS_CHAR
139             PERL_COPY_ON_WRITE
140             PERL_DISABLE_PMC
141             PERL_DONT_CREATE_GVSV
142             PERL_EXTERNAL_GLOB
143             PERL_HASH_FUNC_DJB2
144             PERL_HASH_FUNC_MURMUR3
145             PERL_HASH_FUNC_ONE_AT_A_TIME
146             PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
147             PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
148             PERL_HASH_FUNC_SDBM
149             PERL_HASH_FUNC_SIPHASH
150             PERL_HASH_FUNC_SUPERFAST
151             PERL_IS_MINIPERL
152             PERL_MALLOC_WRAP
153             PERL_MEM_LOG
154             PERL_MEM_LOG_ENV
155             PERL_MEM_LOG_ENV_FD
156             PERL_MEM_LOG_NOIMPL
157             PERL_MEM_LOG_STDERR
158             PERL_MEM_LOG_TIMESTAMP
159             PERL_NEW_COPY_ON_WRITE
160             PERL_OP_PARENT
161             PERL_PERTURB_KEYS_DETERMINISTIC
162             PERL_PERTURB_KEYS_DISABLED
163             PERL_PERTURB_KEYS_RANDOM
164             PERL_PRESERVE_IVUV
165             PERL_RELOCATABLE_INCPUSH
166             PERL_USE_DEVEL
167             PERL_USE_SAFE_PUTENV
168             SILENT_NO_TAINT_SUPPORT
169             UNLINK_ALL_VERSIONS
170             USE_ATTRIBUTES_FOR_PERLIO
171             USE_FAST_STDIO
172             USE_HASH_SEED_EXPLICIT
173             USE_LOCALE
174             USE_LOCALE_CTYPE
175             USE_NO_REGISTRY
176             USE_PERL_ATOF
177             USE_SITECUSTOMIZE
178             USE_THREAD_SAFE_LOCALE
179              
180             DEBUG_LEAKING_SCALARS
181             DEBUG_LEAKING_SCALARS_FORK_DUMP
182             DECCRTL_SOCKETS
183             FAKE_THREADS
184             FCRYPT
185             HAS_TIMES
186             HAVE_INTERP_INTERN
187             MULTIPLICITY
188             MYMALLOC
189             PERL_DEBUG_READONLY_COW
190             PERL_DEBUG_READONLY_OPS
191             PERL_GLOBAL_STRUCT
192             PERL_GLOBAL_STRUCT_PRIVATE
193             PERL_IMPLICIT_CONTEXT
194             PERL_IMPLICIT_SYS
195             PERLIO_LAYERS
196             PERL_MAD
197             PERL_MICRO
198             PERL_NEED_APPCTX
199             PERL_NEED_TIMESBASE
200             PERL_OLD_COPY_ON_WRITE
201             PERL_POISON
202             PERL_SAWAMPERSAND
203             PERL_TRACK_MEMPOOL
204             PERL_USES_PL_PIDSTATUS
205             PL_OP_SLAB_ALLOC
206             THREADS_HAVE_PIDS
207             USE_64_BIT_ALL
208             USE_64_BIT_INT
209             USE_IEEE
210             USE_ITHREADS
211             USE_LARGE_FILES
212             USE_LOCALE_COLLATE
213             USE_LOCALE_NUMERIC
214             USE_LOCALE_TIME
215             USE_LONG_DOUBLE
216             USE_PERLIO
217             USE_QUADMATH
218             USE_REENTRANT_API
219             USE_SFIO
220             USE_SOCKS
221             VMS_DO_SOCKETS
222             VMS_SHORTEN_LONG_SYMBOLS
223             VMS_SYMBOL_CASE_AS_IS
224             );
225              
226             # These are all the keys that are
227             # 1. Always present in %Config - lib/Config.pm #87 tie %Config
228             # 2. Reported by 'perl -V' (the rest)
229             my @config_vars = qw(
230              
231             api_subversion
232             api_version
233             api_versionstring
234             archlibexp
235             dont_use_nlink
236             d_readlink
237             d_symlink
238             exe_ext
239             inc_version_list
240             ldlibpthname
241             patchlevel
242             path_sep
243             perl_patchlevel
244             privlibexp
245             scriptdir
246             sitearchexp
247             sitelibexp
248             subversion
249             usevendorprefix
250             version
251              
252             git_commit_id
253             git_describe
254             git_branch
255             git_uncommitted_changes
256             git_commit_id_title
257             git_snapshot_date
258              
259             package revision version_patchlevel_string
260              
261             osname osvers archname
262             myuname
263             config_args
264             hint useposix d_sigaction
265             useithreads usemultiplicity
266             useperlio d_sfio uselargefiles usesocks
267             use64bitint use64bitall uselongdouble
268             usemymalloc default_inc_excludes_dot bincompat5005
269              
270             cc ccflags
271             optimize
272             cppflags
273             ccversion gccversion gccosandvers
274             intsize longsize ptrsize doublesize byteorder
275             d_longlong longlongsize d_longdbl longdblsize
276             ivtype ivsize nvtype nvsize lseektype lseeksize
277             alignbytes prototype
278              
279             ld ldflags
280             libpth
281             libs
282             perllibs
283             libc so useshrplib libperl
284             gnulibc_version
285              
286             dlsrc dlext d_dlsymun ccdlflags
287             cccdlflags lddlflags
288             );
289              
290             my %empty_build = (
291             'osname' => "",
292             'stamp' => 0,
293             'options' => { %BTD },
294             'patches' => [],
295             );
296              
297             sub _make_derived {
298 0     0     my $conf = shift;
299              
300 0           for ( [ 'lseektype' => "Off_t" ],
301             [ 'myuname' => "uname" ],
302             [ 'perl_patchlevel' => "patch" ],
303             ) {
304 0           my ($official, $derived) = @{$_};
  0            
305 0   0       $conf->{'config'}{$derived} ||= $conf->{'config'}{$official};
306 0   0       $conf->{'config'}{$official} ||= $conf->{'config'}{$derived};
307 0           $conf->{'derived'}{$derived} = delete $conf->{'config'}{$derived};
308             }
309              
310 0 0 0       if (exists $conf->{'config'}{'version_patchlevel_string'} &&
311             !exists $conf->{'config'}{'api_version'}) {
312 0           my $vps = $conf->{'config'}{'version_patchlevel_string'};
313             $vps =~ s{\b revision \s+ (\S+) }{}x and
314 0 0 0       $conf->{'config'}{'revision'} ||= $1;
315              
316             $vps =~ s{\b version \s+ (\S+) }{}x and
317 0 0 0       $conf->{'config'}{'api_version'} ||= $1;
318             $vps =~ s{\b subversion \s+ (\S+) }{}x and
319 0 0 0       $conf->{'config'}{'subversion'} ||= $1;
320             $vps =~ s{\b patch \s+ (\S+) }{}x and
321 0 0 0       $conf->{'config'}{'perl_patchlevel'} ||= $1;
322             }
323              
324             ($conf->{'config'}{'version_patchlevel_string'} ||= join " ",
325 0           map { ($_, $conf->{'config'}{$_} ) }
326 0   0       grep { $conf->{'config'}{$_} }
  0            
327             qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//;
328              
329 0   0       $conf->{'config'}{'perl_patchlevel'} ||= ""; # 0 is not a valid patchlevel
330              
331 0 0         if ($conf->{'config'}{'perl_patchlevel'} =~ m{^git\w*-([^-]+)}i) {
332 0   0       $conf->{'config'}{'git_branch'} ||= $1;
333 0   0       $conf->{'config'}{'git_describe'} ||= $conf->{'config'}{'perl_patchlevel'};
334             }
335              
336 0   0       $conf->{'config'}{$_} ||= "undef" for grep m{^(?:use|def)} => @config_vars;
337              
338 0           $conf;
339             } # _make_derived
340              
341             sub plv2hash {
342 0     0     my %config;
343              
344 0           my $pv = join "\n" => @_;
345              
346 0 0         if ($pv =~ m{^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)}m) {
347 0           $config{'package'} = $1;
348 0           my $rev = $2;
349 0 0         $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{'revision'} = $1;
350 0 0         $rev and $config{'version_patchlevel_string'} = $rev;
351 0           my ($rel) = $config{'package'} =~ m{perl(\d)};
352 0           my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
353             defined $vers && defined $subvers && defined $rel and
354 0 0 0       $config{'version'} = "$rel.$vers.$subvers";
      0        
355             }
356              
357 0 0         if ($pv =~ m{^\s+(Snapshot of:)\s+(\S+)}) {
358 0           $config{'git_commit_id_title'} = $1;
359 0           $config{'git_commit_id'} = $2;
360             }
361              
362             # these are always last on line and can have multiple quotation styles
363 0           for my $k (qw( ccflags ldflags lddlflags )) {
364 0 0         $pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next;
365 0           my $v = $1;
366 0           $v =~ s/\s*,\s*$//;
367 0           $v =~ s/^(['"])(.*)\1$/$2/;
368 0           $config{$k} = $v;
369             }
370              
371 0 0         if (my %kv = ($pv =~ m{\b
372             (\w+) # key
373             \s*= # assign
374             ( '\s*[^']*?\s*' # quoted value
375             | \S+[^=]*?\s*\n # unquoted running till end of line
376             | \S+ # unquoted value
377             | \s*\n # empty
378             )
379             (?:,?\s+|\s*\n)? # separator (5.8.x reports did not have a ','
380             }gx)) { # between every kv pair
381              
382 0           while (my ($k, $v) = each %kv) {
383 0           $k =~ s{\s+$} {};
384 0           $v =~ s{\s*\n\z} {};
385 0           $v =~ s{,$} {};
386 0 0         $v =~ m{^'(.*)'$} and $v = $1;
387 0           $v =~ s{\s+$} {};
388 0           $config{$k} = $v;
389             }
390             }
391              
392 0           my $build = { %empty_build };
393              
394             $pv =~ m{^\s+Compiled at\s+(.*)}m
395 0 0         and $build->{'stamp'} = $1;
396             $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms
397 0 0         and $build->{'patches'} = [ split m{\n+\s*}, $1 ];
398             $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms
399 0 0         and map { $build->{'options'}{$_} = 1 } split m{\s+|\n} => $1;
  0            
400              
401 0           $build->{'osname'} = $config{'osname'};
402             $pv =~ m{^\s+Built under\s+(.*)}m
403 0 0         and $build->{'osname'} = $1;
404 0   0       $config{'osname'} ||= $build->{'osname'};
405              
406 0           return _make_derived ({
407             'build' => $build,
408             'environment' => {},
409             'config' => \%config,
410             'derived' => {},
411             'inc' => [],
412             });
413             } # plv2hash
414              
415             sub summary {
416 0   0 0     my $conf = shift || myconfig ();
417             ref $conf eq "HASH"
418             && exists $conf->{'config'}
419             && exists $conf->{'build'}
420             && ref $conf->{'config'} eq "HASH"
421 0 0 0       && ref $conf->{'build'} eq "HASH" or return;
      0        
      0        
      0        
422              
423             my %info = map {
424 0 0         exists $conf->{'config'}{$_} ? ( $_ => $conf->{'config'}{$_} ) : () }
  0            
425             qw( archname osname osvers revision patchlevel subversion version
426             cc ccversion gccversion config_args inc_version_list
427             d_longdbl d_longlong use64bitall use64bitint useithreads
428             uselongdouble usemultiplicity usemymalloc useperlio useshrplib
429             doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
430             default_inc_excludes_dot
431             );
432 0           $info{$_}++ for grep { $conf->{'build'}{'options'}{$_} } keys %{$conf->{'build'}{'options'}};
  0            
  0            
433              
434 0           return \%info;
435             } # summary
436              
437             sub signature {
438 0     0     my $no_md5 = "0" x 32;
439 0 0         my $conf = summary (shift) or return $no_md5;
440              
441 0           eval { require Digest::MD5 };
  0            
442 0 0         $@ and return $no_md5;
443              
444 0           $conf->{'cc'} =~ s{.*\bccache\s+}{};
445 0           $conf->{'cc'} =~ s{.*[/\\]}{};
446              
447 0           delete $conf->{'config_args'};
448             return Digest::MD5::md5_hex (join "\xFF" => map {
449 0 0         "$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
450 0           } sort keys %{$conf});
  0            
451             } # signature
452              
453             sub myconfig {
454 0     0     my $args = shift;
455 0           my %args = ref $args eq "HASH" ? %{$args} :
456 0 0         ref $args eq "ARRAY" ? @{$args} : ();
  0 0          
457              
458 0           my $build = { %empty_build };
459              
460             # 5.14.0 and later provide all the information without shelling out
461 0           my $stamp = eval { Config::compile_date () };
  0            
462 0 0         if (defined $stamp) {
463 0           $stamp =~ s/^Compiled at //;
464 0           $build->{'osname'} = $^O;
465 0           $build->{'stamp'} = $stamp;
466 0           $build->{'patches'} = [ Config::local_patches () ];
467 0           $build->{'options'}{$_} = 1 for Config::bincompat_options (),
468             Config::non_bincompat_options ();
469             }
470             else {
471             #y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
472 0           my $cnf = plv2hash (qx[$^X -V]);
473              
474 0           $build->{$_} = $cnf->{'build'}{$_} for qw( osname stamp patches options );
475             }
476              
477 0           my @KEYS = keys %ENV;
478             my %env =
479 0           map {( $_ => $ENV{$_} )} grep m{^PERL} => @KEYS;
  0            
480 0 0         if ($args{'env'}) {
481 0           $env{$_} = $ENV{$_} for grep m{$args{'env'}} => @KEYS;
482             }
483              
484 0           my %config = map { $_ => $Config{$_} } @config_vars;
  0            
485              
486 0           return _make_derived ({
487             'build' => $build,
488             'environment' => \%env,
489             'config' => \%config,
490             'derived' => {},
491             'inc' => \@INC,
492             });
493             } # myconfig
494              
495             1;
496              
497             __END__