1package TAP::Harness::Env; 2 3use strict; 4use warnings; 5 6use constant IS_VMS => ( $^O eq 'VMS' ); 7use TAP::Object; 8use Text::ParseWords qw/shellwords/; 9 10our $VERSION = '3.30_01'; 11 12# Get the parts of @INC which are changed from the stock list AND 13# preserve reordering of stock directories. 14sub _filtered_inc_vms { 15 my @inc = grep { !ref } @INC; #28567 16 17 # VMS has a 255-byte limit on the length of %ENV entries, so 18 # toss the ones that involve perl_root, the install location 19 @inc = grep { !/perl_root/i } @inc; 20 21 my @default_inc = _default_inc(); 22 23 my @new_inc; 24 my %seen; 25 for my $dir (@inc) { 26 next if $seen{$dir}++; 27 28 if ( $dir eq ( $default_inc[0] || '' ) ) { 29 shift @default_inc; 30 } 31 else { 32 push @new_inc, $dir; 33 } 34 35 shift @default_inc while @default_inc and $seen{ $default_inc[0] }; 36 } 37 return @new_inc; 38} 39 40# Cache this to avoid repeatedly shelling out to Perl. 41my @inc; 42 43sub _default_inc { 44 return @inc if @inc; 45 46 local $ENV{PERL5LIB}; 47 local $ENV{PERLLIB}; 48 49 my $perl = $ENV{HARNESS_PERL} || $^X; 50 51 # Avoid using -l for the benefit of Perl 6 52 chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` ); 53 return @inc; 54} 55 56sub create { 57 my $package = shift; 58 my %input = %{ shift || {} }; 59 60 my @libs = @{ delete $input{libs} || [] }; 61 my @raw_switches = @{ delete $input{switches} || [] }; 62 my @opt 63 = ( @raw_switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} || '' ) ); 64 my @switches; 65 while ( my $opt = shift @opt ) { 66 if ( $opt =~ /^ -I (.*) $ /x ) { 67 push @libs, length($1) ? $1 : shift @opt; 68 } 69 else { 70 push @switches, $opt; 71 } 72 } 73 74 # Do things the old way on VMS... 75 push @libs, _filtered_inc_vms() if IS_VMS; 76 77 # If $Verbose isn't numeric default to 1. This helps core. 78 my $verbose 79 = $ENV{HARNESS_VERBOSE} 80 ? $ENV{HARNESS_VERBOSE} !~ /\d/ 81 ? 1 82 : $ENV{HARNESS_VERBOSE} 83 : 0; 84 85 my %args = ( 86 lib => \@libs, 87 timer => $ENV{HARNESS_TIMER} || 0, 88 switches => \@switches, 89 color => $ENV{HARNESS_COLOR} || 0, 90 verbosity => $verbose, 91 ignore_exit => $ENV{HARNESS_IGNORE_EXIT} || 0, 92 ); 93 94 my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; 95 if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { 96 for my $opt ( split /:/, $env_opt ) { 97 if ( $opt =~ /^j(\d*)$/ ) { 98 $args{jobs} = $1 || 9; 99 } 100 elsif ( $opt eq 'c' ) { 101 $args{color} = 1; 102 } 103 elsif ( $opt =~ m/^f(.*)$/ ) { 104 my $fmt = $1; 105 $fmt =~ s/-/::/g; 106 $args{formatter_class} = $fmt; 107 } 108 elsif ( $opt =~ m/^a(.*)$/ ) { 109 my $archive = $1; 110 $class = 'TAP::Harness::Archive'; 111 $args{archive} = $archive; 112 } 113 else { 114 die "Unknown HARNESS_OPTIONS item: $opt\n"; 115 } 116 } 117 } 118 return TAP::Object->_construct($class, { %args, %input }); 119} 120 1211; 122 123=head1 NAME 124 125TAP::Harness::Env - Parsing harness related environmental variables where appropriate 126 127=head1 VERSION 128 129Version 3.30 130 131=head1 SYNOPSIS 132 133 my ($class, $args) = get_test_arguments(); 134 require_module($class); 135 $class->new($args); 136 137=head1 DESCRIPTION 138 139This module implements the environmental variables that L<Test::Harness> for use with TAP::Harness. 140 141=head1 FUNCTIONS 142 143=over 4 144 145=item * get_test_options( \%args ) 146 147This function reads the environment and generates an appropriate argument hash from it. If given any arguments, there will override the environmental defaults. It will return of C<$class> and C<$args>. 148 149=back 150