lib/Mouse/Util.pm

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