straps.pm

SinFP是一种新的识别对方计算机操作系统类型的工具

=head2 $strap->_command()

Returns the command that runs the test.  Combine this with C<_switches()>
to build a command line.

Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
to use a different Perl than what you're running the harness under.
This might be to run a threaded Perl, for example.

You can also overload this method if you've built your own strap subclass,
such as a PHP interpreter for a PHP-based strap.

=cut

sub _command {
    my $self = shift;

    return $ENV{HARNESS_PERL}           if defined $ENV{HARNESS_PERL};
    return Win32::GetShortPathName($^X) if $self->{_is_win32};
    return $^X;
}


=head2 $strap->_switches( $file )

Formats and returns the switches necessary to run the test.

=cut

sub _switches {
    my($self, $file) = @_;

    my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
    my @derived_switches;

    local *TEST;
    open(TEST, $file) or print "can't open $file. $!\n";
    my $shebang = <TEST>;
    close(TEST) or print "can't close $file. $!\n";

    my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
    push( @derived_switches, "-$1" ) if $taint;

    # When taint mode is on, PERL5LIB is ignored.  So we need to put
    # all that on the command line as -Is.
    # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
    if ( $taint || $self->{_is_macos} ) {
	my @inc = $self->_filtered_INC;
	push @derived_switches, map { "-I$_" } @inc;
    }

    # 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 ( @derived_switches ) {
	$_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
    }
    return join( " ", @existing_switches, @derived_switches );
}

=head2 $strap->_cleaned_switches( @switches_from_user )

Returns only defined, non-blank, trimmed switches from the parms passed.

=cut

sub _cleaned_switches {
    my $self = shift;

    local $_;

    my @switches;
    for ( @_ ) {
	my $switch = $_;
	next unless defined $switch;
	$switch =~ s/^\s+//;
	$switch =~ s/\s+$//;
	push( @switches, $switch ) if $switch ne "";
    }

    return @switches;
}

=head2 $strap->_INC2PERL5LIB

  local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;

Takes the current value of C<@INC> and turns it into something suitable
for putting onto C<PERL5LIB>.

=cut

sub _INC2PERL5LIB {
    my($self) = shift;

    $self->{_old5lib} = $ENV{PERL5LIB};

    return join $Config{path_sep}, $self->_filtered_INC;
}

=head2 $strap->_filtered_INC()

  my @filtered_inc = $self->_filtered_INC;

Shortens C<@INC> by removing redundant and unnecessary entries.
Necessary for OSes with limited command line lengths, like VMS.

=cut

sub _filtered_INC {
    my($self, @inc) = @_;
    @inc = @INC unless @inc;

    if( $self->{_is_vms} ) {
	# VMS has a 255-byte limit on the length of %ENV entries, so
	# toss the ones that involve perl_root, the install location
        @inc = grep !/perl_root/i, @inc;

    }
    elsif ( $self->{_is_win32} ) {
	# Lose any trailing backslashes in the Win32 paths
	s/[\\\/+]$// foreach @inc;
    }

    my %seen;
    $seen{$_}++ foreach $self->_default_inc();
    @inc = grep !$seen{$_}++, @inc;

    return @inc;
}


sub _default_inc {
    my $self = shift;

    local $ENV{PERL5LIB};
    my $perl = $self->_command;
    my @inc =`$perl -le "print join qq[\\n], \@INC"`;
    chomp @inc;
    return @inc;
}


=head2 $strap->_restore_PERL5LIB()

  $self->_restore_PERL5LIB;

This restores the original value of the C<PERL5LIB> environment variable.
Necessary on VMS, otherwise a no-op.

=cut

sub _restore_PERL5LIB {
    my($self) = shift;

    return unless $self->{_is_vms};

    if (defined $self->{_old5lib}) {
        $ENV{PERL5LIB} = $self->{_old5lib};
    }
}

=head1 Parsing

Methods for identifying what sort of line you're looking at.

