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         '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     },
  90     'MRO::Compat' => {
  91         'get_linear_isa' => {
  92             loaded     => \&mro::get_linear_isa,
  93             not_loaded => do {
  94                 # this recurses so it isn't pretty
  95                 my $code;
  96                 $code = sub {
  97                     no strict 'refs';
  98
  99                     my $classname = shift;
 100
 101                     my @lin = ($classname);
 102                     my %stored;
 103                     foreach my $parent (@{"$classname\::ISA"}) {
 104                         my $plin = $code->($parent);
 105                         foreach (@$plin) {
 106                             next if exists $stored{$_};
 107                             push(@lin, $_);
 108                             $stored{$_} = 1;
 109                         }
 110                     }
 111                     return \@lin;
 112                 }
 113             },
 114         },
 115     },
 116 );
 117
 118 our @EXPORT_OK = map { keys %$_ } values %dependencies;
 119
 120 for my $module_name (keys %dependencies) {
 121     (my $file = "$module_name.pm") =~ s{::}{/}g;
 122
 123     my $loaded = do {
 124         local $SIG{__DIE__} = 'DEFAULT';
 125         eval "require '$file'; 1";
 126     };
 127
 128     for my $method_name (keys %{ $dependencies{ $module_name } }) {
 129         my $producer = $dependencies{$module_name}{$method_name};
 130         my $implementation;
 131
 132         if (ref($producer) eq 'HASH') {
 133             $implementation = $loaded
 134                             ? $producer->{loaded}
 135                             : $producer->{not_loaded};
 136         }
 137         else {
 138             $implementation = $loaded
 139                             ? $module_name->can($method_name)
 140                             : $producer;
 141         }
 142
 143         no strict 'refs';
 144         *{ __PACKAGE__ . '::' . $method_name } = $implementation;
 145     }
 146 }
 147
 148 push @EXPORT_OK, qw(weaken);
 149 sub weaken {
 150     require Scalar::Util;
 151     goto \&Scalar::Util::weaken;
 152 }
 153
 154 1;
 155