This file is indexed.

/usr/share/perl5/TAP/Harness/Archive.pm is in libtap-harness-archive-perl 0.18-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
package TAP::Harness::Archive;
use warnings;
use strict;
use base 'TAP::Harness';
use Cwd                     ();
use File::Basename          ();
use File::Temp              ();
use File::Spec              ();
use File::Path              ();
use File::Find              ();
use Archive::Tar            ();
use TAP::Parser             ();
use YAML::Tiny              ();
use TAP::Parser::Aggregator ();

=head1 NAME

TAP::Harness::Archive - Create an archive of TAP test results

=cut

our $VERSION = '0.18';

=head1 SYNOPSIS

    use TAP::Harness::Archive;
    my $harness = TAP::Harness::Archive->new(\%args);
    $harness->runtests(@tests);

=head1 DESCRIPTION

This module is a direct subclass of L<TAP::Harness> and behaves
in exactly the same way except for one detail. In addition to
outputting a running progress of the tests and an ending summary
it can also capture all of the raw TAP from the individual test
files or streams into an archive file (C<.tar> or C<.tar.gz>).

=head1 METHODS

All methods are exactly the same as our base L<TAP::Harness> except
for the following.

=head2 new

In addition to the options that L<TAP::Harness> allow to this method,
we also allow the following:

=over

=item archive

This is the name of the archive file to generate. We use L<Archive::Tar>
in the background so we only support C<.tar> and C<.tar.gz> archive file
formats. This can optionally be an existing directory that will have
the TAP archive's contents deposited therein without any file archiving
(no L<Archive::Tar> involved).

=item extra_files

This is an array reference to extra files that you want to include in the TAP
archive but which are not TAP files themselves. This is useful if you want to
include some log files that contain useful information about the test run.

=item extra_properties

This is a hash reference of extra properties that you've collected during your
test run. Some things you might want to include are the Perl version, the system's
architecture, the operating system, etc.

=back

=cut

my (%ARCHIVE_TYPES, @ARCHIVE_EXTENSIONS);
BEGIN {
    %ARCHIVE_TYPES = (
        'tar'    => 'tar',
        'tar.gz' => 'tar.gz',
        'tgz'    => 'tar.gz',
    );
    @ARCHIVE_EXTENSIONS = map { ".$_" } keys %ARCHIVE_TYPES;
}

sub new {
    my ($class, $args) = @_;
    $args ||= {};

    # these can't be passed on to Test::Harness
    my $archive     = delete $args->{archive};
    my $extra_files = delete $args->{extra_files};
    my $extra_props = delete $args->{extra_properties};

    $class->_croak("You must provide the name of the archive to create!")
      unless $archive;

    my $self = $class->SUPER::new($args);

    my $is_directory = -d $archive ? 1 : 0;
    if ($is_directory) {
        $self->{__archive_is_directory} = $is_directory;
        $self->{__archive_tempdir}      = $archive;
    } else {
        my $format = $class->_get_archive_format_from_filename($archive);

        # if it's not a format we understand, or it's not a directory
        $class->_croak("Archive is not a known format type!")
          unless $format && $ARCHIVE_TYPES{$format};

        $self->{__archive_file}    = $archive;
        $self->{__archive_format}  = $format;
        $self->{__archive_tempdir} = File::Temp::tempdir();
    }

    # handle any extra files
    if($extra_files) {
        ref $extra_files eq 'ARRAY' 
            or $class->_croak("extra_files must be an array reference!");
        foreach my $file (@$extra_files) {
            $class->_croak("extra_file $file does not exist!") unless -e $file;
            $class->_croak("extra_file $file is not readable!") unless -r $file;
        }
        $self->{__archive_extra_files} = $extra_files;
    }

    if($extra_props) {
        ref $extra_props eq 'HASH'
            or $class->_croak("extra_properties must be a hash reference!");
        $self->{__archive_extra_props} = $extra_props;
    }

    return $self;
}

sub _get_archive_format_from_filename {
    my ($self, $filename) = @_;

    # try to guess it if we don't have one
    my (undef, undef, $suffix) = File::Basename::fileparse($filename, @ARCHIVE_EXTENSIONS);
    $suffix =~ s/^\.//;
    return $ARCHIVE_TYPES{$suffix};
}

=head2 runtests

