lib/Mouse/PurePerl.pm

   1 package
   2     Mouse::Util;
   3
   4 use strict;
   5 use warnings;
   6
   7 use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
   8
   9 use B ();
  10
  11 sub is_class_loaded {
  12     my $class = shift;
  13
  14     return 0 if ref($class) || !defined($class) || !length($class);
  15
  16     # walk the symbol table tree to avoid autovififying
  17     # \*{${main::}{"Foo::"}} == \*main::Foo::
  18
  19     my $pack = \%::;
  20     foreach my $part (split('::', $class)) {
  21         my $entry = \$pack->{$part . '::'};
  22         return 0 if ref($entry) ne 'GLOB';
  23         $pack = *{$entry}{HASH} or return 0;
  24     }
  25
  26     # check for $VERSION or @ISA
  27     return 1 if exists $pack->{VERSION}
  28              && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
  29     return 1 if exists $pack->{ISA}
  30              && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
  31
  32     # check for any method
  33     foreach my $name( keys %{$pack} ) {
  34         my $entry = \$pack->{$name};
  35         return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
  36     }
  37
  38     # fail
  39     return 0;
  40 }
  41
  42
  43 # taken from Sub::Identify
  44 sub get_code_info {
  45     my ($coderef) = @_;
  46     ref($coderef) or return;
  47
  48     my $cv = B::svref_2object($coderef);
  49     $cv->isa('B::CV') or return;
  50
  51     my $gv = $cv->GV;
  52     $gv->isa('B::GV') or return;
  53
  54     return ($gv->STASH->NAME, $gv->NAME);
  55 }
  56
  57 sub get_code_package{
  58     my($coderef) = @_;
  59
  60     my $cv = B::svref_2object($coderef);
  61     $cv->isa('B::CV') or return '';
  62
  63     my $gv = $cv->GV;
  64     $gv->isa('B::GV') or return '';
  65
  66     return $gv->STASH->NAME;
  67 }
  68
  69
  70 package
  71     Mouse::Meta::Method::Accessor;
  72
  73 1;
  74 __END__