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