11 # VVVVV CODE TAKEN FROM SCALAR::UTIL VVVVV
13 *UNIVERSAL::a_sub_not_likely_to_be_here = sub {
16 # deviation from Scalar::Util
17 # XS returns undef, PP returns GLOB.
18 # let's make that more consistent by having PP return
19 # undef if it's a GLOB. :/
21 # \*STDOUT would be allowed as an object in PP blessed
23 return $ref eq 'GLOB' ? undef : $ref;
27 local($@, $SIG{__DIE__}, $SIG{__WARN__});
29 ? eval { $_[0]->a_sub_not_likely_to_be_here }
33 'looks_like_number' => sub {
36 # checks from perlfaq4
37 return 0 if !defined($_) or ref($_);
38 return 1 if (/^[+-]?\d+$/); # is a +/- integer
39 return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
40 return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
45 local($@, $SIG{__DIE__}, $SIG{__WARN__});
49 length($t = ref($r)) or return undef;
51 # This eval will fail if the reference is not blessed
52 eval { $r->a_sub_not_likely_to_be_here; 1 }
55 # we have a GLOB or an IO. Stringify a GLOB gives it's name
57 $q =~ /^\*/ ? "GLOB" : "IO";
60 # OK, if we don't have a GLOB what parts of
61 # a glob will it populate.
62 # NOTE: A glob always has a SCALAR
64 defined *glob{ARRAY} && "ARRAY"
65 or defined *glob{HASH} && "HASH"
66 or defined *glob{CODE} && "CODE"
67 or length(ref(${$r})) ? "REF" : "SCALAR";
74 my $rt = reftype($fh) || '';
76 return defined(fileno($fh)) ? $fh : undef
79 if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
82 elsif ($rt ne 'GLOB') {
86 (tied(*$fh) or defined(fileno($fh)))
90 loaded => \&Scalar::Util::weaken,
91 not_loaded => sub { die "Scalar::Util required for weak reference support" },
93 # ^^^^^ CODE TAKEN FROM SCALAR::UTIL ^^^^^
96 # VVVVV CODE TAKEN FROM MRO::COMPAT VVVVV
98 loaded => \&mro::get_linear_isa,
100 # this recurses so it isn't pretty
105 my $classname = shift;
107 my @lin = ($classname);
109 foreach my $parent (@{"$classname\::ISA"}) {
110 my $plin = $code->($parent);
112 next if exists $stored{$_};
121 # ^^^^^ CODE TAKEN FROM MRO::COMPAT ^^^^^
123 # VVVVV CODE TAKEN FROM TEST::EXCEPTION VVVVV
124 'Test::Exception' => do {
128 my $is_exception = sub {
129 my $exception = shift;
130 return ref $exception || $exception ne '';
133 my $exception_as_string = sub {
134 my ( $prefix, $exception ) = @_;
135 return "$prefix normal exit" unless $is_exception->( $exception );
136 my $class = ref $exception;
137 $exception = "$class ($exception)"
138 if $class && "$exception" !~ m/^\Q$class/;
140 return "$prefix $exception";
142 my $try_as_caller = sub {
144 eval { $coderef->() };
149 'throws_ok' => sub (&$;$) {
150 my ( $coderef, $expecting, $description ) = @_;
151 Carp::croak "throws_ok: must pass exception class/object or regex"
152 unless defined $expecting;
153 $description = $exception_as_string->( "threw", $expecting )
154 unless defined $description;
155 my $exception = $try_as_caller->($coderef);
157 $Tester ||= Test::Builder->new;
159 my $regex = $Tester->maybe_regex( $expecting );
161 ? ( $exception =~ m/$regex/ )
163 $exception->isa( ref $expecting ? ref $expecting : $expecting )
165 $Tester->ok( $ok, $description );
167 $Tester->diag( $exception_as_string->( "expecting:", $expecting ) );
168 $Tester->diag( $exception_as_string->( "found:", $exception ) );
173 'lives_ok' => sub (&;$) {
174 my ( $coderef, $description ) = @_;
175 my $exception = $try_as_caller->( $coderef );
177 $Tester ||= Test::Builder->new;
179 my $ok = $Tester->ok( ! $is_exception->( $exception ), $description );
180 $Tester->diag( $exception_as_string->( "died:", $exception ) ) unless $ok;
190 our @EXPORT_OK = map { keys %$_ } values %dependencies;
193 test => [qw/throws_ok lives_ok/],
196 for my $module_name (keys %dependencies) {
198 local $SIG{__DIE__} = 'DEFAULT';
199 eval "require $module_name; 1";
202 $loaded{$module_name} = $loaded;
204 for my $method_name (keys %{ $dependencies{ $module_name } }) {
205 my $producer = $dependencies{$module_name}{$method_name};
208 if (ref($producer) eq 'HASH') {
209 $implementation = $loaded
210 ? $producer->{loaded}
211 : $producer->{not_loaded};
214 $implementation = $loaded
215 ? $module_name->can($method_name)
220 *{ __PACKAGE__ . '::' . $method_name } = $implementation;
231 Mouse::Util - features, with or without their dependencies
233 =head1 IMPLEMENTATIONS FOR
235 =head2 L<MRO::Compat>
237 =head3 get_linear_isa
239 =head2 L<Scalar::Util>
243 =head3 looks_like_number
251 C<weaken> I<must> be implemented in XS. If the user tries to use C<weaken>
252 without L<Scalar::Util>, an error is thrown.
254 =head2 Test::Exception