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 sub get_code_ref{
  70     my($package, $name) = @_;
  71     no strict 'refs';
  72     no warnings 'once';
  73     use warnings FATAL => 'uninitialized';
  74     return *{$package . '::' . $name}{CODE};
  75 }
  76
  77 package
  78     Mouse::Util::TypeConstraints;
  79
  80 use Scalar::Util qw(blessed looks_like_number openhandle);
  81
  82 sub _generate_class_type_for{
  83     my($for_class, $name) = @_;
  84
  85     my $predicate = sub{ blessed($_[0]) && $_[0]->isa($for_class) };
  86
  87     if(defined $name){
  88         no strict 'refs';
  89         *{ caller() . '::' . $name } = $predicate;
  90         return;
  91     }
  92
  93     return $predicate;
  94 }
  95
  96
  97 sub Any        { 1 }
  98 sub Item       { 1 }
  99
 100 sub Bool       { $_[0] ? $_[0] eq '1' : 1 }
 101 sub Undef      { !defined($_[0]) }
 102 sub Defined    {  defined($_[0])  }
 103 sub Value      {  defined($_[0]) && !ref($_[0]) }
 104 sub Num        { !ref($_[0]) && looks_like_number($_[0]) }
 105 sub Int        {  defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }
 106 sub Str        {  defined($_[0]) && !ref($_[0]) }
 107
 108 sub Ref        { ref($_[0]) }
 109 sub ScalarRef  { ref($_[0]) eq 'SCALAR' }
 110 sub ArrayRef   { ref($_[0]) eq 'ARRAY'  }
 111 sub HashRef    { ref($_[0]) eq 'HASH'   }
 112 sub CodeRef    { ref($_[0]) eq 'CODE'   }
 113 sub RegexpRef  { ref($_[0]) eq 'Regexp' }
 114 sub GlobRef    { ref($_[0]) eq 'GLOB'   }
 115
 116 sub FileHandle {
 117     openhandle($_[0])  || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
 118 }
 119
 120 sub Object     { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
 121
 122 sub ClassName  { Mouse::Util::is_class_loaded($_[0]) }
 123 sub RoleName   { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
 124
 125
 126 package
 127     Mouse::Meta::Module;
 128
 129 sub name          { $_[0]->{package} }
 130
 131 sub _method_map   { $_[0]->{methods} }
 132 sub _attribute_map{ $_[0]->{attribute_map} }
 133
 134 sub namespace{
 135     my $name = $_[0]->{package};
 136     no strict 'refs';
 137     return \%{ $name . '::' };
 138 }
 139
 140 sub add_method {
 141     my($self, $name, $code) = @_;
 142
 143     if(!defined $name){
 144         $self->throw_error('You must pass a defined name');
 145     }
 146     if(!defined $code){
 147         $self->throw_error('You must pass a defined code');
 148     }
 149
 150     if(ref($code) ne 'CODE'){
 151         $code = \&{$code}; # coerce
 152     }
 153
 154     $self->{methods}->{$name} = $code; # Moose stores meta object here.
 155
 156     my $pkg = $self->name;
 157     no strict 'refs';
 158     no warnings 'redefine', 'once';
 159     *{ $pkg . '::' . $name } = $code;
 160     return;
 161 }
 162
 163
 164 package
 165     Mouse::Meta::Class;
 166
 167 sub is_anon_class{
 168     return exists $_[0]->{anon_serial_id};
 169 }
 170
 171 sub roles { $_[0]->{roles} }
 172
 173 sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }
 174
 175 package
 176     Mouse::Meta::Role;
 177
 178 sub is_anon_role{
 179     return exists $_[0]->{anon_serial_id};
 180 }
 181
 182 sub get_roles { $_[0]->{roles} }
 183
 184 package
 185     Mouse::Meta::Attribute;
 186
 187 use Mouse::Meta::Method::Accessor;
 188
 189 # readers
 190
 191 sub name                 { $_[0]->{name}                   }
 192 sub associated_class     { $_[0]->{associated_class}       }
 193
 194 sub accessor             { $_[0]->{accessor}               }
 195 sub reader               { $_[0]->{reader}                 }
 196 sub writer               { $_[0]->{writer}                 }
 197 sub predicate            { $_[0]->{predicate}              }
 198 sub clearer              { $_[0]->{clearer}                }
 199 sub handles              { $_[0]->{handles}                }
 200
 201 sub _is_metadata         { $_[0]->{is}                     }
 202 sub is_required          { $_[0]->{required}               }
 203 sub default              { $_[0]->{default}                }
 204 sub is_lazy              { $_[0]->{lazy}                   }
 205 sub is_lazy_build        { $_[0]->{lazy_build}             }
 206 sub is_weak_ref          { $_[0]->{weak_ref}               }
 207 sub init_arg             { $_[0]->{init_arg}               }
 208 sub type_constraint      { $_[0]->{type_constraint}        }
 209
 210 sub trigger              { $_[0]->{trigger}                }
 211 sub builder              { $_[0]->{builder}                }
 212 sub should_auto_deref    { $_[0]->{auto_deref}             }
 213 sub should_coerce        { $_[0]->{coerce}                 }
 214
 215 sub documentation        { $_[0]->{documentation}          }
 216
 217 # predicates
 218
 219 sub has_accessor         { exists $_[0]->{accessor}        }
 220 sub has_reader           { exists $_[0]->{reader}          }
 221 sub has_writer           { exists $_[0]->{writer}          }
 222 sub has_predicate        { exists $_[0]->{predicate}       }
 223 sub has_clearer          { exists $_[0]->{clearer}         }
 224 sub has_handles          { exists $_[0]->{handles}         }
 225
 226 sub has_default          { exists $_[0]->{default}         }
 227 sub has_type_constraint  { exists $_[0]->{type_constraint} }
 228 sub has_trigger          { exists $_[0]->{trigger}         }
 229 sub has_builder          { exists $_[0]->{builder}         }
 230
 231 sub has_documentation    { exists $_[0]->{documentation}   }
 232
 233 sub accessor_metaclass(){ 'Mouse::Meta::Method::Accessor' }
 234
 235 package
 236     Mouse::Meta::TypeConstraint;
 237
 238 sub name    { $_[0]->{name}    }
 239 sub parent  { $_[0]->{parent}  }
 240 sub message { $_[0]->{message} }
 241
 242 sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
 243
 244 sub _compiled_type_coercion  { $_[0]->{_compiled_type_coercion}  }
 245
 246
 247 sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
 248
 249 1;
 250 __END__