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         'blessed' => do {
  10             do {
  11                 no strict 'refs';
  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
  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     },
  45     'MRO::Compat' => {
  46         'get_linear_isa' => {
  47             loaded     => \&mro::get_linear_isa,
  48             not_loaded => do {
  49                 # this recurses so it isn't pretty
  50                 my $code;
  51                 $code = sub {
  52                     no strict 'refs';
  53
  54                     my $classname = shift;
  55
  56                     my @lin = ($classname);
  57                     my %stored;
  58                     foreach my $parent (@{"$classname\::ISA"}) {
  59                         my $plin = $code->($parent);
  60                         foreach (@$plin) {
  61                             next if exists $stored{$_};
  62                             push(@lin, $_);
  63                             $stored{$_} = 1;
  64                         }
  65                     }
  66                     return \@lin;
  67                 }
  68             },
  69         },
  70     },
  71 );
  72
  73 our @EXPORT_OK = map { keys %$_ } values %dependencies;
  74
  75 for my $module_name (keys %dependencies) {
  76     (my $file = "$module_name.pm") =~ s{::}{/}g;
  77
  78     my $loaded = do {
  79         local $SIG{__DIE__} = 'DEFAULT';
  80         eval "require '$file'; 1";
  81     };
  82
  83     for my $method_name (keys %{ $dependencies{ $module_name } }) {
  84         my $producer = $dependencies{$module_name}{$method_name};
  85         my $implementation;
  86
  87         if (ref($producer) eq 'HASH') {
  88             $implementation = $loaded
  89                             ? $producer->{loaded}
  90                             : $producer->{not_loaded};
  91         }
  92         else {
  93             $implementation = $loaded
  94                             ? $module_name->can($method_name)
  95                             : $producer;
  96         }
  97
  98         no strict 'refs';
  99         *{ __PACKAGE__ . '::' . $method_name } = $implementation;
 100     }
 101 }
 102
 103 1;
 104