[p5sagit/p5-mst-13.2.git] / ext / Test / Harness / lib / TAP / Parser / Source / Perl.pm

package TAP::Parser::Source::Perl;

use strict;
use Config;
use vars qw($VERSION @ISA);

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS => ( $^O eq 'VMS' );

use TAP::Parser::Source;
use TAP::Parser::Utils qw( split_shell );

@ISA = 'TAP::Parser::Source';

=head1 NAME

TAP::Parser::Source::Perl - Stream Perl output

=head1 VERSION

Version 3.14

=cut

$VERSION = '3.14';

=head1 SYNOPSIS

  use TAP::Parser::Source::Perl;
  my $perl = TAP::Parser::Source::Perl->new;
  my $stream = $perl->source( [ $filename, @args ] )->get_stream;

=head1 DESCRIPTION

Takes a filename and hopefully returns a stream from it.  The filename should
be the name of a Perl program.

Note that this is a subclass of L<TAP::Parser::Source>.  See that module for
more methods.

=head1 METHODS

=head2 Class Methods

=head3 C<new>

 my $perl = TAP::Parser::Source::Perl->new;

Returns a new C<TAP::Parser::Source::Perl> object.

=head2 Instance Methods

=head3 C<source>

Getter/setter the name of the test program and any arguments it requires.

  my ($filename, @args) = @{ $perl->source };
  $perl->source( [ $filename, @args ] );

C<croak>s if C<$filename> could not be found.

=cut

sub source {
    my $self = shift;
    $self->_croak("Cannot find ($_[0][0])")
      if @_ && !-f $_[0][0];
    return $self->SUPER::source(@_);
}

=head3 C<switches>

  my $switches = $perl->switches;
  my @switches = $perl->switches;
  $perl->switches( \@switches );

Getter/setter for the additional switches to pass to the perl executable.  One
common switch would be to set an include directory:

  $perl->switches( ['-Ilib'] );

=cut

sub switches {
    my $self = shift;
    unless (@_) {
        return wantarray ? @{ $self->{switches} } : $self->{switches};
    }
    my $switches = shift;
    $self->{switches} = [@$switches];    # force a copy
    return $self;
}

##############################################################################

=head3 C<get_stream>

  my $stream = $source->get_stream($parser);

Returns a stream of the output generated by executing C<source>. Must be
passed an object that implements a C<make_iterator> method. Typically
this is a TAP::Parser instance.

=cut

sub get_stream {
    my ( $self, $factory ) = @_;

    my @extra_libs;

    my @switches = $self->_switches;
    my $path_sep = $Config{path_sep};
    my $path_pat = qr{$path_sep};

    # Nasty kludge. It might be nicer if we got the libs separately
    # although at least this way we find any -I switches that were
    # supplied other then as explicit libs.
    # We filter out any names containing colons because they will break
    # PERL5LIB
    my @libs;
    for ( grep { $_ !~ $path_pat } @switches ) {
        push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
    }

    my $previous = $ENV{PERL5LIB};
    if ($previous) {
        push @libs, split( $path_pat, $previous );
    }

    my $setup = sub {
        if (@libs) {
            $ENV{PERL5LIB} = join( $path_sep, @libs );
        }
    };

    # Cargo culted from comments seen elsewhere about VMS / environment
    # variables. I don't know if this is actually necessary.
    my $teardown = sub {
        if ($previous) {
            $ENV{PERL5LIB} = $previous;
        }
        else {
            delete $ENV{PERL5LIB};
        }
    };

    # Taint mode ignores environment variables so we must retranslate
    # PERL5LIB as -I switches and place PERL5OPT on the command line
    # in order that it be seen.
    if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
        push @switches,
          $self->_libs2switches(
            split $path_pat,
            $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
          );

        push @switches, split_shell( $ENV{PERL5OPT} );
    }

    my @command = $self->_get_command_for_switches(@switches)
      or $self->_croak("No command found!");

    return $factory->make_iterator(
        {   command  => \@command,
            merge    => $self->merge,
            setup    => $setup,
            teardown => $teardown,
        }
    );
}

sub _get_command_for_switches {
    my $self     = shift;
    my @switches = @_;
    my ( $file, @args ) = @{ $self->source };
    my $command = $self->_get_perl;

# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
    my @command = ( $command, @switches, $file, @args );
    return @command;
}

