Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Remove Test::Builder2 from trunk to prevent it leaking out into a rel…

…ease.

It now has its own branch.
  • Loading branch information...
commit 6470109aa6c5b1d13eeb2ec3e5856d3125b67304 1 parent adc23b8
Michael G. Schwern schwern authored
4 MANIFEST.SKIP
View
@@ -28,7 +28,3 @@
# Avoid Devel::Cover stuff
^cover_db/
-
-# TB2 isn't ready to ship.
-^lib/Test/Builder2/
-^t/Builder2/
3  Makefile.PL
View
@@ -59,9 +59,6 @@ WriteMakefile(
PREREQ_PM => {
Test::Harness => 2.03,
-
- # Make sure this gets removed before release.
-# Mouse => 0.06,
},
# Added to the core in 5.7.3 and also 5.6.2.
228 lib/Test/Builder2/History.pm
View
@@ -1,228 +0,0 @@
-package Test::Builder2::History;
-
-use Carp;
-
-# Can't depend on Mouse, but want to see where we can go with a real OO system.
-use Mouse;
-
-=head1 NAME
-
-Test::Builder2::History - Manage the history of test results
-
-=head1 SYNOPSIS
-
- use Test::Builder2::History;
-
- # This is a shared singleton object
- my $history = Test::Builder2::History->new;
-
- $history->add_test_history( { ok => 1 } );
- $history->is_passing;
-
-=head1 DESCRIPTION
-
-This object stores and manages the history of test results.
-
-
-=head1 METHODS
-
-=head2 Constructors
-
-=head3 new
-
- my $history = Test::Builder2::History->new;
-
-Gets the instance of the history object.
-
-Test::Builder2::History is a singleton. new() will return the same
-object every time so all users can have a shared history. If you want
-your own history, call create() instead.
-
-=cut
-
-sub new {
- my $class = shift;
-
- return $class->singleton || $class->singleton( $class->create );
-}
-
-=head3 create
-
- my $history = Test::Builder2::History->create;
-
-Creates a new, unique History object.
-
-=cut
-
-sub create {
- my $class = shift;
- return $class->SUPER::new(@_);
-}
-
-=head2 Accessors
-
-Unless otherwise stated, these are all accessor methods of the form:
-
- my $value = $history->method; # get
- $history->method($value); # set
-
-=head3 singleton
-
- my $history = Test::Builder2::History->singleton;
- Test::Builder2::History->singleton($history);
-
-Gets/sets the History singleton.
-
-Normally you should never have to call this, but instead get the
-singleton through new().
-
-=cut
-
-# What?! No class variables in Moose?! Now I have to write the
-# accessor by hand, bleh.
-{
- my $singleton;
-
- sub singleton {
- my $class = shift;
-
- if(@_) {
- $singleton = shift;
- }
-
- return $singleton;
- }
-}
-
-=head3 next_test_number
-
-The number of the next test to be run.
-
-Defaults to 1.
-
-=cut
-
-has next_test_number => (
- is => 'rw',
- isa => 'Int',
- default => 1,
-);
-
-=head3 results
-
-An array ref of the test history expressed as Result objects.
-Remember that test 1 is index 0.
-
- # The result of test #4.
- my $result = $history->results->[3];
-
-=cut
-
-has results => (
- is => 'rw',
- isa => 'ArrayRef',
- default => sub { [] },
-);
-
-=head3 should_keep_history
-
-If set to false, no history will be recorded. This is handy for very
-long running tests that might consume a lot of memeory.
-
-Defaults to true.
-
-=cut
-
-has should_keep_history => (
- is => 'rw',
- isa => 'Bool',
- default => 1,
-);
-
-=head2 Other Methods
-
-=head3 add_test_history
-
- $history->add_test_history(@results);
-
-Adds the @results to the existing test history at the point indicated
-by next_test_number(). That's usually the end of the history, but if
-next_test_number() is moved backwards it will overlay existing history.
-
-@results is a list of Result objects.
-
-next_test_number() will be incremented by the number of @results.
-
-=cut
-
-sub add_test_history {
- my $self = shift;
-
- croak "add_test_history() takes Result objects"
- if grep {
- !eval { $_->isa("Test::Builder2::Result::Base") }
- } @_;
-
- my $last_test = $self->next_test_number - 1;
- $self->increment_test_number( scalar @_ );
-
- return 0 unless $self->should_keep_history;
-
- splice @{ $self->results }, $last_test, scalar @_, @_;
-
- return 1;
-}
-
-=head3 increment_test_number
-
- $history->increment_test_number;
- $history->increment_test_number($by_how_much);
-
-A convenience method for incrementing next_test_number().
-
-If $by_how_much is not given it will increment by 1.
-
-=cut
-
-sub increment_test_number {
- my $self = shift;
- my $increment = @_ ? shift : 1;
-
- croak "increment_test_number() takes an integer, not '$increment'"
- unless $increment =~ /^[+-]?\d+$/;
-
- my $num = $self->next_test_number;
- return $self->next_test_number( $num + $increment );
-}
-
-=head3 summary
-
- my @summary = $history->results;
-
-Returns a list of true/false values for each test result indicating if
-it passed or failed.
-
-=cut
-
-sub summary {
- my $self = shift;
-
- return map { $_->passed } @{ $self->results };
-}
-
-=head3 is_passing
-
- my $is_passing = $history->is_passing;
-
-Returns true if all the tests passed, false otherwise.
-
-=cut
-
-sub is_passing {
- my $self = shift;
-
- return (grep { !$_->passed } @{ $self->results }) ? 0 : 1;
-}
-
-1;
-
235 lib/Test/Builder2/Result.pm
View
@@ -1,235 +0,0 @@
-# A factory for test results.
-package Test::Builder2::Result;
-
-use Carp;
-use Mouse;
-my $CLASS = __PACKAGE__;
-
-sub new {
- my( $class, %args ) = @_;
-
- $args{directive} ||= '';
-
- my $result_class = $class->result_class_for( \%args );
-
- # Fall through defaults, because there's no other way to say
- # "if nobody else handled it".
- $result_class ||=
- $args{raw_passed} ? "Test::Builder2::Result::Pass" :
- "Test::Builder2::Result::Fail" ;
-
- return $result_class->new(%args);
-}
-
-=head3 register_result_class
-
- $class->register_result_class($result_class, \&when_to_use);
-
-Tells the Result factory that it should use the $result_class when
-&when_to_use returns true.
-
-=cut
-
-sub register_result_class {
- my( $class, $result_class, $check ) = @_;
-
- $class->_result_type_map->{$result_class} = $check;
-
- return;
-}
-
-=head3 result_class_for
-
- my $result_class = $class->result_class_for(\%args);
-
-Returns the $result_class which should be used for the %args to new().
-
-=cut
-
-sub result_class_for {
- my( $class, $args ) = @_;
-
- my $result_class;
- my $map = $class->_result_type_map;
- while( ( $result_class, my($check) ) = each %$map ) {
- last if $check->($args);
- }
-
- return $result_class;
-}
-
-my %Result_Type_Map = ();
-
-sub _result_type_map {
- return \%Result_Type_Map;
-}
-
-package Test::Builder2::Result::Base;
-
-use Mouse;
-
-sub register_result {
- my( $class, $check ) = @_;
-
- Test::Builder2::Result->register_result_class( $class, $check );
-
- return;
-}
-
-{
- my @keys = qw(
- passed
- raw_passed
- test_number
- description
- location
- id
- directive
- reason
- diagnostic
- );
-
- sub as_hash {
- my $self = shift;
- return {
- map {
- my $val = $self->$_();
- defined $val ? ( $_ => $val ) : ()
- } @keys
- };
- }
-}
-
-# This is the interpreted result of the test.
-# For example "not ok 1 # TODO" is true.
-sub passed {
- my $self = shift;
-
- return $self->raw_passed;
-}
-
-# This is the raw result of the test with no further interpretation.
-# For example "not ok 1 # TODO" is false.
-has raw_passed => (
- is => 'ro',
- isa => 'Bool',
- required => 1,
-);
-
-has test_number => (
- is => 'ro',
- isa => 'Int',
-);
-
-has description => (
- is => 'ro',
- isa => 'Str',
-);
-
-# Instead of "file" use the more generic "location"
-has location => (
- is => 'ro',
- isa => 'Str',
-);
-
-# Instead of "line number", the more generic "id".
-has id => (
- is => 'ro',
- isa => 'Str',
-);
-
-# skip, todo, etc...
-has directive => (
- is => 'ro',
- isa => 'Str',
-);
-
-# the reason associated with the directive
-has reason => (
- is => 'ro',
- isa => 'Str',
-);
-
-# a place to store YAML diagnostics associated with a test
-has diagnostic => (
- is => 'rw',
- isa => 'Test::Builder2::Diagnostic'
-);
-
-{
-
- package Test::Builder2::Result::Pass;
-
- use Mouse;
-
- extends 'Test::Builder2::Result::Base';
-
- sub passed { 1 }
-
- has '+raw_passed' => (
- default => 1
- );
-
- # This is special cased.
- __PACKAGE__->register_result( sub { } );
-}
-
-{
-
- package Test::Builder2::Result::Fail;
-
- use Mouse;
-
- extends 'Test::Builder2::Result::Base';
-
- sub passed { 0 }
-
- has '+raw_passed' => (
- default => 0
- );
-
- # This is special cased.
- __PACKAGE__->register_result( sub { } );
-}
-
-{
-
- package Test::Builder2::Result::Skip;
-
- use Mouse;
-
- # Skip tests always pass
- extends 'Test::Builder2::Result::Pass';
-
- has '+directive' => (
- default => 'skip'
- );
-
- __PACKAGE__->register_result(
- sub {
- my $args = shift;
- return $args->{directive} eq 'skip';
- }
- );
-}
-
-{
-
- package Test::Builder2::Result::Todo;
-
- use Mouse;
-
- # Todo tests always pass
- extends 'Test::Builder2::Result::Pass';
-
- has '+directive' => (
- default => 'todo'
- );
-
- __PACKAGE__->register_result(sub {
- my $args = shift;
- return $args->{directive} eq 'todo';
- });
-}
-
-1;
125 t/Builder2/history.t
View
@@ -1,125 +0,0 @@
-#!/usr/bin/perl -w
-
-use strict;
-use warnings;
-
-use Test::More 'no_plan';
-
-use Test::Builder2::Result;
-
-
-my $CLASS = "Test::Builder2::History";
-require_ok 'Test::Builder2::History';
-
-
-my $Pass = Test::Builder2::Result->new(
- raw_passed => 1
-);
-
-my $Fail = Test::Builder2::Result->new(
- raw_passed => 0
-);
-
-my $create_ok = sub {
- my $history = $CLASS->create;
- isa_ok $history, $CLASS;
- return $history;
-};
-
-
-# Testing initialization
-{
- my $history = $create_ok->();
-
- is $history->next_test_number, 1;
- is_deeply $history->results, [];
- ok $history->should_keep_history;
-}
-
-
-# Test the singleton nature
-{
- my $history1 = new_ok($CLASS);
- my $history2 = new_ok($CLASS);
-
- is $history1, $history2, "new() is a singleton";
- is $history1, $CLASS->singleton, "singleton() get";
-
- $history1->add_test_history($Pass, $Fail);
-
- is_deeply $history1->results, $history2->results;
-
- $CLASS->singleton($create_ok->());
- isnt $history1, $CLASS->singleton, "singleton() set";
- is new_ok($CLASS), $CLASS->singleton, "new() changed";
-}
-
-
-# increment_test_number()
-{
- my $history = $create_ok->();
-
- $history->increment_test_number;
- is $history->next_test_number, 2;
-
- $history->increment_test_number(2);
- is $history->next_test_number, 4;
-
- $history->increment_test_number(-3);
- is $history->next_test_number, 1;
-
- ok !eval {
- $history->increment_test_number(1.1);
- };
- is $@, sprintf "increment_test_number\(\) takes an integer, not '1.1' at %s line %d\n",
- $0, __LINE__ - 3;
-}
-
-
-# add_test_history
-{
- my $history = $create_ok->();
-
- $history->add_test_history( $Pass );
- is_deeply $history->results, [$Pass];
- is_deeply [$history->summary], [1];
-
- is $history->next_test_number, 2;
- ok $history->is_passing;
-
- $history->add_test_history( $Pass, $Fail );
- is_deeply $history->results, [
- $Pass, $Pass, $Fail
- ];
- is_deeply [$history->summary], [1, 1, 0];
-
- is $history->next_test_number, 4;
- ok !$history->is_passing;
-
- # Try a history replacement
- $history->next_test_number(3);
- $history->add_test_history( $Pass, $Pass );
- is_deeply [$history->summary], [1, 1, 1, 1];
-}
-
-
-# add_test_history argument checks
-{
- my $history = $create_ok->();
-
- ok !eval {
- $history->add_test_history($Pass, { passed => 1 }, $Fail);
- };
- like $@, qr/takes Result objects/;
-}
-
-
-# should_keep_history
-{
- my $history = $create_ok->();
-
- $history->should_keep_history(0);
- $history->add_test_history( $Pass );
- is $history->next_test_number, 2;
- is_deeply $history->results, [];
-}
151 t/Builder2/result.t
View
@@ -1,151 +0,0 @@
-#!/usr/bin/perl -w
-
-use strict;
-use warnings;
-
-use Test::More 'no_plan';
-
-my $CLASS = 'Test::Builder2::Result';
-require_ok $CLASS;
-
-my $new_ok = sub {
- my $result = $CLASS->new(@_);
- isa_ok $result, 'Test::Builder2::Result::Base';
- return $result;
-};
-
-
-# Pass
-{
- my $result = $new_ok->( raw_passed => 1 );
- isa_ok $result, "Test::Builder2::Result::Pass";
-
- ok $result->passed;
- ok $result->raw_passed;
-}
-
-
-# Fail
-{
- my $result = $new_ok->( raw_passed => 0 );
- isa_ok $result, "Test::Builder2::Result::Fail";
-
- ok !$result->passed;
- ok !$result->raw_passed;
-}
-
-
-# Skip
-{
- my $result = $new_ok->(
- directive => 'skip',
- );
- isa_ok $result, "Test::Builder2::Result::Skip";
-
- ok $result->passed;
- ok $result->raw_passed;
- is $result->directive, 'skip';
-}
-
-
-# TODO
-{
- my $result = $new_ok->(
- directive => 'todo',
- raw_passed => 0
- );
- isa_ok $result, "Test::Builder2::Result::Todo";
-
- ok $result->passed;
- ok !$result->raw_passed;
- is $result->directive, 'todo';
-}
-
-
-# Unknown directive, pass
-{
- my $result = $new_ok->(
- directive => 'omega',
- raw_passed => 1
- );
-
- isa_ok $result, "Test::Builder2::Result::Pass";
-
- ok $result->passed;
- ok $result->raw_passed;
- is $result->directive, 'omega';
-}
-
-
-# Unknown directive, fail
-{
- my $result = $new_ok->(
- directive => 'omega',
- raw_passed => 0
- );
-
- isa_ok $result, "Test::Builder2::Result::Fail";
-
- ok !$result->passed;
- ok !$result->raw_passed;
- is $result->directive, 'omega';
-}
-
-
-# as_hash
-{
- my $result = $new_ok->(
- raw_passed => 1,
- description => 'something something something test result',
- test_number => 23,
- location => 'foo.t',
- id => 0,
- directive => '',
- );
-
- is_deeply $result->as_hash, {
- raw_passed => 1,
- description => 'something something something test result',
- test_number => 23,
- passed => 1,
- location => 'foo.t',
- id => 0,
- directive => '',
- }, 'as_hash';
-}
-
-
-# Register a new result type
-{
- {
- package TB2::Result::NoTest;
-
- use Mouse;
-
- extends 'Test::Builder2::Result::Todo';
-
- __PACKAGE__->register_result(sub {
- my $args = shift;
- return $args->{directive} eq 'notest';
- });
- }
-
- my $result = $new_ok->(
- raw_passed => 1,
- description => 'something something something test result',
- test_number => 23,
- location => 'foo.t',
- id => 0,
- directive => '',
- );
-
- is_deeply $result->as_hash, {
- raw_passed => 1,
- description => 'something something something test result',
- test_number => 23,
- passed => 1,
- location => 'foo.t',
- id => 0,
- directive => '',
- }, 'as_hash';
-}
Please sign in to comment.
Something went wrong with that request. Please try again.