lib/Mouse/Util.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Util;
   3 use strict;
   4 use warnings;
   5 use base 'Exporter';
   6
   7 our %dependencies = (
   8     'Scalar::Util' => {
   9         'blessed' => do {
  10             do {
  11                 no strict 'refs';
  12                 *UNIVERSAL::a_sub_not_likely_to_be_here = sub {
  13                     my $ref = ref($_[0]);
  14
  15                     # deviation from Scalar::Util
  16                     # XS returns undef, PP returns GLOB.
  17                     # let's make that more consistent by having PP return
  18                     # undef if it's a GLOB. :/
  19
  20                     # \*STDOUT would be allowed as an object in PP blessed
  21                     # but not XS
  22                     return $ref eq 'GLOB' ? undef : $ref;
  23                 };
  24             };
  25
  26             sub {
  27                 local($@, $SIG{__DIE__}, $SIG{__WARN__});
  28                 length(ref($_[0]))
  29                     ? eval { $_[0]->a_sub_not_likely_to_be_here }
  30                     : undef;
  31             },
  32         },
  33     },
  34     'MRO::Compat' => {
  35         'get_linear_isa' => {
  36             loaded     => \&mro::get_linear_isa,
  37             not_loaded => do {
  38                 # this recurses so it isn't pretty
  39                 my $code;
  40                 $code = sub {
  41                     no strict 'refs';
  42
  43                     my $classname = shift;
  44
  45                     my @lin = ($classname);
  46                     my %stored;
  47                     foreach my $parent (@{"$classname\::ISA"}) {
  48                         my $plin = $code->($parent);
  49                         foreach (@$plin) {
  50                             next if exists $stored{$_};
  51                             push(@lin, $_);
  52                             $stored{$_} = 1;
  53                         }
  54                     }
  55                     return \@lin;
  56                 }
  57             },
  58         },
  59     },
  60 );
  61
  62 our @EXPORT_OK = map { keys %$_ } values %dependencies;
  63
  64 for my $module_name (keys %dependencies) {
  65     (my $file = "$module_name.pm") =~ s{::}{/}g;
  66
  67     my $loaded = do {
  68         local $SIG{__DIE__} = 'DEFAULT';
  69         eval "require '$file'; 1";
  70     };
  71
  72     for my $method_name (keys %{ $dependencies{ $module_name } }) {
  73         my $producer = $dependencies{$module_name}{$method_name};
  74         my $implementation;
  75
  76         if (ref($producer) eq 'HASH') {
  77             $implementation = $loaded
  78                             ? $producer->{loaded}
  79                             : $producer->{not_loaded};
  80         }
  81         else {
  82             $implementation = $loaded
  83                             ? $module_name->can($method_name)
  84                             : $producer;
  85         }
  86
  87         no strict 'refs';
  88         *{ __PACKAGE__ . '::' . $method_name } = $implementation;
  89     }
  90 }
  91
  92 1;
  93