Takes the same arguments as L<TAP::Harness>'s version and returns the
same thing (a L<TAP::Parser::Aggregator> object). The only difference
is that in addition to the normal test running and progress output
we also create the TAP Archive when it's all done.

=cut

sub runtests {
    my ($self, @files) = @_;

    # tell TAP::Harness to put the raw tap someplace we can find it later
    my $dir = $self->{__archive_tempdir};
    $ENV{PERL_TEST_HARNESS_DUMP_TAP} = $dir;

    # get some meta information about this run
    my %meta = (
        file_order => \@files,
        start_time => time(),
    );

    my $aggregator = $self->SUPER::runtests(@files);

    $meta{stop_time} = time();

    my @parsers = $aggregator->parsers;
    for ( my $i = 0; $i < @parsers; $i++ ) {
        $parsers[ $i ] = {
            start_time  => $parsers[ $i ]->start_time,
            end_time    => $parsers[ $i ]->end_time,
            description => $files[ $i ],
        };
    }
    $meta{file_attributes} = \@parsers;

    my $cwd         = Cwd::getcwd();
    my $is_dir      = $self->{__archive_is_directory};
    my ($archive, $output_file);
    if( $is_dir ) {
        $output_file = $self->{__archive_tempdir};
    } else {
        $output_file = $self->{__archive_file};

        # go into the dir so that we can reference files
        # relatively and put them in the archive that way
        chdir($dir) or $self->_croak("Could not change to directory $dir: $!");

        unless (File::Spec->file_name_is_absolute($output_file)) {
            $output_file = File::Spec->catfile($cwd, $output_file);
        }

        # create the archive
        $archive = Archive::Tar->new();
        $archive->add_files($self->_get_all_tap_files);
        chdir($cwd) or $self->_croak("Could not return to directory $cwd: $!");
    }
 
    # add in any extra files
    if(my $x_files = $self->{__archive_extra_files}) {
        my @rel_x_files;
        foreach my $x_file (@$x_files) {
            # handle both relative and absolute file names
            my $rel_file;
            if( File::Spec->file_name_is_absolute($x_file) ) {
                $rel_file = File::Spec->abs2rel($x_file, $cwd);
            } else {
                $rel_file = $x_file;
            }
            push(@rel_x_files, $rel_file);
        }
        $archive->add_files(@rel_x_files) unless $is_dir;
        $meta{extra_files} = \@rel_x_files;
    }

    # add any extra_properties to the meta
    if(my $extra_props = $self->{__archive_extra_props}) {
        $meta{extra_properties} = $extra_props;
    }

    # create the YAML meta file
    my $yaml = YAML::Tiny->new();
    $yaml->[0] = \%meta;
    if( $is_dir ) {
        my $meta_file = File::Spec->catfile($output_file, 'meta.yml');
        open(my $out, '>', $meta_file) or die "Could not create meta.yml: $!";
        print $out $yaml->write_string;
        close($out);
    } else {
        $archive->add_data('meta.yml', $yaml->write_string);
        $archive->write($output_file, $self->{__archive_format} eq 'tar.gz') or die $archive->error;
        # be nice and clean up
        File::Path::rmtree($dir);
    }

    print "\nTAP Archive created at $output_file\n" unless $self->verbosity < -1;

    return $aggregator;
}

sub _get_all_tap_files {
    my ($self, $dir, $meta) = @_;
    $dir ||= $self->{__archive_tempdir};
    my @files;
    my %x_files;
    if($meta && $meta->{extra_files}) {
        %x_files = map { $_ => 1 } @{$meta->{extra_files}};
    }

    File::Find::find(
        {
            no_chdir => 1,
            wanted   => sub {
                return if /^\./;
                return if -d;
                my $rel_name = File::Spec->abs2rel($_, $dir);
                return if $rel_name eq 'meta.yml';
                push(@files, $rel_name) unless $x_files{$rel_name};
            },
        },
        $dir
    );
    return @files;
}

=head2 aggregator_from_archive

This class method will return a L<TAP::Parser::Aggregator> object
when given a TAP Archive to open and parse. It's pretty much the reverse
of creating a TAP Archive from using C<new> and C<runtests>.

It takes a hash of arguments which are as follows:

=over

=item archive

The path to the archive file. This can also be a directory if you created
the archive as a directory.  This is required.

