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     our %dependencies = (
  24         'Scalar::Util' => {
  25
  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     our %loaded;
 141
 142     our @EXPORT_OK = map { keys %$_ } values %dependencies;
 143     our %EXPORT_TAGS = (
 144         all  => \@EXPORT_OK,
 145         test => [qw/throws_ok lives_ok dies_ok/],
 146     );
 147
 148     for my $module (keys %dependencies) {
 149         my ($module_name, $version) = split ' ', $module;
 150
 151         my $loaded = do {
 152             local $SIG{__DIE__} = 'DEFAULT';
 153             eval "use $module (); 1";
 154         };
 155
 156         $loaded{$module_name} = $loaded;
 157
 158         for my $method_name (keys %{ $dependencies{ $module } }) {
 159             my $producer = $dependencies{$module}{$method_name};
 160             my $implementation;
 161
 162             if (ref($producer) eq 'HASH') {
 163                 $implementation = $loaded
 164                                 ? $producer->{loaded}
 165                                 : $producer->{not_loaded};
 166             }
 167             else {
 168                 $implementation = $loaded
 169                                 ? $module_name->can($method_name)
 170                                 : $producer;
 171             }
 172
 173             no strict 'refs';
 174             *{ __PACKAGE__ . '::' . $method_name } = $implementation;
 175         }
 176     }
 177 }
 178
 179 sub apply_all_roles {
 180     my $meta = Mouse::Meta::Class->initialize(shift);
 181
 182     my @roles;
 183     my $max = scalar(@_);
 184     for (my $i = 0; $i < $max ; $i++) {
 185         if ($i + 1 < $max && ref($_[$i + 1])) {
 186             push @roles, [ $_[$i++] => $_[$i] ];
 187         } else {
 188             push @roles, [ $_[$i] => {} ];
 189         }
 190     }
 191
 192     foreach my $role_spec (@roles) {
 193         Mouse::load_class( $role_spec->[0] );
 194     }
 195
 196     ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
 197         || croak("You can only consume roles, "
 198         . $_->[0]
 199         . " is not a Moose role")
 200         foreach @roles;
 201
 202     if ( scalar @roles == 1 ) {
 203         my ( $role, $params ) = @{ $roles[0] };
 204         $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
 205     }
 206     else {
 207         Mouse::Meta::Role->combine_apply($meta, @roles);
 208     }
 209
 210 }
 211
 212 1;
 213
 214 __END__
 215
 216 =head1 NAME
 217
 218 Mouse::Util - features, with or without their dependencies
 219
 220 =head1 IMPLEMENTATIONS FOR
 221
 222 =head2 L<MRO::Compat>
 223
 224 =head3 get_linear_isa
 225
 226 =head2 L<Scalar::Util>
 227
 228 =head3 blessed
 229
 230 =head3 looks_like_number
 231
 232 =head3 reftype
 233
 234 =head3 openhandle
 235
 236 =head3 weaken
 237
 238 C<weaken> I<must> be implemented in XS. If the user tries to use C<weaken>
 239 without L<Scalar::Util>, an error is thrown.
 240
 241 =head2 Test::Exception
 242
 243 =head3 throws_ok
 244
 245 =head3 lives_ok
 246
 247 =cut
 248