sub _get_command {
    my $self = shift;
    return $self->_get_command_for_switches( $self->_switches );
}

sub _libs2switches {
    my $self = shift;
    return map {"-I$_"} grep {$_} @_;
}

=head3 C<shebang>

Get the shebang line for a script file.

  my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );

May be called as a class method

=cut

{

    # Global shebang cache.
    my %shebang_for;

    sub _read_shebang {
        my $file = shift;
        local *TEST;
        my $shebang;
        if ( open( TEST, $file ) ) {
            $shebang = <TEST>;
            close(TEST) or print "Can't close $file. $!\n";
        }
        else {
            print "Can't open $file. $!\n";
        }
        return $shebang;
    }

    sub shebang {
        my ( $class, $file ) = @_;
        unless ( exists $shebang_for{$file} ) {
            $shebang_for{$file} = _read_shebang($file);
        }
        return $shebang_for{$file};
    }
}

=head3 C<get_taint>

Decode any taint switches from a Perl shebang line.

  # $taint will be 't'
  my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );

  # $untaint will be undefined
  my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );

=cut

sub get_taint {
    my ( $class, $shebang ) = @_;
    return
      unless defined $shebang
          && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
    return $1;
}

sub _switches {
    my $self = shift;
    my ( $file, @args ) = @{ $self->source };
    my @switches = (
        $self->switches,
    );

    my $shebang = $self->shebang($file);
    return unless defined $shebang;

    my $taint = $self->get_taint($shebang);
    push @switches, "-$taint" if defined $taint;

    # Quote the argument if there's any whitespace in it, or if
    # we're VMS, since VMS requires all parms quoted.  Also, don't quote
    # it if it's already quoted.
    for (@switches) {
        $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
    }

    return @switches;
}

sub _get_perl {
    my $self = shift;
    return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
    return Win32::GetShortPathName($^X) if IS_WIN32;
    return $^X;
}

1;

=head1 SUBCLASSING

Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.

=head2 Example

  package MyPerlSource;

  use strict;
  use vars '@ISA';

  use Carp qw( croak );
  use TAP::Parser::Source::Perl;

  @ISA = qw( TAP::Parser::Source::Perl );

  sub source {
      my ($self, $args) = @_;
      if ($args) {
	  $self->{file} = $args->[0];
	  return $self->SUPER::source($args);
      }
      return $self->SUPER::source;
  }

  # use the version of perl from the shebang line in the test file
  sub _get_perl {
      my $self = shift;
      if (my $shebang = $self->shebang( $self->{file} )) {
          $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
	  return $1 if $1;
      }
      return $self->SUPER::_get_perl(@_);
  }

=head1 SEE ALSO

L<TAP::Object>,
L<TAP::Parser>,
L<TAP::Parser::Source>,

=cut
Commit	Line	Data
b965d173	1	package TAP::Parser::Source::Perl;
	2
	3	use strict;
	4	use Config;
	5	use vars qw($VERSION @ISA);
	6
	7	use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
	8	use constant IS_VMS => ( $^O eq 'VMS' );
	9
	10	use TAP::Parser::Source;
27fc0087	11	use TAP::Parser::Utils qw( split_shell );
27fc0087	12
b965d173	13	@ISA = 'TAP::Parser::Source';
	14
	15	=head1 NAME
	16
	17	TAP::Parser::Source::Perl - Stream Perl output
	18
	19	=head1 VERSION
	20
27fc0087	21	Version 3.14
b965d173	22
	23	=cut
	24
27fc0087	25	$VERSION = '3.14';
f7c69158	26
	27	=head1 SYNOPSIS
	28
	29	use TAP::Parser::Source::Perl;
	30	my $perl = TAP::Parser::Source::Perl->new;
	31	my $stream = $perl->source( [ $filename, @args ] )->get_stream;
b965d173	32
	33	=head1 DESCRIPTION
	34
	35	Takes a filename and hopefully returns a stream from it. The filename should
	36	be the name of a Perl program.
	37
	38	Note that this is a subclass of L<TAP::Parser::Source>. See that module for
	39	more methods.
	40