=item parser_callbacks

This is a hash ref containing callbacks for the L<TAP::Parser> objects
that are created while parsing the TAP files. See the L<TAP::Parser>
documentation for details about these callbacks.

=item made_parser_callback

This callback is executed every time a new L<TAP::Parser> object
is created. It will be passed the new parser object, the name
of the file to be parsed, and also the full (temporary) path of that file.

=item meta_yaml_callback

This is a subroutine that will be called if we find and parse a YAML
file containing meta information about the test run in the archive.
The structure of the YAML file will be passed in as an argument.

=back

    my $aggregator = TAP::Harness::Archive->aggregator_from_archive(
        {
            archive          => 'my_tests.tar.gz',
            parser_callbacks => {
                plan    => sub { warn "Nice to see you plan ahead..." },
                unknown => sub { warn "Your TAP is bad!" },
            },
            made_parser_callback => sub {
                my ($parser, $file, $full_path) = @_;
                warn "$file is temporarily located at $full_path\n";
            }
            
        }
    );

=cut

sub aggregator_from_archive {
    my ($class, $args) = @_;
    my $meta;

    my $file = Cwd::abs_path( $args->{archive} )
      or $class->_croak("You must provide the path to the archive!");

    my $is_directory = -d $file;

    # extract the files out into a temporary directory
    my $dir = $is_directory ? $file : File::Temp::tempdir();
    my $cwd = Cwd::getcwd();
    chdir($dir) or $class->_croak("Could not change to directory $dir: $!");
    my @files;

    Archive::Tar->new()->extract_archive($file) unless $is_directory;
    my @tap_files;

    # do we have a meta.yml file in the archive?
    my $yaml_file = File::Spec->catfile($dir, 'meta.yml');
    if( -e $yaml_file) {

        # parse it into a structure
        if ($YAML::Tiny::VERSION < 1.57) {
            $meta = YAML::Tiny->new()->read($yaml_file);
            die "Could not read YAML $yaml_file: " . YAML::Tiny->errstr if YAML::Tiny->errstr;
        } else {
            $meta = eval {
                YAML::Tiny->new()->read($yaml_file);
            };
            if ($@) {
                die "Could not read YAML $yaml_file: ".$@;
            }
        }

        if($args->{meta_yaml_callback}) {
            $args->{meta_yaml_callback}->($meta);
        }
        $meta = $meta->[0];

        if($meta->{file_order} && ref $meta->{file_order} eq 'ARRAY') {
            foreach my $file (@{$meta->{file_order}}) {
                push(@tap_files, $file) if -e $file;
            }
        }
    }

    # if we didn't get the files from the YAML file, just find them all
    unless(@tap_files) {
        @tap_files = $class->_get_all_tap_files($dir, $meta);
    }

    # now create the aggregator
    my $aggregator = TAP::Parser::Aggregator->new();
    foreach my $tap_file (@tap_files) {
        open(my $fh, $tap_file) or die "Could not open $tap_file for reading: $!";
        my $parser = TAP::Parser->new({source => $fh, callbacks => $args->{parser_callbacks}});
        if($args->{made_parser_callback}) {
            $args->{made_parser_callback}->($parser, $tap_file, File::Spec->catfile($dir, $tap_file));
        }
        $parser->run;
        $aggregator->add($tap_file, $parser);
    }

    # be nice and clean up
    chdir($cwd) or $class->_croak("Could not return to directory $cwd: $!");
    File::Path::rmtree($dir) unless $is_directory;

    return $aggregator;
}

=head1 AUTHOR

Michael Peters, C<< <mpeters at plusthree.com> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-tap-harness-archive at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Harness-Archive>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc TAP::Harness::Archive

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/TAP-Harness-Archive>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/TAP-Harness-Archive>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=TAP-Harness-Archive>

=item * Search CPAN

L<http://search.cpan.org/dist/TAP-Harness-Archive>

=back

=head1 ACKNOWLEDGEMENTS

=over

=item * A big thanks to Plus Three, LP (L<http://www.plusthree.com>) for sponsoring my work on this module and other open source pursuits.

=item * Andy Armstrong

=back

=head1 COPYRIGHT & LICENSE

Copyright 2007 Michael Peters, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;    # End of TAP::Harness::Archive