File Coverage

blib/lib/Package/Subroutine.pm

Criterion	Covered	Total	%
statement	44	66	66.6
branch	6	18	33.3
condition			n/a
subroutine	10	15	66.6
pod	10	10	100.0
total	70	109	64.2

package Package::Subroutine;
# **************************
$VERSION = '0.22.001';
# ****************
; no strict 'refs'

; use Class::ISA ()

; sub export_to_caller
    { my ($self,$level) = @_
    ; my $namespace = (caller($level))[0]
    ; return sub
      { my ($from,@methods) = @_
      ; $from = caller if $from eq '_'
      ; exporter($namespace,$from,@methods)
      }
    }

; sub export_to
    { my ($self,$namespace) = @_
    ; return sub
        { my ($from,@methods) = @_
        ; $from = caller if $from eq '_'
        ; exporter($namespace,$from,@methods)
        }
    }

; sub export
    { my $ns = (caller(1))[0]
    ; shift() # rm package
    # working shortcut for __PACKAGE__
    ; splice(@_,0,1,"".caller) if $_[0] eq '_'
    ; exporter($ns,@_)
    }

; sub import
    { my $ns = (caller(0))[0]
    ; shift() # rm package
    ; exporter($ns,@_)
    }

; sub mixin
    { my $ns  = (caller(0))[0]
    ; my $pkg = shift()
    ; if(@_==1)
        { push @_, $pkg->findsubs($_[0])
        }
    ; exporter($ns,@_)
    }

; sub exporter
    { my $namespace = shift
    ; my $from      = shift
    ; my @methods   = @_
    ; local $_

    ; for ( @methods )
        { my $srcm = my $trgm = $_
        ; ($srcm,$trgm) = @$_ if ref eq 'ARRAY'
        ; my $target = "${namespace}::${trgm}"
        ; my $source = "${from}::${srcm}"
        ; *$target = \&$source
        }
    }

; sub version
    { my ($f,$pkg,$num)=@_
    ; if( defined($num) )
        { $num=eval { UNIVERSAL::VERSION($pkg,$num) }
        ; return $@ ? undef : $num
        }
    ; eval { UNIVERSAL::VERSION($pkg) }
    }

; sub install
   { my ($pkg,$target,$name,$coderef)=@_
   ; $target="${target}::${name}"
   ; *$target = $coderef
   }

; sub isdefined
   { my ($pkg,$namespace,$subname)=@_
   ; unless($subname)
       { my @ns = split /\'|\:\:/, $namespace
       ; $subname = pop @ns
       ; $namespace = join "::",@ns
       }
   ; *{"${namespace}::${subname}"}{CODE} || undef
   }

; sub findsubs
   { my ($self,$class)=@_
   ; grep { *{"${class}::${_}"}{CODE} } keys %{"${class}::"}
   }

; sub findmethods
   { my ($self,$class)=@_
   ; my %methods = map { $_ => 1 }
       map { $self->findsubs($_) }
       reverse  (Class::ISA::self_and_super_path($class),'UNIVERSAL')
   ; return keys %methods
   }

; 1

__END__