lib/Mouse/Util.pm

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