=head2 C<_is_diagnostic>

    my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);

Checks if the given line is a comment.  If so, it will place it into
C<$comment> (sans #).

=cut

sub _is_diagnostic {
    my($self, $line, $comment) = @_;

    if( $line =~ /^\s*\#(.*)/ ) {
        $$comment = $1;
        return $YES;
    }
    else {
        return $NO;
    }
}

=head2 C<_is_header>

  my $is_header = $strap->_is_header($line);

Checks if the given line is a header (1..M) line.  If so, it places how
many tests there will be in C<< $strap->{max} >>, a list of which tests
are todo in C<< $strap->{todo} >> and if the whole test was skipped
C<< $strap->{skip_all} >> contains the reason.

=cut

# Regex for parsing a header.  Will be run with /x
my $Extra_Header_Re = <<'REGEX';
                       ^
                        (?: \s+ todo \s+ ([\d \t]+) )?      # optional todo set
                        (?: \s* \# \s* ([\w:]+\s?) (.*) )?     # optional skip with optional reason
REGEX

sub _is_header {
    my($self, $line) = @_;

    if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
        $self->{max}  = $max;
        assert( $self->{max} >= 0,  'Max # of tests looks right' );

        if( defined $extra ) {
            my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;

            $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;

            if( $self->{max} == 0 ) {
                $reason = '' unless defined $skip and $skip =~ /^Skip/i;
            }

            $self->{skip_all} = $reason;
        }

        return $YES;
    }
    else {
        return $NO;
    }
}

=head2 C<_is_bail_out>

  my $is_bail_out = $strap->_is_bail_out($line, \$reason);

Checks if the line is a "Bail out!".  Places the reason for bailing
(if any) in $reason.

=cut

sub _is_bail_out {
    my($self, $line, $reason) = @_;

    if( $line =~ /^Bail out!\s*(.*)/i ) {
        $$reason = $1 if $1;
        return $YES;
    }
    else {
        return $NO;
    }
}

=head2 C<_reset_file_state>

  $strap->_reset_file_state;

Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
etc. so it's ready to parse the next file.

=cut

sub _reset_file_state {
    my($self) = shift;

    delete @{$self}{qw(max skip_all todo too_many_tests)};
    $self->{line}       = 0;
    $self->{saw_header} = 0;
    $self->{saw_bailout}= 0;
    $self->{lone_not_line} = 0;
    $self->{bailout_reason} = '';
    $self->{'next'}       = 1;
}

=head1 Results

The C<%results> returned from C<analyze()> contain the following
information:

  passing           true if the whole test is considered a pass 
                    (or skipped), false if its a failure

  exit              the exit code of the test run, if from a file
  wait              the wait code of the test run, if from a file

  max               total tests which should have been run
  seen              total tests actually seen
  skip_all          if the whole test was skipped, this will 
                      contain the reason.

  ok                number of tests which passed 
                      (including todo and skips)

  todo              number of todo tests seen
  bonus             number of todo tests which 
                      unexpectedly passed

  skip              number of tests skipped

So a successful test should have max == seen == ok.


There is one final item, the details.

  details           an array ref reporting the result of 
                    each test looks like this:

    $results{details}[$test_num - 1] = 
            { ok          => is the test considered ok?
              actual_ok   => did it literally say 'ok'?
              name        => name of the test (if any)
              diagnostics => test diagnostics (if any)
              type        => 'skip' or 'todo' (if any)
              reason      => reason for the above (if any)
            };

Element 0 of the details is test #1.  I tried it with element 1 being
#1 and 0 being empty, this is less awkward.

=head1 EXAMPLES

See F<examples/mini_harness.plx> for an example of use.

=head1 AUTHOR

Michael G Schwern C<< <[e-mail]> >>, currently maintained by
Andy Lester C<< <[e-mail]> >>.

=head1 SEE ALSO

L<Test::Harness>

=cut

sub _def_or_blank {
    return $_[0] if defined $_[0];
    return "";
}

1;