util/testgraph.pl

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 #use Smart::Comments;
   7 use Best 0.05 [ [qw/YAML::Syck YAML/], qw/Dump Load/ ];
   8 use Getopt::Long;
   9 use Test::TAP::HTMLMatrix;
  10 use Test::TAP::Model::Visual;
  11 use File::Spec;
  12
  13 GetOptions \our %Config, qw(inlinecss|e cssfile|c=s help|h);
  14 $Config{cssfile} ||= Test::TAP::HTMLMatrix->css_file();
  15 usage() if $Config{help};
  16
  17 my $yamlfile = shift || 'smoke.yml';
  18
  19 open(my $yamlfh, '<', $yamlfile) or die "Couldn't open $yamlfile for reading: $!";
  20 binmode $yamlfh, ":utf8" or die "binmode: $!";
  21 local $/=undef;
  22
  23 my $data = Load(<$yamlfh>);
  24 ## data keys: keys %$data
  25 ### build info: $data->{build_info}
  26 my $timing = $data->{timing};
  27 $timing->{duration} .=
  28     " (" . sprintf("%.2f min", $timing->{duration} / 60) . ')';
  29 $timing->{start} .=
  30     " (" . localtime($timing->{start}) . ')';
  31 $timing->{end} .= " (" . localtime($timing->{end}) . ')';
  32 ### timing: $data->{timing}
  33
  34 undef $yamlfh;
  35
  36 my $tap = My::Model->new_with_struct(delete $data->{meat});
  37 my $v = Test::TAP::HTMLMatrix->new($tap, Dump($data));
  38 $v->has_inline_css($Config{inlinecss});
  39
  40 my $fh;
  41 if (my $out = shift) {
  42     open $fh, '>', $out or die $!;
  43 }
  44 else {
  45     $fh = \*STDOUT;
  46 }
  47 binmode $fh, ":utf8" or die "binmode: $!";
  48 my $html = "$v";
  49 # patch the resulting HTML for the "...\n...\t" stuff
  50 $html =~ s{(?<=build_info:) \&quot;([^\n]*)\&quot;}
  51     { my $s = $1; $s =~ s/\\n/\n/g; $s =~ s/\\t/\t/g; "\n$s" }ems;
  52 print $fh $html; close $fh;
  53
  54 sub usage {
  55   print <<"USAGE";
  56 usage: $0 [OPTIONS] > output_file.html
  57
  58 Generates an HTML summary of a YAML test run. Options:
  59
  60    --inlinecss, -e      inline css in HTML header (for broken webservers)
  61    --cssfile,  -c FILE  location of css. [default: $Config{cssfile}]
  62
  63 See also:
  64    util/yaml_harness.pl  - produce the data for this tool
  65    util/catalog_tests.pl - produce cross-linkable tests
  66    util/run-smoke.pl     - automate the smoke process
  67
  68 USAGE
  69   exit 0;
  70 }
  71
  72 {
  73     package My::Model;
  74     use base qw/Test::TAP::Model::Visual/;
  75     sub file_class { "My::File" }
  76
  77     package My::File;
  78     use base qw/Test::TAP::Model::File::Visual/;
  79     sub subtest_class { "My::Subtest" }
  80     sub link {
  81         my $self = shift;
  82         my $link = $self->SUPER::link;
  83         $link =~ s/\.t$/.html/;
  84         File::Spec->catdir("t_index",$link);
  85     }
  86
  87     package My::Subtest;
  88     use base qw/Test::TAP::Model::Subtest::Visual/;
  89     sub link {
  90         my $self = shift;
  91         my $link = $self->SUPER::link;
  92         $link =~ s/\.t(?=#line|$)/.html/;
  93         File::Spec->catdir("t_index",$link);
  94     }
  95 }
  96