b965d173	41	=head1 METHODS
	42
	43	=head2 Class Methods
	44
	45	=head3 C<new>
	46
	47	my $perl = TAP::Parser::Source::Perl->new;
	48
	49	Returns a new C<TAP::Parser::Source::Perl> object.
	50
	51	=head2 Instance Methods
	52
	53	=head3 C<source>
	54
	55	Getter/setter the name of the test program and any arguments it requires.
	56
	57	my ($filename, @args) = @{ $perl->source };
	58	$perl->source( [ $filename, @args ] );
	59
f7c69158	60	C<croak>s if C<$filename> could not be found.
f7c69158	61
b965d173	62	=cut
	63
	64	sub source {
	65	my $self = shift;
	66	$self->_croak("Cannot find ($_[0][0])")
	67	if @_ && !-f $_[0][0];
	68	return $self->SUPER::source(@_);
	69	}
	70
	71	=head3 C<switches>
	72
	73	my $switches = $perl->switches;
	74	my @switches = $perl->switches;
	75	$perl->switches( \@switches );
	76
	77	Getter/setter for the additional switches to pass to the perl executable. One
	78	common switch would be to set an include directory:
	79
	80	$perl->switches( ['-Ilib'] );
	81
	82	=cut
	83
	84	sub switches {
	85	my $self = shift;
	86	unless (@_) {
	87	return wantarray ? @{ $self->{switches} } : $self->{switches};
	88	}
	89	my $switches = shift;
	90	$self->{switches} = [@$switches]; # force a copy
	91	return $self;
	92	}
	93
	94	##############################################################################
	95
	96	=head3 C<get_stream>
	97
f7c69158	98	my $stream = $source->get_stream($parser);
b965d173	99
f7c69158	100	Returns a stream of the output generated by executing C<source>. Must be
	101	passed an object that implements a C<make_iterator> method. Typically
	102	this is a TAP::Parser instance.
b965d173	103
	104	=cut
	105
	106	sub get_stream {
f7c69158	107	my ( $self, $factory ) = @_;
b965d173	108
	109	my @extra_libs;
	110
	111	my @switches = $self->_switches;
	112	my $path_sep = $Config{path_sep};
	113	my $path_pat = qr{$path_sep};
	114
	115	# Nasty kludge. It might be nicer if we got the libs separately
	116	# although at least this way we find any -I switches that were
	117	# supplied other then as explicit libs.
	118	# We filter out any names containing colons because they will break
	119	# PERL5LIB
	120	my @libs;
	121	for ( grep { $_ !~ $path_pat } @switches ) {
	122	push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
	123	}
	124
	125	my $previous = $ENV{PERL5LIB};
	126	if ($previous) {
	127	push @libs, split( $path_pat, $previous );
	128	}
	129
	130	my $setup = sub {
	131	if (@libs) {
	132	$ENV{PERL5LIB} = join( $path_sep, @libs );
	133	}
	134	};
	135
	136	# Cargo culted from comments seen elsewhere about VMS / environment
	137	# variables. I don't know if this is actually necessary.
	138	my $teardown = sub {
	139	if ($previous) {
	140	$ENV{PERL5LIB} = $previous;
	141	}
	142	else {
	143	delete $ENV{PERL5LIB};
	144	}
	145	};
	146
	147	# Taint mode ignores environment variables so we must retranslate
	148	# PERL5LIB as -I switches and place PERL5OPT on the command line
	149	# in order that it be seen.
27fc0087	150	if ( grep { $_ eq "-T" \|\| $_ eq "-t" } @switches ) {
b965d173	151	push @switches,
	152	$self->_libs2switches(
	153	split $path_pat,
	154	$ENV{PERL5LIB} \|\| $ENV{PERLLIB} \|\| ''
	155	);
	156
27fc0087	157	push @switches, split_shell( $ENV{PERL5OPT} );
b965d173	158	}
	159
	160	my @command = $self->_get_command_for_switches(@switches)
	161	or $self->_croak("No command found!");
	162
f7c69158	163	return $factory->make_iterator(
b965d173	164	{ command => \@command,
	165	merge => $self->merge,
	166	setup => $setup,
	167	teardown => $teardown,
	168	}
	169	);
	170	}
	171
	172	sub _get_command_for_switches {
	173	my $self = shift;
	174	my @switches = @_;
	175	my ( $file, @args ) = @{ $self->source };
	176	my $command = $self->_get_perl;
	177
f7c69158	178	# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
f7c69158	179	#$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
b965d173	180	my @command = ( $command, @switches, $file, @args );
	181	return @command;
	182	}
	183
	184	sub _get_command {
	185	my $self = shift;
	186	return $self->_get_command_for_switches( $self->_switches );
	187	}
	188
	189	sub _libs2switches {
	190	my $self = shift;
	191	return map {"-I$_"} grep {$_} @_;
	192	}
	193
	194	=head3 C<shebang>
	195
	196	Get the shebang line for a script file.
	197
