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             do {
  13                 no strict 'refs';
  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
  28             sub {
  29                 local($@, $SIG{__DIE__}, $SIG{__WARN__});
  30                 length(ref($_[0]))
  31                     ? eval { $_[0]->a_sub_not_likely_to_be_here }
  32                     : undef;
  33             },
  34         },
  35         'looks_like_number' => sub {
  36             local $_ = shift;
  37
  38             # checks from perlfaq4
  39             return 0 if !defined($_) or ref($_);
  40             return 1 if (/^[+-]?\d+$/); # is a +/- integer
  41             return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
  42             return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
  43
  44             0;
  45         },
  46         'reftype' => sub {
  47             local($@, $SIG{__DIE__}, $SIG{__WARN__});
  48             my $r = shift;
  49             my $t;
  50
  51             length($t = ref($r)) or return undef;
  52
  53             # This eval will fail if the reference is not blessed
  54             eval { $r->a_sub_not_likely_to_be_here; 1 }
  55             ? do {
  56                 $t = eval {
  57                     # we have a GLOB or an IO. Stringify a GLOB gives it's name
  58                     my $q = *$r;
  59                     $q =~ /^\*/ ? "GLOB" : "IO";
  60                 }
  61                 or do {
  62                     # OK, if we don't have a GLOB what parts of
  63                     # a glob will it populate.
  64                     # NOTE: A glob always has a SCALAR
  65                     local *glob = $r;
  66                     defined *glob{ARRAY} && "ARRAY"
  67                         or defined *glob{HASH} && "HASH"
  68                         or defined *glob{CODE} && "CODE"
  69                         or length(ref(${$r})) ? "REF" : "SCALAR";
  70                 }
  71             }
  72             : $t
  73         },
  74         'openhandle' => sub {
  75             my $fh = shift;
  76             my $rt = reftype($fh) || '';
  77
  78             return defined(fileno($fh)) ? $fh : undef
  79                 if $rt eq 'IO';
  80
  81             if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
  82                 $fh = \(my $tmp=$fh);
  83             }
  84             elsif ($rt ne 'GLOB') {
  85                 return undef;
  86             }
  87
  88             (tied(*$fh) or defined(fileno($fh)))
  89                 ? $fh : undef;
  90         },
  91         weaken => {
  92             loaded => \&Scalar::Util::weaken,
  93             not_loaded => sub { die "Scalar::Util required for weak reference support" },
  94         },
  95 #       ^^^^^   CODE TAKEN FROM SCALAR::UTIL   ^^^^^
  96     },
  97     'MRO::Compat' => {
  98 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
  99         'get_linear_isa' => {
 100             loaded     => \&mro::get_linear_isa,
 101             not_loaded => do {
 102                 # this recurses so it isn't pretty
 103                 my $code;
 104                 $code = sub {
 105                     no strict 'refs';
 106
 107                     my $classname = shift;
 108
 109                     my @lin = ($classname);
 110                     my %stored;
 111                     foreach my $parent (@{"$classname\::ISA"}) {
 112                         my $plin = $code->($parent);
 113                         foreach (@$plin) {
 114                             next if exists $stored{$_};
 115                             push(@lin, $_);
 116                             $stored{$_} = 1;
 117                         }
 118                     }
 119                     return \@lin;
 120                 }
 121             },
 122         },
 123 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
 124     },
 125 );
 126
 127 our @EXPORT_OK = map { keys %$_ } values %dependencies;
 128
 129 for my $module_name (keys %dependencies) {
 130     (my $file = "$module_name.pm") =~ s{::}{/}g;
 131
 132     my $loaded = do {
 133         local $SIG{__DIE__} = 'DEFAULT';
 134         eval "require '$file'; 1";
 135     };
 136
 137     for my $method_name (keys %{ $dependencies{ $module_name } }) {
 138         my $producer = $dependencies{$module_name}{$method_name};
 139         my $implementation;
 140
 141         if (ref($producer) eq 'HASH') {
 142             $implementation = $loaded
 143                             ? $producer->{loaded}
 144                             : $producer->{not_loaded};
 145         }
 146         else {
 147             $implementation = $loaded
 148                             ? $module_name->can($method_name)
 149                             : $producer;
 150         }
 151
 152         no strict 'refs';
 153         *{ __PACKAGE__ . '::' . $method_name } = $implementation;
 154     }
 155 }
 156
 157
 158 1;
 159