view release on metacpan or  search on metacpan

t/lib/Test/Builder.pm  view on Meta::CPAN

You'll want to avoid qr// if you want your tests to work before 5.005.

=item B<unlike>

  $Test->unlike($this, qr/$regex/, $name);
  $Test->unlike($this, '/$regex/', $name);

Like Test::More's unlike().  Checks if $this B<does not match> the
given $regex.

=cut

sub like {
    my($self, $this, $regex, $name) = @_;

    local $Level = $Level + 1;
    $self->_regex_ok($this, $regex, '=~', $name);
}

sub unlike {
    my($self, $this, $regex, $name) = @_;

    local $Level = $Level + 1;
    $self->_regex_ok($this, $regex, '!~', $name);
}

=item B<maybe_regex>

  $Test->maybe_regex(qr/$regex/);
  $Test->maybe_regex('/$regex/');

Convenience method for building testing functions that take regular
expressions as arguments, but need to work before perl 5.005.

Takes a quoted regular expression produced by qr//, or a string
representing a regular expression.

Returns a Perl value which may be used instead of the corresponding
regular expression, or undef if it's argument is not recognised.

For example, a version of like(), sans the useful diagnostic messages,
could be written as:

  sub laconic_like {
      my ($self, $this, $regex, $name) = @_;
      my $usable_regex = $self->maybe_regex($regex);
      die "expecting regex, found '$regex'\n"
          unless $usable_regex;
      $self->ok($this =~ m/$usable_regex/, $name);
  }

=cut


sub maybe_regex {
	my ($self, $regex) = @_;
    my $usable_regex = undef;
    if( ref $regex eq 'Regexp' ) {
        $usable_regex = $regex;
    }
    # Check if it looks like '/foo/'
    elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
        $usable_regex = length $opts ? "(?$opts)$re" : $re;
    };
    return($usable_regex)
};

sub _regex_ok {
    my($self, $this, $regex, $cmp, $name) = @_;

    local $Level = $Level + 1;

    my $ok = 0;
    my $usable_regex = $self->maybe_regex($regex);
    unless (defined $usable_regex) {
        $ok = $self->ok( 0, $name );
        $self->diag("    '$regex' doesn't look much like a regex to me.");
        return $ok;
    }

    {
        local $^W = 0;
        my $test = $this =~ /$usable_regex/ ? 1 : 0;
        $test = !$test if $cmp eq '!~';
        $ok = $self->ok( $test, $name );
    }

    unless( $ok ) {
        $this = defined $this ? "'$this'" : 'undef';
        my $match = $cmp eq '=~' ? "doesn't match" : "matches";
        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
                  %s
    %13s '%s'
DIAGNOSTIC

    }

    return $ok;
}

=item B<cmp_ok>

  $Test->cmp_ok($this, $type, $that, $name);

Works just like Test::More's cmp_ok().

    $Test->cmp_ok($big_num, '!=', $other_big_num);

=cut

sub cmp_ok {
    my($self, $got, $type, $expect, $name) = @_;

    my $test;
    {
        local $^W = 0;
        local($@,$!);   # don't interfere with $@
                        # eval() sometimes resets $!
        $test = eval "\$got $type \$expect";
    }
    local $Level = $Level + 1;

t/lib/Test/Builder.pm  view on Meta::CPAN

=cut

sub current_test {
    my($self, $num) = @_;

    lock($Curr_Test);
    if( defined $num ) {
        unless( $Have_Plan ) {
            require Carp;
            Carp::croak("Can't change the current test number without a plan!");
        }

        $Curr_Test = $num;
        if( $num > @Test_Results ) {
            my $start = @Test_Results ? $#Test_Results : 0;
            for ($start..$num-1) {
                $Test_Results[$_] = 1;
            }
        }
    }
    return $Curr_Test;
}


=item B<summary>

    my @tests = $Test->summary;

A simple summary of the tests so far.  True for pass, false for fail.
This is a logical pass/fail, so todos are passes.

Of course, test #1 is $tests[0], etc...

=cut

sub summary {
    my($self) = shift;

    return @Test_Results;
}

=item B<details>  I<UNIMPLEMENTED>

    my @tests = $Test->details;

Like summary(), but with a lot more detail.

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

=item B<todo>

    my $todo_reason = $Test->todo;
    my $todo_reason = $Test->todo($pack);

todo() looks for a $TODO variable in your tests.  If set, all tests
will be considered 'todo' (see Test::More and Test::Harness for
details).  Returns the reason (ie. the value of $TODO) if running as
todo tests, false otherwise.

todo() is pretty part about finding the right package to look for
$TODO in.  It uses the exported_to() package to find it.  If that's
not set, it's pretty good at guessing the right package to look at.

Sometimes there is some confusion about where todo() should be looking
for the $TODO variable.  If you want to be sure, tell it explicitly
what $pack to use.

=cut

sub todo {
    my($self, $pack) = @_;

    $pack = $pack || $self->exported_to || $self->caller(1);

    no strict 'refs';
    return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
                                     : 0;
}

=item B<caller>

    my $package = $Test->caller;
    my($pack, $file, $line) = $Test->caller;
    my($pack, $file, $line) = $Test->caller($height);

Like the normal caller(), except it reports according to your level().

=cut

sub caller {
    my($self, $height) = @_;
    $height ||= 0;

    my @caller = CORE::caller($self->level + $height + 1);
    return wantarray ? @caller : $caller[0];
}

=back

=cut

=begin _private

=over 4

=item B<_sanity_check>

  _sanity_check();

Runs a bunch of end of test sanity checks to make sure reality came
through ok.  If anything is wrong it will die with a fairly friendly
error message.

=cut