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