f7c69158	198	my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
b965d173	199
	200	May be called as a class method
	201
	202	=cut
	203
	204	{
	205
	206	# Global shebang cache.
	207	my %shebang_for;
	208
	209	sub _read_shebang {
	210	my $file = shift;
	211	local *TEST;
	212	my $shebang;
	213	if ( open( TEST, $file ) ) {
	214	$shebang = <TEST>;
	215	close(TEST) or print "Can't close $file. $!\n";
	216	}
	217	else {
	218	print "Can't open $file. $!\n";
	219	}
	220	return $shebang;
	221	}
	222
	223	sub shebang {
	224	my ( $class, $file ) = @_;
	225	unless ( exists $shebang_for{$file} ) {
	226	$shebang_for{$file} = _read_shebang($file);
	227	}
	228	return $shebang_for{$file};
	229	}
	230	}
	231
	232	=head3 C<get_taint>
	233
	234	Decode any taint switches from a Perl shebang line.
	235
f7c69158	236	# $taint will be 't'
f7c69158	237	my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
b965d173	238
f7c69158	239	# $untaint will be undefined
f7c69158	240	my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
b965d173	241
	242	=cut
	243
	244	sub get_taint {
	245	my ( $class, $shebang ) = @_;
	246	return
	247	unless defined $shebang
	248	&& $shebang =~ /^#!.\bperl.\s-\w*([Tt]+)/;
	249	return $1;
	250	}
	251
	252	sub _switches {
	253	my $self = shift;
	254	my ( $file, @args ) = @{ $self->source };
	255	my @switches = (
	256	$self->switches,
	257	);
	258
	259	my $shebang = $self->shebang($file);
	260	return unless defined $shebang;
	261
	262	my $taint = $self->get_taint($shebang);
	263	push @switches, "-$taint" if defined $taint;
	264
	265	# Quote the argument if there's any whitespace in it, or if
	266	# we're VMS, since VMS requires all parms quoted. Also, don't quote
	267	# it if it's already quoted.
	268	for (@switches) {
	269	$_ = qq["$_"] if ( ( /\s/ \|\| IS_VMS ) && !/^".*"$/ );
	270	}
	271
b965d173	272	return @switches;
	273	}
	274
	275	sub _get_perl {
f7c69158	276	my $self = shift;
69f36734	277	return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
b965d173	278	return Win32::GetShortPathName($^X) if IS_WIN32;
	279	return $^X;
	280	}
	281
	282	1;
f7c69158	283
	284	=head1 SUBCLASSING
	285
	286	Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
	287
	288	=head2 Example
	289
	290	package MyPerlSource;
	291
	292	use strict;
	293	use vars '@ISA';
	294
	295	use Carp qw( croak );
	296	use TAP::Parser::Source::Perl;
	297
	298	@ISA = qw( TAP::Parser::Source::Perl );
	299
	300	sub source {
	301	my ($self, $args) = @_;
	302	if ($args) {
	303	$self->{file} = $args->[0];
	304	return $self->SUPER::source($args);
	305	}
	306	return $self->SUPER::source;
	307	}
	308
	309	# use the version of perl from the shebang line in the test file
	310	sub _get_perl {
	311	my $self = shift;
	312	if (my $shebang = $self->shebang( $self->{file} )) {
	313	$shebang =~ /^#!(.\bperl.?)(?:(?:\s)\|(?:$))/;
	314	return $1 if $1;
	315	}
	316	return $self->SUPER::_get_perl(@_);
	317	}
	318
	319	=head1 SEE ALSO
	320
	321	L<TAP::Object>,
	322	L<TAP::Parser>,
	323	L<TAP::Parser::Source>,
	324
	325	=cut