File Coverage

blib/lib/Class/Util.pm

Criterion	Covered	Total	%
statement	58	58	100.0
branch	31	36	86.1
condition	13	18	72.2
subroutine	11	11	100.0
pod	4	4	100.0
total	117	127	92.1

package Class::Util ;
$VERSION = 2.41 ;
use 5.006_001 ;
use strict ;

# This file uses the "Perlish" coding style
# please read http://perl.4pro.net/perlish_coding_style.html

; use Carp
; $Carp::Internal{+__PACKAGE__}++

; sub import
   { return unless @_
   ; require Exporter
   ; our @ISA = 'Exporter'
   ; our @EXPORT_OK = qw| load
                          gather
                          blessed
                          classes
                        |
   ; $_[0]->export_to_level(1, @_)
   }

; sub load
   { local $_ = $_[0] if defined $_[0]
   ; my $r = eval "require $_;"
   ; if ($@)
      { (my $c = $_.'.pm') =~ s|\b::\b|/|g
      ; no strict 'refs'
      ; croak $@ if $@ !~ /^Can't locate $c in \@INC/
                    || not grep { /[^:][^:]\z/ } keys %{$_.'::'}
      }
   ; $r
   }

; sub gather (&$;$)
   { my( $code, $symbol, $packages ) = @_
   ; no strict 'refs'
   ; unless ( ref $packages eq 'ARRAY' )
      { my $class = defined($packages) &&! ref($packages)
                    ? $packages
                    : blessed($packages) || caller
      ; $packages =  classes($class)
      }
   ; my $t = substr $symbol, 0, 1, ''
   ; my $type = $t eq '*' ? 'GLOB'
              : $t eq '&' ? 'CODE'
              : $t eq '%' ? 'HASH'
              : $t eq '@' ? 'ARRAY'
              : $t eq '$' ? 'SCALAR'
              : croak 'Identifier must start with [*&%@$], died'
   ;  map { $code->() }
      map { *{$_.'::'.$symbol}{$type} }
     grep { defined( $type eq 'SCALAR'
                     ? ${$_.'::'.$symbol}
                     : *{$_.'::'.$symbol}{$type}
                   )
          }
          @$packages
   }

; sub blessed
   { local $_ = $_[0] if defined $_[0]
   ; defined && length && eval{ $_->isa( ref ) }
     ? ref
     : undef
   }

; sub classes ($)
   { my $class = shift
   ; return () unless $class
   ; $class  = blessed($class) || $class
   ; my @stack   = ($class)
   ; my %skip    = ($class => 1)
   ; my (@classes, $c)
   ; while ( @stack )
      { next unless defined($c = shift @stack) && length $c
      ; unshift @classes, $c
      ; no strict 'refs';
      ; unshift @stack, map{ $skip{$_}++ ? () : $_ } @{$c.'::ISA'}
      }
   ; wantarray ? @classes : \@classes
   }


; 1

__END__