lib/Mouse/Util.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Util;
   3 use strict;
   4 use warnings;
   5 use base 'Exporter';
   6
   7 BEGIN {
   8     our %dependencies = (
   9         'Scalar::Util' => {
  10
  11 #       VVVVV   CODE TAKEN FROM SCALAR::UTIL   VVVVV
  12             'blessed' => do {
  13                 *UNIVERSAL::a_sub_not_likely_to_be_here = sub {
  14                     my $ref = ref($_[0]);
  15
  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. :/
  20
  21                     # \*STDOUT would be allowed as an object in PP blessed
  22                     # but not XS
  23                     return $ref eq 'GLOB' ? undef : $ref;
  24                 };
  25
  26                 sub {
  27                     local($@, $SIG{__DIE__}, $SIG{__WARN__});
  28                     length(ref($_[0]))
  29                         ? eval { $_[0]->a_sub_not_likely_to_be_here }
  30                         : undef;
  31                 },
  32             },
  33             'looks_like_number' => sub {
  34                 local $_ = shift;
  35
  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);
  41
  42                 0;
  43             },
  44             'reftype' => sub {
  45                 local($@, $SIG{__DIE__}, $SIG{__WARN__});
  46                 my $r = shift;
  47                 my $t;
  48
  49                 length($t = ref($r)) or return undef;
  50
  51                 # This eval will fail if the reference is not blessed
  52                 eval { $r->a_sub_not_likely_to_be_here; 1 }
  53                 ? do {
  54                     $t = eval {
  55                         # we have a GLOB or an IO. Stringify a GLOB gives it's name
  56                         my $q = *$r;
  57                         $q =~ /^\*/ ? "GLOB" : "IO";
  58                     }
  59                     or do {
  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
  63                         local *glob = $r;
  64                         defined *glob{ARRAY} && "ARRAY"
  65                             or defined *glob{HASH} && "HASH"
  66                             or defined *glob{CODE} && "CODE"
  67                             or length(ref(${$r})) ? "REF" : "SCALAR";
  68                     }
  69                 }
  70                 : $t
  71             },
  72             'openhandle' => sub {
  73                 my $fh = shift;
  74                 my $rt = reftype($fh) || '';
  75
  76                 return defined(fileno($fh)) ? $fh : undef
  77                     if $rt eq 'IO';
  78
  79                 if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
  80                     $fh = \(my $tmp=$fh);
  81                 }
  82                 elsif ($rt ne 'GLOB') {
  83                     return undef;
  84                 }
  85
  86                 (tied(*$fh) or defined(fileno($fh)))
  87                     ? $fh : undef;
  88             },
  89             weaken => {
  90                 loaded => \&Scalar::Util::weaken,
  91                 not_loaded => sub { die "Scalar::Util required for weak reference support" },
  92             },
  93 #       ^^^^^   CODE TAKEN FROM SCALAR::UTIL   ^^^^^
  94         },
  95         'MRO::Compat' => {
  96 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
  97             'get_linear_isa' => {
  98                 loaded     => \&mro::get_linear_isa,
  99                 not_loaded => do {
 100                     # this recurses so it isn't pretty
 101                     my $code;
 102                     $code = sub {
 103                         no strict 'refs';
 104
 105                         my $classname = shift;
 106
 107                         my @lin = ($classname);
 108                         my %stored;
 109                         foreach my $parent (@{"$classname\::ISA"}) {
 110                             my $plin = $code->($parent);
 111                             foreach (@$plin) {
 112                                 next if exists $stored{$_};
 113                                 push(@lin, $_);
 114                                 $stored{$_} = 1;
 115                             }
 116                         }
 117                         return \@lin;
 118                     }
 119                 },
 120             },
 121 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
 122         },
 123 #       VVVVV   CODE TAKEN FROM TEST::EXCEPTION   VVVVV
 124         'Test::Exception' => do {
 125
 126             my $Tester;
 127
 128             my $is_exception = sub {
 129                 my $exception = shift;
 130                 return ref $exception || $exception ne '';
 131             };
 132
 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/;
 139                 chomp $exception;
 140                 return "$prefix $exception";
 141             };
 142             my $try_as_caller = sub {
 143                 my $coderef = shift;
 144                 eval { $coderef->() };
 145                 $@;
 146             };
 147
 148             {
 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);
 156
 157                     $Tester ||= Test::Builder->new;
 158
 159                     my $regex = $Tester->maybe_regex( $expecting );
 160                     my $ok = $regex
 161                         ? ( $exception =~ m/$regex/ )
 162                         : eval {
 163                             $exception->isa( ref $expecting ? ref $expecting : $expecting )
 164                         };
 165                     $Tester->ok( $ok, $description );
 166                     unless ( $ok ) {
 167                         $Tester->diag( $exception_as_string->( "expecting:", $expecting ) );
 168                         $Tester->diag( $exception_as_string->( "found:", $exception ) );
 169                     };
 170                     $@ = $exception;
 171                     return $ok;
 172                 },
 173                 'lives_ok' => sub (&;$) {
 174                     my ( $coderef, $description ) = @_;
 175                     my $exception = $try_as_caller->( $coderef );
 176
 177                     $Tester ||= Test::Builder->new;
 178
 179                     my $ok = $Tester->ok( ! $is_exception->( $exception ), $description );
 180                     $Tester->diag( $exception_as_string->( "died:", $exception ) ) unless $ok;
 181                     $@ = $exception;
 182                     return $ok;
 183                 },
 184             },
 185         },
 186     );
 187
 188     our %loaded;
 189
 190     our @EXPORT_OK = map { keys %$_ } values %dependencies;
 191     our %EXPORT_TAGS = (
 192         all  => \@EXPORT_OK,
 193         test => [qw/throws_ok lives_ok/],
 194     );
 195
 196     for my $module_name (keys %dependencies) {
 197         my $loaded = do {
 198             local $SIG{__DIE__} = 'DEFAULT';
 199             eval "require $module_name; 1";
 200         };
 201
 202         $loaded{$module_name} = $loaded;
 203
 204         for my $method_name (keys %{ $dependencies{ $module_name } }) {
 205             my $producer = $dependencies{$module_name}{$method_name};
 206             my $implementation;
 207
 208             if (ref($producer) eq 'HASH') {
 209                 $implementation = $loaded
 210                                 ? $producer->{loaded}
 211                                 : $producer->{not_loaded};
 212             }
 213             else {
 214                 $implementation = $loaded
 215                                 ? $module_name->can($method_name)
 216                                 : $producer;
 217             }
 218
 219             no strict 'refs';
 220             *{ __PACKAGE__ . '::' . $method_name } = $implementation;
 221         }
 222     }
 223 }
 224
 225 1;
 226
 227 __END__
 228
 229 =head1 NAME
 230
 231 Mouse::Util - features, with or without their dependencies
 232
 233 =head1 IMPLEMENTATIONS FOR
 234
 235 =head2 L<MRO::Compat>
 236
 237 =head3 get_linear_isa
 238
 239 =head2 L<Scalar::Util>
 240
 241 =head3 blessed
 242
 243 =head3 looks_like_number
 244
 245 =head3 reftype
 246
 247 =head3 openhandle
 248
 249 =head3 weaken
 250
 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.
 253
 254 =head2 Test::Exception
 255
 256 =head3 throws_ok
 257
 258 =head3 lives_ok
 259
 260 =cut
 261