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