Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch 'Test-Builder1.5' into history/store_events_switch

Conflicts:
	lib/TB2/Mouse.pm

TB2::Mouse already has our patch.
  • Loading branch information...
commit 4c4a273ae2d06bab8847228dbce9fdf7817b0cfa 2 parents b5c2bf8 + 88633a0
@schwern schwern authored
View
4 Changes
@@ -1,4 +1,3 @@
-<<<<<<< HEAD
See README and version control log for Test::Builder2 changes.
1.005000_006 Fri Apr 12 18:01:09 BST 2013
@@ -310,8 +309,6 @@ See README and version control log for Test::Builder2 changes.
Very incomplete.
-0.98_04
-=======
0.98_05
Doc Changes
* Add a shorter work around for the UTF-8 output problem.
@@ -324,7 +321,6 @@ See README and version control log for Test::Builder2 changes.
0.98_04 Sun Apr 14 10:54:13 BST 2013
->>>>>>> master
Distribution Changes
* Scalar::Util 1.13 (ships with Perl 5.8.1) is now required.
(Michael G Schwern)
View
46 dist/eat_mouse
@@ -5,14 +5,14 @@
# To upgrade Mouse:
# * Get the copy of Mouse you want
# * Build it
-# * Copy /path/to/Mouse/blib/lib/Mouse/Tiny.pm into lib/TB2/
+# * Copy /path/to/Mouse/blib/lib/Mouse/Tiny.pm into lib/TB2/Mouse.pm
# * Run eat_mouse
+# * git diff and check that it looks ok
+# * make test
use strict;
use warnings;
-use File::Find;
-
main();
sub run {
@@ -22,29 +22,21 @@ sub run {
}
sub main {
- my @files;
- find(
- {
- wanted => sub { push @files, $_ if /\bMouse\b/ && /\.(pm|pod)/ },
- no_chdir => 1
- }, "lib/TB2/"
- );
-
- for my $file (@files) {
- # Change all instances of Mouse to TB2::Mouse
- # and Mouse/Blah to TB2/Mouse/Blah
- run $^X, "-i", "-pe", q[s{Mouse.pm}{TB2/Mouse.pm}g], $file;
- run $^X, "-i", "-pe", q[s{Mouse/}{TB2/Mouse/}g], $file;
- run $^X, "-i", "-pe", q[s{Mouse::}{TB2::Mouse::}g], $file;
-
- # Special case for "use Mouse ()"
- run $^X, "-i", "-pe", q[s{use Mouse }{use TB2::Mouse }], $file;
-
- # Special case for 'Mouse' and 'Mouse::Foo'
- run $^X, "-i", "-pe", q[s{(['"])(Mouse[:\w+]*)\1}{$1TB2::$2$1}], $file;
-
- # Special case for "package Mouse;"
- run $^X, "-i", "-pe", q[s{package Mouse;}{package TB2::Mouse;}], $file;
- }
+ my $file = 'lib/TB2/Mouse.pm';
+
+ # Change all instances of Mouse to TB2::Mouse
+ # and Mouse/Blah to TB2/Mouse/Blah
+ run $^X, "-i", "-pe", q[s{Mouse.pm}{TB2/Mouse.pm}g], $file;
+ run $^X, "-i", "-pe", q[s{Mouse/}{TB2/Mouse/}g], $file;
+ run $^X, "-i", "-pe", q[s{Mouse::}{TB2::Mouse::}g], $file;
+
+ # Special case for "use Mouse ()"
+ run $^X, "-i", "-pe", q[s{use Mouse }{use TB2::Mouse }], $file;
+
+ # Special case for 'Mouse' and 'Mouse::Foo'
+ run $^X, "-i", "-pe", q[s{(['"])(Mouse[:\w+]*)\1}{$1TB2::$2$1}g], $file;
+
+ # Special case for "package Mouse;"
+ run $^X, "-i", "-pe", q[s{package Mouse;}{package TB2::Mouse;}], $file;
}
View
41 dist/test_dists
@@ -8,15 +8,20 @@
use perl5i::2;
use CPAN;
+use IPC::Run qw(run timeout);
use Test::More;
use Path::Tiny 0.018;
use Getopt::Long;
-my $mirror = "file:///var/local/CPAN_mirror";
+my $mirror = "file:///var/local/CPAN_mirror";
my $lib_path = "/tmp/tb2/lib/perl5";
+my $timeout = 60*5;
my $nomirror;
-my $result = GetOptions ("nomirror" => \$nomirror,
- "mirror=s" => \$mirror, # numeric
- "lib=s" => \$lib_path);
+GetOptions(
+ "nomirror" => \$nomirror,
+ "mirror=s" => \$mirror,
+ "lib=s" => \$lib_path,
+ "timeout=i" => \$timeout,
+);
CPAN::HandleConfig->load;
@@ -26,10 +31,12 @@ my %skip_dists = map { chomp; $_ => 1 } <DATA>;
sub get_distributions {
my $match = shift;
- return map { $_->pretty_id } CPAN::Shell->expand("Distribution", $match);
+ my @dists = grep { defined $_ } map { $_->distribution } CPAN::Shell->expand("Module", $match);
+ my %unique_dists = map { ($_->pretty_id => 1) } @dists;
+ return keys %unique_dists;
}
-my @dist_list = @ARGV ? @ARGV : get_distributions("/Test-/");
+my @dist_list = @ARGV ? @ARGV : get_distributions("/Test/");
my @failed_dists;
@@ -54,15 +61,15 @@ for my $dist (@dist_list->shuffle) {
my $test_out;
eval {
- local $SIG{ALRM} = sub { die "Alarm!\n" };
- alarm 60*5;
my $mirror_settings = '';
$mirror_settings = "--mirror $mirror --mirror-only" unless $nomirror;
- $test_out = `cpanm $mirror_settings --test-only $mod_name 2>&1`;
- alarm 0;
+ run [("cpanm", $mirror_settings, "--test-only", $mod_name)],
+ \undef, \$test_out, \$test_out,
+ timeout($timeout);
};
if( $@ ) {
- push @results, $@;
+ note "Test died with $@";
+ push @results, 0;
}
else {
push @results, ($test_out =~ /^Building and testing .* OK$/ms) ? 1 : 0;
@@ -73,8 +80,9 @@ for my $dist (@dist_list->shuffle) {
# Save the build log.
my $mod_file = $mod_name =~ s/::/-/gr;
my $lib_id = $perl5lib =~ s/\//-/gr;
- my $new_file = $temp->child("$mod_file-$lib_id-build.log");
- path('~/.cpanm/latest-build/build.log')->copy($new_file);
+ my $latest_build_log = '~/.cpanm/latest-build/build.log';
+ my $save_build_log = $temp->child("$mod_file-$lib_id-build.log");
+ path($latest_build_log)->copy($save_build_log) if -e $latest_build_log;
}
is( $results[0], $results[1], "$mod_name - install vs dev" ) || push @failed_dists, $mod_name;
@@ -88,3 +96,10 @@ note "$_" for @failed_dists;
__DATA__
Test::Presenter
Test::Harness::FileFilter
+mod_perl
+Tapper::CLI
+Genome
+YATT
+CommitBit
+Net::DNS::TestNS
+Net::Statsd::Server
View
83 lib/TB2/CanAsHash.pm
@@ -0,0 +1,83 @@
+package TB2::CanAsHash;
+
+use TB2::Mouse ();
+use TB2::Mouse::Role;
+use Scalar::Util ();
+with 'TB2::CanTry';
+
+
+=head1 NAME
+
+TB2::CanAsHash - a role to dump an object as a hash
+
+=head1 SYNOPSIS
+
+ package Some::Object;
+
+ use TB2::Mouse;
+ with 'TB2::CanAsHash';
+
+
+=head2 Methods
+
+=head3 as_hash
+
+ my $data = $object->as_hash;
+
+Returns all the attributes and data associated with this C<$object> as
+a hash of attributes and values.
+
+Attributes with undefined values will not be dumped.
+
+It is recursive, objects encountered will have their as_hash method
+called, if they have one.
+
+The intent is to provide a way to dump all the information in an
+object without having to call methods which may or may not exist.
+
+Uses L</keys_for_as_hash> to determine which attributes to access.
+
+=cut
+
+sub as_hash {
+ my $self = shift;
+
+ my %hash;
+ for my $key (@{$self->keys_for_as_hash}) {
+ my $val = $self->$key();
+
+ next unless defined $val;
+
+ $val = $val->as_hash if defined Scalar::Util::blessed($val) && $val->can("as_hash");
+
+ $hash{$key} = $val if defined $val;
+ }
+
+ return \%hash;
+}
+
+
+=head3 keys_for_as_hash
+
+ my $keys = $object->keys_for_as_hash;
+
+Returns an array ref of keys for C<as_hash> to use as keys and methods
+to call on the $object for the key's value.
+
+By default it uses the $object's non-private attributes. That should
+be sufficient for most cases.
+
+=cut
+
+my %Attributes;
+sub keys_for_as_hash {
+ my $self = shift;
+ my $class = ref $self;
+ return $Attributes{$class} ||= [
+ grep !/^_/, map { $_->name } $class->meta->get_all_attributes
+ ];
+}
+
+no TB2::Mouse::Role;
+
+1;
View
46 lib/TB2/Event.pm
@@ -3,7 +3,7 @@ package TB2::Event;
use TB2::Mouse ();
use TB2::Mouse::Role;
use TB2::Types;
-with 'TB2::HasObjectID';
+with 'TB2::HasObjectID', 'TB2::CanAsHash';
requires qw( build_event_type );
@@ -118,52 +118,16 @@ underscores.
Used to build C<event_type>
+
=head2 Provided Methods
=head3 as_hash
- my $data = $event->as_hash;
-
-Returns all the attributes and data associated with this C<$event> as
-a hash of attributes and values.
-
-The intent is to provide a way to dump all the information in an Event
-without having to call methods which may or may not exist.
-
-=cut
-
-sub as_hash {
- my $self = shift;
- return {
- map {
- my $val = $self->$_();
- defined $val ? ( $_ => $val ) : ()
- } @{$self->keys_for_as_hash}
- };
-}
-
+See L<TB2::CanAsHash/as_hash> for details.
-=head3 keys_for_hash
-
- my $keys = $event->keys_for_hash;
-
-Returns an array ref of keys for C<as_hash> to use as keys and methods
-to call on the object for the key's value.
-
-By default it uses the object's non-private attributes. That should
-be sufficient for most events.
-
-=cut
-
-my %Attributes;
-sub keys_for_as_hash {
- my $self = shift;
- my $class = ref $self;
- return $Attributes{$class} ||= [
- grep !/^_/, map { $_->name } $class->meta->get_all_attributes
- ];
-}
+=head3 keys_for_as_hash
+See L<TB2::CanAshash/keys_for_as_hash> for details.
=head3 copy_context
View
62 lib/TB2/Event/Generic.pm
@@ -0,0 +1,62 @@
+package TB2::Event::Generic;
+
+use strict;
+use warnings;
+
+use Carp;
+use TB2::Mouse;
+with 'TB2::Event';
+
+
+=head1 NAME
+
+TB2::Event::Generic - A container for any type of event
+
+=head1 SYNOPSIS
+
+ use TB2::Event::Generic;
+
+ my $event = TB2::Event::Generic->new( $event->as_hash );
+
+=head1 DESCRIPTION
+
+This is a container for any type of event. Its primary purpose is to
+receive events serialized using C<< TB2::Event->as_hash >>.
+
+All attributes are read only.
+
+=head1 SEE ALSO
+
+See L<TB2::Formatter::JSON> for an example of use.
+
+=cut
+
+
+sub build_event_type {
+ croak("The event_type must be defined in the constructor");
+}
+
+# Ensure that all attributes are dumped via as_hash
+my @Attributes = grep !/^_/, map { $_->name } __PACKAGE__->meta->get_all_attributes;
+sub keys_for_as_hash {
+ my $self = shift;
+
+ return \@Attributes;
+}
+
+sub BUILDARGS {
+ my $class = shift;
+ my %args = @_;
+
+ # Generate attributes for whatever they pass in
+ for my $attribute (keys %args) {
+ next if $class->can($attribute);
+ has $attribute =>
+ is => 'ro';
+ push @Attributes, $attribute;
+ }
+
+ return \%args;
+}
+
+1;
View
31 lib/TB2/Events.pm
@@ -6,17 +6,26 @@ use warnings;
our $VERSION = '1.005000_006';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-use TB2::Event::TestStart;
-use TB2::Event::TestEnd;
-use TB2::Event::SubtestStart;
-use TB2::Event::SubtestEnd;
-use TB2::Event::SetPlan;
-use TB2::Event::TestMetadata;
-use TB2::Event::Log;
-use TB2::Event::Comment;
-use TB2::Event::Abort;
-use TB2::Result;
+sub event_classes {
+ return qw(
+ TB2::Event::TestStart
+ TB2::Event::TestEnd
+ TB2::Event::SubtestStart
+ TB2::Event::SubtestEnd
+ TB2::Event::SetPlan
+ TB2::Event::TestMetadata
+ TB2::Event::Log
+ TB2::Event::Comment
+ TB2::Event::Abort
+ TB2::Result
+ );
+}
+
+BEGIN {
+ for my $class (__PACKAGE__->event_classes) {
+ eval "require $class" or die $@;
+ }
+}
=head1 NAME
View
92 lib/TB2/Formatter/JSON.pm
@@ -0,0 +1,92 @@
+package TB2::Formatter::JSON;
+
+use TB2::Mouse;
+extends "TB2::Formatter";
+
+
+=head1 NAME
+
+TB2::Formatter::JSON - Output event objects as a JSON list
+
+=head1 DESCRIPTION
+
+This formatter outputs all events as a list of JSON items. The
+items are events dumped using C<< TB2::Event->as_hash >>. These
+events can be restored as L<TB2::Event::Generic> objects.
+
+ use TB2::Event::Generic;
+ use JSON;
+
+ my @$events_as_hash = decode_json( $events_as_json );
+ my @events = map { TB2::Event::Generic->new( $_ ) } @$events_as_hash;
+
+This is useful for debugging or as an interprocess communication
+mechanism. The reader of the JSON stream will have all the same
+information as an event handler does.
+
+Set the TB2_FORMATTER_CLASS environment variable to
+TB2::Formatter::JSON.
+
+=head1 NOTES
+
+Requires JSON::PP which is not a requirement of Test::More. This
+module will likely be split out of the Test-Simple distribution. If
+you use it, be sure to declare it.
+
+=cut
+
+{
+ my $json;
+ sub json {
+ require JSON::PP;
+ $json ||= JSON::PP->new
+ ->utf8
+ ->pretty
+ ->allow_unknown
+ ->allow_blessed;
+
+ return $json;
+ }
+}
+
+sub handle_test_start {
+ my $self = shift;
+ my($event, $ec) = @_;
+
+ $self->write(out => "[\n");
+ $self->_event2json($event);
+
+ return;
+}
+
+sub handle_test_end {
+ my $self = shift;
+ my($event, $ec) = @_;
+
+ $self->write(out => ",\n");
+ $self->_event2json($event);
+ $self->write(out => "]\n");
+
+ return;
+}
+
+sub handle_event {
+ my $self = shift;
+ my($event, $ec) = @_;
+
+ $self->write(out => ",\n");
+ $self->_event2json($event);
+
+ return;
+}
+
+sub _event2json {
+ my $self = shift;
+ my($event) = @_;
+
+ $self->write(out => $self->json->encode($event->as_hash) );
+
+ return;
+}
+
+1;
View
34 lib/TB2/History.pm
@@ -8,7 +8,8 @@ use TB2::threads::shared;
with 'TB2::EventHandler',
'TB2::CanTry',
- 'TB2::CanLoad';
+ 'TB2::CanLoad',
+ 'TB2::CanAsHash';
our $VERSION = '1.005000_006';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -514,7 +515,8 @@ sub in_test {
my $self = shift;
return 0 if $self->abort;
- return $self->test_start && !$self->test_end;
+ return 1 if $self->test_start && !$self->test_end;
+ return 0;
}
@@ -531,7 +533,8 @@ sub done_testing {
my $self = shift;
return 0 if $self->abort;
- return $self->test_start && $self->test_end;
+ return 1 if $self->test_start && $self->test_end;
+ return 0;
}
@@ -721,6 +724,31 @@ sub consume {
$self->accept_event($_) for @{ $old_history->events };
return;
+}
+
+
+my %Keys_To_Remove = map { $_ => 1 } qw(
+ event_storage
+ store_events
+ last_event
+ last_result
+);
+my @Keys_To_Add = qw(
+ subtest_depth
+ is_subtest
+ is_child_process
+ in_test
+ done_testing
+
+ can_succeed
+ test_was_successful
+);
+around keys_for_as_hash => sub {
+ my $orig = shift;
+ my $self = shift;
+
+ my @keys = grep { !$Keys_To_Remove{$_} } @{ $self->$orig };
+ return [ @keys, @Keys_To_Add ];
};
View
424 lib/TB2/Mouse.pm
@@ -1,39 +1,39 @@
-# This file was generated by Mouse::Maker 0.12 from Mouse 0.87.
+# This file was generated by tool/generate-mouse-tiny.pl from Mouse 1.08.
#
# ANY CHANGES MADE HERE WILL BE LOST!
use strict;
use warnings;
-# tell Perl we already have all of the TB2::Mouse files loaded:
-BEGIN {
- $INC{'TB2/Mouse.pm'} = __FILE__;
- $INC{'TB2/Mouse/Role.pm'} = __FILE__;
- $INC{'TB2/Mouse/Util.pm'} = __FILE__;
- $INC{'TB2/Mouse/Exporter.pm'} = __FILE__;
- $INC{'TB2/Mouse/PurePerl.pm'} = __FILE__;
- $INC{'TB2/Mouse/Object.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Class.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Method.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/TypeConstraint.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Attribute.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Role.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Module.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Method/Delegation.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Method/Destructor.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Method/Accessor.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Method/Constructor.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Role/Method.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Role/Composite.pm'} = __FILE__;
- $INC{'TB2/Mouse/Meta/Role/Application.pm'} = __FILE__;
- $INC{'TB2/Mouse/Util/TypeConstraints.pm'} = __FILE__;
- $INC{'TB2/Mouse/Util/MetaRole.pm'} = __FILE__;
-}
+{
+# tell Perl we already have all of the Mouse files loaded:
+$INC{'TB2/Mouse.pm'} = __FILE__;
+$INC{'TB2/Mouse/Exporter.pm'} = __FILE__;
+$INC{'TB2/Mouse/Object.pm'} = __FILE__;
+$INC{'TB2/Mouse/PurePerl.pm'} = __FILE__;
+$INC{'TB2/Mouse/Role.pm'} = __FILE__;
+$INC{'TB2/Mouse/Util.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Attribute.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Class.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Method.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Module.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Role.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/TypeConstraint.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Method/Accessor.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Method/Constructor.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Method/Delegation.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Method/Destructor.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Role/Application.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Role/Composite.pm'} = __FILE__;
+$INC{'TB2/Mouse/Meta/Role/Method.pm'} = __FILE__;
+$INC{'TB2/Mouse/Util/MetaRole.pm'} = __FILE__;
+$INC{'TB2/Mouse/Util/TypeConstraints.pm'} = __FILE__;
+eval sprintf("#line %d %s\n", __LINE__, __FILE__) . <<'END_OF_TINY';
# and now their contents
-# Contents of Mouse::PurePerl
+BEGIN{ # lib/TB2/Mouse/PurePerl.pm
package TB2::Mouse::PurePerl;
-# The pure Perl backend for Mousse
+# The pure Perl backend for Mouse
package TB2::Mouse::Util;
use strict;
use warnings;
@@ -471,7 +471,12 @@ sub handles { $_[0]->{handles} }
sub _is_metadata { $_[0]->{is} }
sub is_required { $_[0]->{required} }
-sub default { $_[0]->{default} }
+sub default {
+ my($self, $instance) = @_;
+ my $value = $self->{default};
+ $value = $value->($instance) if defined($instance) and ref($value) eq "CODE";
+ return $value;
+}
sub is_lazy { $_[0]->{lazy} }
sub is_lazy_build { $_[0]->{lazy_build} }
sub is_weak_ref { $_[0]->{weak_ref} }
@@ -519,7 +524,7 @@ sub _process_options{
if(exists $args->{builder}){
# XXX:
- # Moose refuses a CODE ref builder, but TB2::Mouse doesn't for backward compatibility
+ # Moose refuses a CODE ref builder, but Mouse doesn't for backward compatibility
# This feature will be changed in a future. (gfx)
$class->throw_error('builder must be a defined scalar value which is a method name')
#if ref $args->{builder} || !defined $args->{builder};
@@ -687,13 +692,13 @@ sub compile_type_constraint{
}
else{
$self->{compiled_type_constraint} = sub{
- my(@args) = @_;
- for ($args[0]) {
- foreach my $c(@checks){
- return undef if !$c->(@args);
- }
- }
- return 1;
+ my(@args) = @_;
+ for ($args[0]) { # local $_ will cancel tie-ness due to perl's bug
+ foreach my $c(@checks){
+ return undef if !$c->(@args);
+ }
+ }
+ return 1;
};
}
return;
@@ -747,7 +752,7 @@ sub DESTROY {
my $demolish = TB2::Mouse::Util::get_code_ref($class, 'DEMOLISH')
|| next;
- $self->$demolish($TB2::Mouse::Util::in_global_destruction);
+ $self->$demolish(TB2::Mouse::Util::in_global_destruction());
}
};
$@;
@@ -775,26 +780,29 @@ sub BUILDALL {
sub DEMOLISHALL;
*DEMOLISHALL = \&DESTROY;
-# Contents of Mouse::Exporter
+}
+BEGIN{ # lib/TB2/Mouse/Exporter.pm
package TB2::Mouse::Exporter;
use strict;
use warnings;
-
use Carp ();
my %SPEC;
my $strict_bits;
-BEGIN{ $strict_bits = strict::bits(qw(subs refs vars)); }
-
my $warnings_extra_bits;
-BEGIN{ $warnings_extra_bits = warnings::bits(FATAL => 'recursion') }
+BEGIN{
+ $strict_bits = strict::bits(qw(subs refs vars));
+ $warnings_extra_bits = warnings::bits(FATAL => 'recursion');
+}
# it must be "require", because TB2::Mouse::Util depends on TB2::Mouse::Exporter,
# which depends on TB2::Mouse::Util::import()
require TB2::Mouse::Util;
sub import{
+ ## no critic ProhibitBitwiseOperators
+
# strict->import;
$^H |= $strict_bits;
# warnings->import('all', FATAL => 'recursion');
@@ -947,10 +955,10 @@ sub do_import {
}
# strict->import;
- $^H |= $strict_bits;
+ $^H |= $strict_bits; ## no critic ProhibitBitwiseOperators
# warnings->import('all', FATAL => 'recursion');
- ${^WARNING_BITS} |= $warnings::Bits{all};
- ${^WARNING_BITS} |= $warnings_extra_bits;
+ ${^WARNING_BITS} |= $warnings::Bits{all}; ## no critic ProhibitBitwiseOperators
+ ${^WARNING_BITS} |= $warnings_extra_bits; ## no critic ProhibitBitwiseOperators
if($spec->{INIT_META}){
my $meta;
@@ -968,7 +976,7 @@ sub do_import {
require TB2::Mouse::Util::MetaRole;
TB2::Mouse::Util::MetaRole::apply_metaroles(
- for => $into,
+ for => $into,
TB2::Mouse::Util::is_a_metarole($into->meta)
? (role_metaroles => { role => \@traits })
: (class_metaroles => { class => \@traits }),
@@ -1012,7 +1020,9 @@ sub do_unimport {
for my $keyword (@{ $spec->{REMOVABLES} }) {
next if !exists $stash->{$keyword};
my $gv = \$stash->{$keyword};
- if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us
+
+ # remove what is from us
+ if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){
delete $stash->{$keyword};
}
}
@@ -1034,12 +1044,12 @@ sub _get_caller_package {
}
}
-#sub _spec{ %SPEC }
-
-# Contents of Mouse::Util
+}
+BEGIN{ # lib/TB2/Mouse/Util.pm
package TB2::Mouse::Util;
use TB2::Mouse::Exporter; # enables strict and warnings
-no warnings 'once';
+
+# Note that those which don't exist here are defined in XS or TB2::Mouse::PurePerl
# must be here because it will be refered by other modules loaded
sub get_linear_isa($;$); ## no critic
@@ -1083,16 +1093,16 @@ BEGIN{
groups => {
default => [], # export no functions by default
- # The ':meta' group is 'use metaclass' for Mousse
+ # The ':meta' group is 'use metaclass' for Mouse
meta => [qw(does meta dump throw_error)],
},
);
- our $VERSION = '1.005000_005';
+ our $VERSION = '1.08';
my $xs = !(defined(&is_valid_class_name) || $ENV{MOUSE_PUREPERL} || $ENV{PERL_ONLY});
- # Because TB2::Mouse::Util is loaded first in all the TB2::Mouse sub-modules,
+ # Because TB2::Mouse::Util is loaded first in all the Mouse sub-modules,
# XSLoader must be placed here, not in TB2/Mouse.pm.
if($xs){
# XXX: XSLoader tries to get the object path from caller's file name
@@ -1115,62 +1125,14 @@ BEGIN{
}
*MOUSE_XS = sub(){ $xs };
-}
-
-use Carp ();
-use Scalar::Util ();
-
-# aliases as public APIs
-# it must be 'require', not 'use', because TB2::Mouse::Meta::Module depends on TB2::Mouse::Util
-require TB2::Mouse::Meta::Module; # for the entities of metaclass cache utilities
-
-# aliases
-{
- *class_of = \&TB2::Mouse::Meta::Module::_class_of;
- *get_metaclass_by_name = \&TB2::Mouse::Meta::Module::_get_metaclass_by_name;
- *get_all_metaclass_instances = \&TB2::Mouse::Meta::Module::_get_all_metaclass_instances;
- *get_all_metaclass_names = \&TB2::Mouse::Meta::Module::_get_all_metaclass_names;
-
- *TB2::Mouse::load_class = \&load_class;
- *TB2::Mouse::is_class_loaded = \&is_class_loaded;
-
- # is-a predicates
- #generate_isa_predicate_for('TB2::Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
- #generate_isa_predicate_for('TB2::Mouse::Meta::Class' => 'is_a_metaclass');
- #generate_isa_predicate_for('TB2::Mouse::Meta::Role' => 'is_a_metarole');
-
- # duck type predicates
- generate_can_predicate_for(['_compiled_type_constraint'] => 'is_a_type_constraint');
- generate_can_predicate_for(['create_anon_class'] => 'is_a_metaclass');
- generate_can_predicate_for(['create_anon_role'] => 'is_a_metarole');
-}
-
-our $in_global_destruction = 0;
-END{ $in_global_destruction = 1 }
-
-# Moose::Util compatible utilities
-
-sub find_meta{
- return class_of( $_[0] );
-}
-
-sub does_role{
- my ($class_or_obj, $role_name) = @_;
-
- my $meta = class_of($class_or_obj);
-
- (defined $role_name)
- || ($meta || 'TB2::Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
- return defined($meta) && $meta->does_role($role_name);
-}
-
-BEGIN {
+ # definition of mro::get_linear_isa()
my $get_linear_isa;
- if ($] >= 5.009_005) {
+ if ($] >= 5.010_000) {
require mro;
$get_linear_isa = \&mro::get_linear_isa;
- } else {
+ }
+ else {
# this code is based on MRO::Compat::__get_linear_isa
my $_get_linear_isa_dfs; # this recurses so it isn't pretty
$_get_linear_isa_dfs = sub {
@@ -1218,6 +1180,75 @@ BEGIN {
*get_linear_isa = $get_linear_isa;
}
+use Carp ();
+use Scalar::Util ();
+
+# aliases as public APIs
+# it must be 'require', not 'use', because TB2::Mouse::Meta::Module depends on TB2::Mouse::Util
+require TB2::Mouse::Meta::Module; # for the entities of metaclass cache utilities
+
+# aliases
+{
+ *class_of = \&TB2::Mouse::Meta::Module::_class_of;
+ *get_metaclass_by_name = \&TB2::Mouse::Meta::Module::_get_metaclass_by_name;
+ *get_all_metaclass_instances = \&TB2::Mouse::Meta::Module::_get_all_metaclass_instances;
+ *get_all_metaclass_names = \&TB2::Mouse::Meta::Module::_get_all_metaclass_names;
+
+ *TB2::Mouse::load_class = \&load_class;
+ *TB2::Mouse::is_class_loaded = \&is_class_loaded;
+
+ # is-a predicates
+ #generate_isa_predicate_for('TB2::Mouse::Meta::TypeConstraint' => 'is_a_type_constraint');
+ #generate_isa_predicate_for('TB2::Mouse::Meta::Class' => 'is_a_metaclass');
+ #generate_isa_predicate_for('TB2::Mouse::Meta::Role' => 'is_a_metarole');
+
+ # duck type predicates
+ generate_can_predicate_for(['_compiled_type_constraint'] => 'is_a_type_constraint');
+ generate_can_predicate_for(['create_anon_class'] => 'is_a_metaclass');
+ generate_can_predicate_for(['create_anon_role'] => 'is_a_metarole');
+}
+
+sub in_global_destruction;
+
+if (defined ${^GLOBAL_PHASE}) {
+ *in_global_destruction = sub {
+ return ${^GLOBAL_PHASE} eq 'DESTRUCT';
+ };
+}
+else {
+ my $in_global_destruction = 0;
+ END { $in_global_destruction = 1 }
+ *in_global_destruction = sub {
+ return $in_global_destruction;
+ };
+}
+
+# Moose::Util compatible utilities
+
+sub find_meta{
+ return class_of( $_[0] );
+}
+
+sub _does_role_impl {
+ my ($class_or_obj, $role_name) = @_;
+
+ my $meta = class_of($class_or_obj);
+
+ (defined $role_name)
+ || ($meta || 'TB2::Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
+
+ return defined($meta) && $meta->does_role($role_name);
+}
+
+sub does_role {
+ my($thing, $role_name) = @_;
+
+ if( (Scalar::Util::blessed($thing) || is_class_loaded($thing))
+ && $thing->can('does')) {
+ return $thing->does($role_name);
+ }
+ goto &_does_role_impl;
+}
# taken from TB2::Mouse::Util (0.90)
{
@@ -1252,6 +1283,7 @@ sub get_code_info;
sub get_code_package;
sub is_valid_class_name;
+sub is_class_loaded;
# taken from Class/MOP.pm
sub load_first_existing_class {
@@ -1310,7 +1342,6 @@ sub load_class {
return $class;
}
-sub is_class_loaded;
sub apply_all_roles {
my $consumer = Scalar::Util::blessed($_[0])
@@ -1339,7 +1370,7 @@ sub apply_all_roles {
push @roles, [ $role => undef ];
}
is_a_metarole($role)
- || $consumer->meta->throw_error("You can only consume roles, $role_name is not a TB2::Mouse role");
+ || $consumer->meta->throw_error("You can only consume roles, $role_name is not a Mouse role");
}
if ( scalar @roles == 1 ) {
@@ -1377,7 +1408,7 @@ sub not_supported{
$feature ||= ( caller(1) )[3] . '()'; # subroutine name
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
- Carp::confess("TB2::Mouse does not currently support $feature");
+ Carp::confess("Mouse does not currently support $feature");
}
# general meta() method
@@ -1416,10 +1447,11 @@ sub dump :method {
# general does() method
sub does :method {
- goto &does_role;
+ goto &_does_role_impl;
}
-# Contents of Mouse::Meta::TypeConstraint
+}
+BEGIN{ # lib/TB2/Mouse/Meta/TypeConstraint.pm
package TB2::Mouse::Meta::TypeConstraint;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
@@ -1571,7 +1603,7 @@ sub _compiled_type_coercion {
foreach my $pair (@coercions) {
#my ($constraint, $converter) = @$pair;
if ($pair->[0]->($thing)) {
- return $pair->[1]->($thing) for $thing;
+ return $pair->[1]->($thing) for $thing; # local $_ will cancel tie-ness due to perl's bug
}
}
return $thing;
@@ -1611,7 +1643,7 @@ sub coerce {
sub get_message {
my ($self, $value) = @_;
if ( my $msg = $self->message ) {
- return $msg->($value) for $value;
+ return $msg->($value) for $value; # local $_ will cancel tie-ness due to perl's bug
}
else {
if(not defined $value) {
@@ -1687,7 +1719,8 @@ sub _unite { # overload infix:<|>
);
}
-# Contents of Mouse::Util::TypeConstraints
+}
+BEGIN{ # lib/TB2/Mouse/Util/TypeConstraints.pm
package TB2::Mouse::Util::TypeConstraints;
use TB2::Mouse::Util; # enables strict and warnings
@@ -1702,7 +1735,7 @@ TB2::Mouse::Exporter->setup_import_methods(
as where message optimize_as
from via
- type subtype class_type role_type duck_type
+ type subtype class_type role_type maybe_type duck_type
enum
coerce
@@ -1830,7 +1863,7 @@ sub _define_type {
my $this = $args{package_defined_in};
if(!$this){
$this = caller(1);
- if($this !~ /\A TB2::Mouse \b/xms){
+ if($this !~ /\A Mouse \b/xms){
$args{package_defined_in} = $this;
}
}
@@ -1909,6 +1942,11 @@ sub role_type {
);
}
+sub maybe_type {
+ my $param = shift;
+ return _find_or_create_parameterized_type($TYPE{Maybe}, $param);
+}
+
sub duck_type {
my($name, @methods);
@@ -2102,27 +2140,28 @@ sub find_or_parse_type_constraint {
}
sub find_or_create_does_type_constraint{
- # XXX: Moose does not register a new role_type, but TB2::Mouse does.
+ # XXX: Moose does not register a new role_type, but Mouse does.
my $tc = find_or_parse_type_constraint(@_);
return defined($tc) ? $tc : role_type(@_);
}
sub find_or_create_isa_type_constraint {
- # XXX: Moose does not register a new class_type, but TB2::Mouse does.
+ # XXX: Moose does not register a new class_type, but Mouse does.
my $tc = find_or_parse_type_constraint(@_);
return defined($tc) ? $tc : class_type(@_);
}
-# Contents of Mouse
-package TB2::Mouse::TOP;
+}
+BEGIN{ # lib/TB2/Mouse.pm
+package TB2::Mouse;
use 5.006_002;
use TB2::Mouse::Exporter; # enables strict and warnings
-our $VERSION = '0.87';
+our $VERSION = '1.08';
-use Carp qw(confess);
-use Scalar::Util qw(blessed);
+use Carp ();
+use Scalar::Util ();
use TB2::Mouse::Util ();
@@ -2255,14 +2294,15 @@ sub init_meta {
$meta->superclasses($base_class)
unless $meta->superclasses;
- # make a class type for each TB2::Mouse class
+ # make a class type for each Mouse class
TB2::Mouse::Util::TypeConstraints::class_type($class)
unless TB2::Mouse::Util::TypeConstraints::find_type_constraint($class);
return $meta;
}
-# Contents of Mouse::Meta::Attribute
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Attribute.pm
package TB2::Mouse::Meta::Attribute;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
@@ -2301,7 +2341,7 @@ my %valid_options = map { $_ => undef } (
'associated_methods',
'__METACLASS__',
- # Moose defines, but TB2::Mouse doesn't
+ # Moose defines, but Mouse doesn't
#'definition_context',
#'initializer',
@@ -2520,8 +2560,15 @@ sub install_accessors{
if(exists $attribute->{$type}){
my $generator = '_generate_' . $type;
my $code = $accessor_class->$generator($attribute, $metaclass);
- $metaclass->add_method($attribute->{$type} => $code);
- $attribute->associate_method($attribute->{$type});
+ my $name = $attribute->{$type};
+# TODO: do something for compatibility
+# if( $metaclass->name->can($name) ) {
+# my $t = $metaclass->has_method($name) ? 'method' : 'function';
+# Carp::cluck("You are overwriting a locally defined $t"
+# . " ($name) with an accessor");
+# }
+ $metaclass->add_method($name => $code);
+ $attribute->associate_method($name);
}
}
@@ -2598,17 +2645,17 @@ sub _make_delegation_method {
->_generate_delegation($self, $handle, $method_to_call);
}
-# Contents of Mouse::Meta::Class
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Class.pm
package TB2::Mouse::Meta::Class;
use TB2::Mouse::Util qw/:meta/; # enables strict and warnings
-no warnings 'once';
use Scalar::Util ();
use TB2::Mouse::Meta::Module;
our @ISA = qw(TB2::Mouse::Meta::Module);
-our @CARP_NOT = qw(TB2::Mouse); # trust Mousse
+our @CARP_NOT = qw(Mouse); # trust Mouse
sub attribute_metaclass;
sub method_metaclass;
@@ -2673,7 +2720,7 @@ sub verify_superclass {
if(defined $super_meta) {
if(TB2::Mouse::Util::is_a_metarole($super_meta)){
- $self->throw_error("You cannot inherit from a TB2::Mouse Role ($super)");
+ $self->throw_error("You cannot inherit from a Mouse Role ($super)");
}
}
else {
@@ -2695,9 +2742,11 @@ sub verify_superclass {
sub inherit_from_foreign_class {
my($class, $super) = @_;
- Carp::carp("You inherit from non-TB2::Mouse class ($super),"
- . " but it is unlikely to work correctly."
- . " Please consider using TB2::MouseX::Foreign");
+ if($ENV{PERL_MOUSE_STRICT}) {
+ Carp::carp("You inherit from non-Mouse class ($super),"
+ . " but it is unlikely to work correctly."
+ . " Please consider using MouseX::Foreign");
+ }
return;
}
@@ -3012,9 +3061,9 @@ sub add_override_method_modifier {
or $self->throw_error("You cannot override '$name' because it has no super method");
$self->add_method($name => sub {
- local $TB2::Mouse::TOP::SUPER_PACKAGE = $package;
- local $TB2::Mouse::TOP::SUPER_BODY = $super_body;
- local @TB2::Mouse::TOP::SUPER_ARGS = @_;
+ local $TB2::Mouse::SUPER_PACKAGE = $package;
+ local $TB2::Mouse::SUPER_BODY = $super_body;
+ local @TB2::Mouse::SUPER_ARGS = @_;
&{$code};
});
return;
@@ -3033,8 +3082,8 @@ sub add_augment_method_modifier {
my $super_body = $super->body;
$self->add_method($name => sub {
- local $TB2::Mouse::TOP::INNER_BODY{$super_package} = $code;
- local $TB2::Mouse::TOP::INNER_ARGS{$super_package} = [@_];
+ local $TB2::Mouse::INNER_BODY{$super_package} = $code;
+ local $TB2::Mouse::INNER_ARGS{$super_package} = [@_];
&{$super_body};
});
return;
@@ -3061,7 +3110,8 @@ sub does_role {
return 0;
}
-# Contents of Mouse::Meta::Method
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Method.pm
package TB2::Mouse::Meta::Method;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use Scalar::Util ();
@@ -3109,7 +3159,8 @@ sub _equal {
&& $l->package_name eq $r->package_name;
}
-# Contents of Mouse::Meta::Method::Accessor
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Method/Accessor.pm
package TB2::Mouse::Meta::Method::Accessor;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
@@ -3170,11 +3221,11 @@ sub _generate_accessor_any{
$attribute->_throw_type_constraint_error('.$value.', $constraint);' . "\n";
}
- $accessor .= "my \$old_value = $slot;\n" if $trigger;
-
# if there's nothing left to do for the attribute we can return during
# this setter
$accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;
+
+ $accessor .= "my \@old_value = exists $slot ? $slot : ();\n" if $trigger;
$accessor .= "$slot = $value;\n";
if ($is_weak) {
@@ -3182,7 +3233,7 @@ sub _generate_accessor_any{
}
if ($trigger) {
- $accessor .= '$trigger->('.$self.', '.$value.', $old_value);' . "\n";
+ $accessor .= '$trigger->('.$self.', '.$value.', @old_value);' . "\n";
}
$accessor .= "}\n";
@@ -3291,7 +3342,8 @@ sub _generate_clearer {
};
}
-# Contents of Mouse::Meta::Method::Constructor
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Method/Constructor.pm
package TB2::Mouse::Meta::Method::Constructor;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
@@ -3381,10 +3433,6 @@ sub _generate_initialize_object {
$post_process .= "\$checks[$index]->($instance_slot)\n";
$post_process .= " or $attr_var->_throw_type_constraint_error($instance_slot, $constraint_var);\n";
}
- if($is_weak_ref){
- $post_process = "Scalar::Util::weaken($instance_slot) "
- . "if ref $instance_slot;\n";
- }
# build cde for an attribute
if (defined $init_arg) {
@@ -3445,6 +3493,11 @@ sub _generate_initialize_object {
$code .= "}\n" if defined $init_arg;
+ if($is_weak_ref){
+ $code .= "Scalar::Util::weaken($instance_slot) "
+ . "if ref $instance_slot and not Scalar::Util::isweak($instance_slot);\n";
+ }
+
push @res, $code;
}
@@ -3517,7 +3570,8 @@ sub _generate_BUILDALL {
return join "\n", @code;
}
-# Contents of Mouse::Meta::Method::Delegation
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Method/Delegation.pm
package TB2::Mouse::Meta::Method::Delegation;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
use Scalar::Util;
@@ -3572,7 +3626,8 @@ sub _generate_delegation{
}
-# Contents of Mouse::Meta::Method::Destructor
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Method/Destructor.pm
package TB2::Mouse::Meta::Method::Destructor;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
@@ -3585,7 +3640,7 @@ sub _generate_destructor{
for my $class ($metaclass->linearized_isa) {
if (TB2::Mouse::Util::get_code_ref($class, 'DEMOLISH')) {
$demolishall .= ' ' . $class
- . '::DEMOLISH($self, $TB2::Mouse::Util::in_global_destruction);'
+ . '::DEMOLISH($self, TB2::Mouse::Util::in_global_destruction());'
. "\n",
}
}
@@ -3631,10 +3686,10 @@ EOT
return $code;
}
-# Contents of Mouse::Meta::Module
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Module.pm
package TB2::Mouse::Meta::Module;
use TB2::Mouse::Util qw/:meta/; # enables strict and warnings
-no warnings 'once';
use Carp ();
use Scalar::Util ();
@@ -3711,7 +3766,7 @@ sub get_attribute_list{ keys %{$_[0]->{attributes}} }
# XXX: not completely compatible with Moose
my %foreign = map{ $_ => undef } qw(
- TB2::Mouse TB2::Mouse::Role TB2::Mouse::Util TB2::Mouse::Util::TypeConstraints
+ Mouse TB2::Mouse::Role TB2::Mouse::Util TB2::Mouse::Util::TypeConstraints
Carp Scalar::Util List::Util
);
sub _get_method_body {
@@ -3763,7 +3818,7 @@ sub get_method_list {
return grep { $self->has_method($_) } keys %{ $self->namespace };
}
-sub _collect_methods { # TB2::Mouse specific, used for method modifiers
+sub _collect_methods { # Mouse specific, used for method modifiers
my($meta, @args) = @_;
my @methods;
@@ -3907,7 +3962,7 @@ sub create {
sub DESTROY{
my($self) = @_;
- return if $TB2::Mouse::Util::in_global_destruction;
+ return if TB2::Mouse::Util::in_global_destruction();
my $serial_id = $self->{anon_serial_id};
return if !$serial_id;
@@ -3937,7 +3992,8 @@ sub DESTROY{
}
-# Contents of Mouse::Meta::Role
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Role.pm
package TB2::Mouse::Meta::Role;
use TB2::Mouse::Util qw(:meta); # enables strict and warnings
@@ -4062,7 +4118,8 @@ sub does_role {
return 0;
}
-# Contents of Mouse::Meta::Role::Application
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Role/Application.pm
package TB2::Mouse::Meta::Role::Application;
use TB2::Mouse::Util qw(:meta);
@@ -4265,7 +4322,8 @@ sub _append_roles {
}
return;
}
-# Contents of Mouse::Meta::Role::Composite
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Role/Composite.pm
package TB2::Mouse::Meta::Role::Composite;
use TB2::Mouse::Util; # enables strict and warnings
use TB2::Mouse::Meta::Role;
@@ -4274,7 +4332,7 @@ our @ISA = qw(TB2::Mouse::Meta::Role);
# FIXME: TB2::Mouse::Meta::Role::Composite does things in different way from Moose's
# Moose: creates a new class for the consumer, and applies roles to it.
-# TB2::Mouse: creates a coposite role and apply roles to the role,
+# Mouse: creates a coposite role and apply roles to the role,
# and then applies it to the consumer.
sub new {
@@ -4415,7 +4473,8 @@ sub apply_methods {
}
package TB2::Mouse::Meta::Role::Composite;
-# Contents of Mouse::Meta::Role::Method
+}
+BEGIN{ # lib/TB2/Mouse/Meta/Role/Method.pm
package TB2::Mouse::Meta::Role::Method;
use TB2::Mouse::Util; # enables strict and warnings
@@ -4432,18 +4491,26 @@ sub _new{
return $self;
}
-# Contents of Mouse::Object
+}
+BEGIN{ # lib/TB2/Mouse/Object.pm
package TB2::Mouse::Object;
use TB2::Mouse::Util qw(does dump meta); # enables strict and warnings
# all the stuff are defined in XS or PP
-# Contents of Mouse::Role
+
+sub DOES {
+ my($self, $class_or_role_name) = @_;
+ return $self->isa($class_or_role_name) || $self->does($class_or_role_name);
+}
+
+}
+BEGIN{ # lib/TB2/Mouse/Role.pm
package TB2::Mouse::Role;
use TB2::Mouse::Exporter; # enables strict and warnings
-our $VERSION = '0.87';
+our $VERSION = '1.08';
-use Carp qw(confess);
-use Scalar::Util qw(blessed);
+use Carp ();
+use Scalar::Util ();
use TB2::Mouse ();
@@ -4514,8 +4581,8 @@ sub around {
sub super {
- return if !defined $TB2::Mouse::TOP::SUPER_BODY;
- $TB2::Mouse::TOP::SUPER_BODY->(@TB2::Mouse::TOP::SUPER_ARGS);
+ return if !defined $TB2::Mouse::SUPER_BODY;
+ $TB2::Mouse::SUPER_BODY->(@TB2::Mouse::SUPER_ARGS);
}
sub override {
@@ -4559,14 +4626,15 @@ sub init_meta{
$metaclass->initialize(ref($_[0]) || $_[0]);
});
- # make a role type for each TB2::Mouse role
+ # make a role type for each Mouse role
TB2::Mouse::Util::TypeConstraints::role_type($class)
unless TB2::Mouse::Util::TypeConstraints::find_type_constraint($class);
return $meta;
}
-# Contents of Mouse::Util::MetaRole
+}
+BEGIN{ # lib/TB2/Mouse/Util/MetaRole.pm
package TB2::Mouse::Util::MetaRole;
use TB2::Mouse::Util; # enables strict and warnings
use Scalar::Util ();
@@ -4711,12 +4779,14 @@ sub _make_new_class {
)->name();
}
-;
-
-package TB2::Mouse;
+}
+END_OF_TINY
+ die $@ if $@;
+} # unless TB2/Mouse.pm is loaded
+package TB2::Mouse::Tiny;
-our $VERSION = '0.12';
+our $VERSION = '1.08';
-TB2::Mouse::Exporter->setup_import_methods(also => 'TB2::Mouse::TOP');
+TB2::Mouse::Exporter->setup_import_methods(also => 'TB2::Mouse');
1;
View
95 lib/Test/Builder.pm
@@ -2365,29 +2365,94 @@ This behavior can be turned off with L<no_change_exit_code>.
=head1 THREADS
-In perl 5.8.1 and later, Test::Builder is thread-safe. The test
-number is shared amongst all threads. This means if one thread sets
-the test number using C<current_test()> they will all be effected.
-
-While versions earlier than 5.8.1 had threads they contain too many
-bugs to support.
+Test::Builder is thread-safe. The test state is shared amongst all
+threads.
Test::Builder is only thread-aware if threads.pm is loaded I<before>
Test::Builder.
+While we support all versions of Perl with threads, we recommend you
+use the latest version of Perl possible to avoid threading bugs.
+
+
+=head1 FORKS
+
+By default, Test::Builder is unaware of forks. Tests in a forked
+process will not be noticed by the parent.
+
+You can turn on sharing state across forks with C<<
+Test::Builder->new->coordinated_forks(1) >>.
+
+See L</coordinated_forks> for more details.
+
+
=head1 MEMORY
-An informative hash, accessible via C<<details()>>, is stored for each
-test you perform. So memory usage will scale linearly with each test
-run. Although this is not a problem for most test suites, it can
-become an issue if you do large (hundred thousands to million)
-combinatorics tests in the same run.
+Memory usage should remain constant as you run tests so long as C<<
+Test::Builder->history->store_events >> is off, which it is by
+default.
+
+
+=head1 INCOMPATIBILITIES
+
+=head2 Between Test::Builder 0.98 and 1.5.0
+
+=head3 summary() and details() are only populated on request
+
+By default L<summary> and L<details> will throw an exception if you
+use them. This is to keep memory usage down. You can turn it on with
+C<< $history->store_events(1) >>, but we recommend you instead use the
+statistical methods of TB2::History instead. See
+L<TB2::History/Statistics> and L<history> for more details.
+
+Here's an example of how you'd write code compatible across
+Test::Builder 0.98 and 1.5.0.
+
+ my $builder = Test::Builder->new;
+ if( $builder->can("history") ) {
+ my $history = $builder->history;
+ ...use TB2::History...
+ }
+ else {
+ ...use $builder->details or summary...
+ }
+
+=head3 Output handles are duplicated on first use
+
+Test::Builder will duplicate STDOUT and STDERR to make it safe for you
+to manipulate them as part of your test. 0.98 will duplicate them
+when the module is loaded, but 1.5.0 will duplicate them on first use.
+
+We recommend making any changes to the handles that you wish
+Test::Builder to see, such as turning on UTF8, as early as possible.
+
+We also recommend making any changes you I<don't> wish Test::Builder
+to see after the plan has been output.
+
+
+=head3 TAP version header
+
+1.5.0 uses TAP version 13 which will output a version header before
+anything else.
+
+ TAP version 13
+ 1..1
+ ok 1
+
+If you have code which examines the output of a test, this may
+interfere.
+
+
+=head3 TAP end of test formatting
-In such cases, you are advised to either split the test file into smaller
-ones, or use a reverse approach, doing "normal" (code) compares and
-triggering fail() should anything go unexpected.
+The comment at the end of a failing test script has changed.
+Previously it was "Looks like you failed X test(s) of Y." It is now
+"X test(s) of Y failed.".
-Future versions of Test::Builder will have a way to turn history off.
+Other minor incompatibilities in the TAP comments will appear. We
+recommend you do not rely on the TAP comments. Instead use modules
+such as L<Test::Tester>, L<Test::Builder::Tester> or inspect the state
+of the test using the L<TB2::History> object.
=head1 EXAMPLES
View
37 t/CanAsHash.t
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+BEGIN { require "t/test.pl" }
+
+note "Setting up test class"; {
+ package Some::Object;
+ use TB2::Mouse;
+ with "TB2::CanAsHash";
+
+ has foo =>
+ is => 'rw';
+
+ has _private =>
+ is => 'rw';
+}
+
+
+note "empty object"; {
+ my $obj = Some::Object->new;
+
+ is_deeply $obj->as_hash, {}, "undefined attributes are ignored";
+}
+
+
+note "private accessors"; {
+ my $obj = Some::Object->new(
+ foo => 23,
+ _private => 42,
+ );
+
+ is_deeply $obj->as_hash, { foo => 23 };
+}
+
+done_testing;
View
13 t/Event/Events.t
@@ -6,18 +6,9 @@ use warnings;
BEGIN { require "t/test.pl"; }
use TB2::Events;
-my @events = map { "TB2::Event::".$_ }
- qw(TestStart TestEnd
- SetPlan
- TestMetadata
- Log
- Comment
- SubtestStart
- SubtestEnd
- Abort
- );
+my @events = TB2::Events->event_classes;
-for my $class (@events) {
+for my $class (grep !/TB2::Result/, @events) {
ok $class->can("event_type"), "$class loaded";
}
View
38 t/Event/Generic.t
@@ -0,0 +1,38 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+BEGIN { require "t/test.pl" }
+
+my $CLASS = 'TB2::Event::Generic';
+require_ok $CLASS;
+
+note "generic events"; {
+ my $line = __LINE__ + 1;
+ my $event = $CLASS->new(
+ foo => 23,
+ bar => 42,
+ event_type => "some_thing",
+ );
+
+ is $event->foo, 23;
+ is $event->bar, 42;
+ is $event->event_type, "some_thing";
+ ok $event->object_id;
+
+ is_deeply $event->as_hash, {
+ foo => 23,
+ bar => 42,
+ event_type => 'some_thing',
+ object_id => $event->object_id,
+ pid => $$
+ };
+}
+
+note "generic events must be given an event type"; {
+ ok !eval { $CLASS->new() };
+ like $@, qr{^The event_type must be defined in the constructor};
+}
+
+done_testing;
View
4 t/Event/SubtestEnd.t
@@ -25,8 +25,8 @@ note "defaults"; {
event_type => "subtest_end",
object_id => $event->object_id,
pid => $$,
- history => $history,
- result => $event->result,
+ history => $history->as_hash,
+ result => $event->result->as_hash,
};
is $event->result->name, "No tests run in subtest";
View
52 t/Event/as_hash.t
@@ -0,0 +1,52 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+BEGIN { require "t/test.pl" }
+
+use TB2::Events;
+use TB2::Event::Generic;
+use TB2::History;
+
+my %Special_Constructors = (
+ 'TB2::Event::SubtestEnd' => sub {
+ my $class = shift;
+ return $class->new(
+ history => TB2::History->new,
+ @_,
+ );
+ },
+ 'TB2::Result' => sub {
+ my $class = shift;
+ return TB2::Result->new_result(@_)
+ },
+ 'TB2::Event::Log' => sub {
+ my $class = shift;
+ return $class->new(
+ message => "This is a message",
+ @_
+ );
+ },
+ 'TB2::Event::Comment' => sub {
+ my $class = shift;
+ return $class->new(
+ comment => "This is a comment",
+ @_
+ );
+ }
+);
+
+note "as_hash / new round trip"; {
+ for my $class (TB2::Events->event_classes) {
+ my $constructor = $Special_Constructors{$class} || 'new';
+
+ note "Trying $class";
+ my $obj = $class->$constructor;
+
+ my $duplicate = TB2::Event::Generic->new( %{$obj->as_hash} );
+ is_deeply $obj->as_hash, $duplicate->as_hash, "$class round trip";
+ }
+}
+
+done_testing;
View
50 t/Formatter/JSON.t
@@ -0,0 +1,50 @@
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+BEGIN {
+ require "t/test.pl";
+ plan(skip_all => "JSON::PP required") unless eval { require JSON::PP };
+}
+use MyEventCoordinator;
+use TB2::Events;
+use TB2::Event::Generic;
+
+use JSON::PP;
+
+use_ok 'TB2::Formatter::JSON';
+
+my $formatter = TB2::Formatter::JSON->new(
+ streamer_class => 'TB2::Streamer::Debug'
+);
+
+my $ec = MyEventCoordinator->new(
+ formatters => [$formatter]
+);
+
+{
+ my @events = (
+ TB2::Event::TestStart->new,
+ TB2::Event::SetPlan->new( asserts_expected => 2 ),
+ TB2::Result->new_result( pass => 1 ),
+ TB2::Result->new_result( pass => 0 ),
+ TB2::Event::TestEnd->new,
+ );
+
+ $ec->post_event($_) for @events;
+
+ my $json = $formatter->streamer->read;
+
+ my $events_as_hash = decode_json($json);
+ is_deeply $events_as_hash,
+ [map { $_->as_hash } @events],
+ "events restored as hashes";
+
+ my @restored_events = map { TB2::Event::Generic->new(%$_) } @$events_as_hash;
+ is_deeply [map { $_->as_hash } @restored_events],
+ [map { $_->as_hash } @events],
+ "events restored as generic events";
+}
+
+done_testing;
View
82 t/History/as_hash.t
@@ -0,0 +1,82 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+BEGIN { require "t/test.pl" }
+
+use TB2::History;
+use TB2::EventCoordinator;
+use TB2::Events;
+
+note "Empty history object as_hash"; {
+ my $history = TB2::History->new;
+
+ is_deeply $history->as_hash, {
+ counter => 0,
+ event_count => 0,
+ fail_count => 0,
+ literal_fail_count => 0,
+ literal_pass_count => 0,
+ pass_count => 0,
+ result_count => 0,
+ skip_count => 0,
+ todo_count => 0,
+
+ object_id => $history->object_id,
+
+ subtest_depth => 0,
+ is_subtest => 0,
+ is_child_process => 0,
+ in_test => 0,
+ done_testing => 0,
+
+ can_succeed => 1,
+ test_was_successful => 0,
+ };
+}
+
+
+note "Empty history object as_hash"; {
+ my $ec = TB2::EventCoordinator->new(
+ formatters => [],
+ );
+ my $history = $ec->history;
+
+ my $plan = TB2::Event::SetPlan->new( asserts_expected => 2 );
+ my @results = (TB2::Result->new_result( pass => 1 )) x 2;
+ my $test_end = TB2::Event::TestEnd->new;
+
+ $ec->post_event($_) for ($plan, @results, $test_end);
+
+ is_deeply $history->as_hash, {
+ counter => 2,
+ event_count => 5,
+ fail_count => 0,
+ literal_fail_count => 0,
+ literal_pass_count => 2,
+ pass_count => 2,
+ result_count => 2,
+ skip_count => 0,
+ todo_count => 0,
+
+ object_id => $history->object_id,
+
+ subtest_depth => 0,
+ is_subtest => 0,
+ is_child_process => 0,
+ in_test => 0,
+ done_testing => 1,
+
+ can_succeed => 1,
+ test_was_successful => 1,
+
+ pid_at_test_start => $$,
+
+ plan => $plan->as_hash,
+ test_end => $test_end->as_hash,
+ test_start => $history->test_start->as_hash
+ };
+}
+
+done_testing;
Please sign in to comment.
Something went wrong with that request. Please try again.