lib/Mouse/Util.pm

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