Package-Pkg-0.0020000755000765000024 011766742236 12731 5ustar00robstaff000000000000README100644000765000024 1425411766742236 13720 0ustar00robstaff000000000000Package-Pkg-0.0020NAME Package::Pkg - Handy package munging utilities VERSION version 0.0020 SYNOPSIS First, import a new keyword: "pkg" use Package::Pkg; Package name formation: pkg->name( 'Xy', 'A' ) # Xy::A pkg->name( $object, qw/ Cfg / ); # (ref $object)::Cfg Subroutine installation: pkg->install( sub { ... } => 'MyPackage::myfunction' ); # myfunction in MyPackage is now useable MyPackage->myfunction( ... ); Subroutine exporting: package MyPackage; use Package::Pkg; sub this { ... } # Setup an exporter (literally sub import { ... }) for # MyPackage, exporting 'this' and 'that' pkg->export( that => sub { ... }, 'this' ); package main; use MyPackage; this( ... ); that( ... ); DESCRIPTION Package::Pkg is a collection of useful, miscellaneous package-munging utilities. Functionality is accessed via the imported "pkg" keyword, although you can also invoke functions directly from the package ("Package::Pkg") USAGE pkg->install( ... ) Install a subroutine, similar to Sub::Install This method takes a number of parameters and also has a two- and three-argument form (see below) # Install an anonymous subroutine as Banana::magic pkg->install( code => sub { ... } , as => 'Banana::magic' ) pkg->install( code => sub { ... } , into => 'Banana::magic' ) # Bzzzt! Throws an error! # Install the subroutine Apple::xyzzy as Banana::magic pkg->install( code => 'Apple::xyzzy', as => 'Banana::magic' ) pkg->install( code => 'Apple::xyzzy', into => 'Banana', as => 'magic' ) pkg->install( from => 'Apple', code => 'xyzzy', as => 'Banana::magic' ) pkg->install( from => 'Apple', code => 'xyzzy', into => 'Banana', as => 'magic' ) # Install the subroutine Apple::xyzzy as Banana::xyzzy pkg->install( code => 'Apple::xyzzy', as => 'Banana::xyzzy' ) pkg->install( code => 'Apple::xyzzy', into => 'Banana' ) pkg->install( from => 'Apple', code => 'xyzzy', as => 'Banana::xyzzy' ) pkg->install( from => 'Apple', code => 'xyzzy', into => 'Banana' ) With implicit "from" (via "caller()") package Apple; sub xyzzy { ... } # Install the subroutine Apple::xyzzy as Banana::xyzzy pkg->install( code => 'xyzzy', as => 'Banana::xyzzy' ) # 'from' is implicitly 'Apple' pkg->install( code => \&xyzzy, as => 'Banana::xyzzy' ) Acceptable parameters are: code A subroutine reference, A package-with-name identifier, or The name of a subroutine in the calling package from (optional) A package identifier If :code is an identifier, then :from is the package where the subroutine can be found If :code is an identifier and :from is not given, then :from is assumed to be the calling package (via caller()) as The name of the subroutine to install as. Can be a simple name (when paired with :into) or a full package-with-name into (optional) A package identifier If :as is given, then the full name of the installed subroutine is (:into)::(:as) If :as is not given and we can derive a simple name from :code (It is a package-with-name identifier), then :as will be the name identifier part of :code pkg->install( $code => $as ) This is the two-argument form of subroutine installation Install $code subroutine as $as pkg->install( sub { ... } => 'Banana::xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana::xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana::' ) pkg->install( sub { ... } => 'Banana::' ) # Bzzzt! Throws an error! $code should be: * A CODE reference sub { ... } * A package-with-name identifier Scalar::Util::blessed * The name of a subroutine in the calling package sub xyzzy { ... } pkg->install( 'xyzzy' => ... ) $as should be: * A package-with-name identifier Acme::Xyzzy::magic * A package identifier (with a trailing ::) Acme::Xyzzy:: pkg->install( $code => $into, $as ) This is the three-argument form of subroutine installation pkg->install( sub { ... } => 'Banana', 'xyzzy' ) pkg->install( sub { ... } => 'Banana::', 'xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana', 'xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana::', 'xyzzy' ) $code can be the same as the two argument form $into should be: * A package identifier (trailing :: is optional) Acme::Xyzzy:: Acme::Xyzzy $as should be: * A name (the name of the subroutine) xyzzy magic $package = pkg->name( $part, [ $part, ..., $part ] ) Return a namespace composed by joining each $part with "::" Superfluous/redundant "::" are automatically cleaned up and stripped from the resulting $package If the first part leads with a "::", the the calling package will be prepended to $package pkg->name( 'Xy', 'A::', '::B' ) # Xy::A::B pkg->name( 'Xy', 'A::' ) # Xy::A:: { package Zy; pkg->name( '::', 'A::', '::B' ) # Zy::A::B pkg->name( '::Xy::A::B' ) # Zy::Xy::A::B } In addition, if any part is blessed, "name" will resolve that part to the package that the part makes reference to: my $object = bless {}, 'Xyzzy'; pkg->name( $object, qw/ Cfg / ); # Xyzzy::Cfg SEE ALSO Sub::Install Sub::Exporter AUTHOR Robert Krimen COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Robert Krimen. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Changes100644000765000024 251411766742236 14307 0ustar00robstaff000000000000Package-Pkg-0.00200.0020 Friday June 15 16:24:34 PDT 2012: - Switch to using Class::Load instead of (potentially) hidden Mouse::Util interface 0.0019 Friday June 11 23:32:55 PDT 2010: - Added Clone prerequisite 0.0018 Thursday June 10 22:00:39 PDT 2010: - Added ::Lexicon & ->lexicon - Remove "Subroutine * redefined" during t/02-install.t 0.0017 Wednesday June 09 15:55:13 PDT 2010: - Fleshed out ->install documentation - Changed behavior of ->install to be sane and have saner documentation - Added tests for ->install that reflect documentation 0.0016 Saturday June 05 21:16:11 PDT 2010: - Missed Any::Moose requirement (for Loader) - Replaced Class::MOP with Mouse::Util - Using Mouse proper instead of Any::Moose 0.0015 Thursday June 03 09:24:33 PDT 2010: - Fixed bug with exporting <.* (modification of read-only value) 0.0014 Wednesday June 02 18:54:53 PDT 2010: - Added stealth _into option to ->install (Usaginator) - Added loader - Fixed bug with exporter - ->package is now ->name 0.0013 Thursday May 13 17:48:00 PDT 2010: - ->package can now deal with the blessed 0.0012 Thursday May 13 16:46:13 PDT 2010: - Added ->package functionality 0.0011 Monday May 10 12:35:28 PDT 2010: - Include Class::MOP as a prerequisite 0.0010 Monday May 10 12:15:00 PDT 2010: - Initial release META.yml100644000765000024 76711766742236 14255 0ustar00robstaff000000000000Package-Pkg-0.0020--- abstract: 'Handy package munging utilities' author: - 'Robert Krimen ' build_requires: Test::Most: 0 configure_requires: ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300003, CPAN::Meta::Converter version 2.112150' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Package-Pkg requires: Class::Load: 0 Clone: 0 Mouse: 0 Sub::Install: 0 Try::Tiny: 0 version: 0.0020 MANIFEST100644000765000024 31111766742236 14116 0ustar00robstaff000000000000Package-Pkg-0.0020Changes MANIFEST META.yml Makefile.PL README lib/Package/Pkg.pm lib/Package/Pkg/Lexicon.pm lib/Package/Pkg/Loader.pm t/01-basic.t t/02-install.t t/03-name.t t/03-package.t t/04-loader.t t/05-lexicon.t t000755000765000024 011766742236 13115 5ustar00robstaff000000000000Package-Pkg-0.002003-name.t100644000765000024 136511766742236 14607 0ustar00robstaff000000000000Package-Pkg-0.0020/tuse strict; use warnings; use Test::Most; plan 'no_plan'; use Package::Pkg; is( pkg->name(qw/ A B C D E F /), 'A::B::C::D::E::F' ); is( pkg->name(qw/ A::B C:::D E::::F /), 'A::B::C::D::E::F' ); is( pkg->name( 'A::' ), 'A::' ); is( pkg->name( '::A' ), 'main::A' ); is( pkg->name( '::' ), '' ); is( pkg->name( 'Xy', 'A::', '::B' ), 'Xy::A::B' ); is( pkg->name( 'Xy', 'A::' ), 'Xy::A::' ); { package Zy; use Test::Most; use Package::Pkg; is( pkg->name( '::', 'A::', '::B' ), 'Zy::A::B' ); is( pkg->name( '::Xy::A::B' ), 'Zy::Xy::A::B' ); } my $zy = bless {}, 'Zy'; is( pkg->name( $zy, 'A::', '::B' ), 'Zy::A::B' ); is( pkg->name( $zy, 'Xy::A::B' ), 'Zy::Xy::A::B' ); is( pkg->name( $zy, 'Xy::A::B', {} ), 'Zy::Xy::A::B::HASH' ); Makefile.PL100644000765000024 211411766742236 14762 0ustar00robstaff000000000000Package-Pkg-0.0020 use strict; use warnings; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( "ABSTRACT" => "Handy package munging utilities", "AUTHOR" => "Robert Krimen ", "BUILD_REQUIRES" => { "Test::Most" => 0 }, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "Package-Pkg", "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "Package::Pkg", "PREREQ_PM" => { "Class::Load" => 0, "Clone" => 0, "Mouse" => 0, "Sub::Install" => 0, "Try::Tiny" => 0 }, "VERSION" => "0.0020", "test" => { "TESTS" => "t/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); 01-basic.t100644000765000024 35611766742236 14725 0ustar00robstaff000000000000Package-Pkg-0.0020/t#!/usr/bin/env perl use strict; use warnings; use Test::Most; plan 'no_plan'; package Apple; use Package::Pkg; pkg->export( xyzzy => sub { 'apple' } ); package Xyzzy; Apple->import; package main; is( Xyzzy->xyzzy, 'apple' ); 1; 04-loader.t100644000765000024 62311766742236 15112 0ustar00robstaff000000000000Package-Pkg-0.0020/tuse strict; use warnings; use Test::Most 'no_plan'; use Package::Pkg; my ( $loader ); $loader = Package::Pkg->loader(qw/ Apple Banana::Cherry /); is( $loader->load( 'p0' ), 'Apple::p0' ); is( $loader->load( 'p1' ), 'Banana::Cherry::p1' ); is( $loader->load(qw/ p0 p1 /), 'Apple::p0::p1' ); package Apple::p0; sub p0 {} package Banana::Cherry::p1; sub p1 {} package Apple::p0::p1; sub p0p1 {} 02-install.t100644000765000024 617011766742236 15333 0ustar00robstaff000000000000Package-Pkg-0.0020/tuse strict; use warnings; use Test::Most 'no_plan'; package Apple; sub apple { return 'apple'; } sub xyzzy { return 'xyzzy'; } package Xyzzy; sub frobozz { return 'frobozz'; } package main; use Package::Pkg; pkg->install( 'Xyzzy::frobozz' => 'Apple::frobozz' ); is( Apple->frobozz, 'frobozz' ); pkg->install( sub { 'banana' }, 'Apple::banana' ); is( Apple->banana, 'banana' ); pkg->install( sub { 'cherry' }, 'Apple', 'cherry' ); is( Apple->cherry, 'cherry' ); sub grape { 'grape'; } pkg->install( 'grape', 'Apple::' ); is( Apple->grape, 'grape' ); pkg->install( 'grape', 'Apple::grape1' ); is( Apple->grape1, 'grape' ); pkg->install( 'grape', 'Apple::grape1::' ); is( Apple::grape1->grape, 'grape' ); # From dox #pkg->install( code => sub { ... } , as => 'Banana::magic' ) #pkg->install( code => sub { ... } , into => 'Banana::magic' ) # Bzzzt! Throws an error! { local $SIG{__WARN__} = sub { CORE::warn(@_) if $_[0] !~ m/Subroutine \S+ redefined/ }; my $code = sub { 'code' }; pkg->install( code => $code, as => 'Banana::magic' ); is( $code, \&Banana::magic ); throws_ok { pkg->install( code => sub { } , into => 'Banana::magic' ) } qr/^Missing as/; # Install the subroutine C as C pkg->install( code => 'Apple::xyzzy', as => 'Banana::magic' ); is( \&Apple::xyzzy, \&Banana::magic ); pkg->install( code => 'Apple::xyzzy', into => 'Banana', as => 'magic' ); is( \&Apple::xyzzy, \&Banana::magic ); pkg->install( from => 'Apple', code => 'xyzzy', as => 'Banana::magic' ); is( \&Apple::xyzzy, \&Banana::magic ); pkg->install( from => 'Apple', code => 'xyzzy', into => 'Banana', as => 'magic' ); is( \&Apple::xyzzy, \&Banana::magic ); # Install the subroutine C as C pkg->install( code => 'Apple::xyzzy', as => 'Banana::xyzzy' ); is( \&Apple::xyzzy, \&Banana::xyzzy ); pkg->install( code => 'Apple::xyzzy', into => 'Banana' ); is( \&Apple::xyzzy, \&Banana::xyzzy ); pkg->install( from => 'Apple', code => 'xyzzy', as => 'Banana::xyzzy' ); is( \&Apple::xyzzy, \&Banana::xyzzy ); pkg->install( from => 'Apple', code => 'xyzzy', into => 'Banana' ); is( \&Apple::xyzzy, \&Banana::xyzzy ); } { local $SIG{__WARN__} = sub { CORE::warn(@_) if $_[0] !~ m/Subroutine \S+ redefined/ }; my $code = sub {}; pkg->install( $code => 'Banana::xyzzy' ); is( $code, \&Banana::xyzzy ); pkg->install( 'Apple::apple' => 'Banana::xyzzy' ); is( \&Apple::apple, \&Banana::xyzzy ); pkg->install( 'Apple::apple' => 'Banana::' ); throws_ok { pkg->install( $code => 'Banana::' ) } qr/^Missing as/; } { local $SIG{__WARN__} = sub { CORE::warn(@_) if $_[0] !~ m/Subroutine \S+ redefined/ }; my $code = sub {}; pkg->install( $code => 'Banana', 'xyzzy' ); is( $code, \&Banana::xyzzy ); pkg->install( $code => 'Banana::', 'xyzzy' ); is( $code, \&Banana::xyzzy ); pkg->install( 'Apple::apple' => 'Banana', 'xyzzy' ); is( \&Apple::apple, \&Banana::xyzzy ); pkg->install( 'Apple::apple' => 'Banana::', 'xyzzy' ); is( \&Apple::apple, \&Banana::xyzzy ); } 03-package.t100644000765000024 143011766742236 15253 0ustar00robstaff000000000000Package-Pkg-0.0020/tuse strict; use warnings; use Test::Most; plan 'no_plan'; use Package::Pkg; is( pkg->package(qw/ A B C D E F /), 'A::B::C::D::E::F' ); is( pkg->package(qw/ A::B C:::D E::::F /), 'A::B::C::D::E::F' ); is( pkg->package( 'A::' ), 'A::' ); is( pkg->package( '::A' ), 'main::A' ); is( pkg->package( '::' ), '' ); is( pkg->package( 'Xy', 'A::', '::B' ), 'Xy::A::B' ); is( pkg->package( 'Xy', 'A::' ), 'Xy::A::' ); { package Zy; use Test::Most; use Package::Pkg; is( pkg->package( '::', 'A::', '::B' ), 'Zy::A::B' ); is( pkg->package( '::Xy::A::B' ), 'Zy::Xy::A::B' ); } my $zy = bless {}, 'Zy'; is( pkg->package( $zy, 'A::', '::B' ), 'Zy::A::B' ); is( pkg->package( $zy, 'Xy::A::B' ), 'Zy::Xy::A::B' ); is( pkg->package( $zy, 'Xy::A::B', {} ), 'Zy::Xy::A::B::HASH' ); 05-lexicon.t100644000765000024 263111766742236 15327 0ustar00robstaff000000000000Package-Pkg-0.0020/tuse strict; use warnings; use Test::Most 'no_plan'; use Package::Pkg; use Package::Pkg::Lexicon; my ( $lexicon ); $lexicon = Package::Pkg::Lexicon->new; ok( $lexicon ); my $apple = sub { 'apple' }; my $banana = sub { 'banana' }; my $cherry = sub { 'cherry' }; my $grape = sub { 'grape' }; $lexicon->add( apple => $apple, banana => $banana ); is( scalar $lexicon->get, 2 ); cmp_deeply( { $lexicon->copy->prefix( '' )->export }, { _apple => $apple, _banana => $banana } ); cmp_deeply( { $lexicon->copy->prefix( 'prefix' )->export }, { prefix_apple => $apple, prefix_banana => $banana } ); $lexicon->add( cherry => $cherry, grape => $grape ); is( scalar $lexicon->get, 4 ); cmp_deeply( { $lexicon->copy->prefix( '' )->slice }, { apple => $apple, banana => $banana, cherry => $cherry, grape => $grape } ); { my $lexicon = $lexicon->copy->remove(qw/ apple grape /); cmp_deeply( { $lexicon->copy->prefix( '' )->slice }, { banana => $banana, cherry => $cherry } ); } cmp_deeply( { $lexicon->copy->prefix( '' )->prefix( undef )->slice }, { apple => $apple, banana => $banana, cherry => $cherry, grape => $grape } ); $lexicon = pkg->lexicon; cmp_deeply( { $lexicon->export }, {} ); $lexicon = pkg->lexicon( apple => $apple, banana => $banana, cherry => $cherry, grape => $grape ); cmp_deeply( { $lexicon->export }, { apple => $apple, banana => $banana, cherry => $cherry, grape => $grape } ); Package000755000765000024 011766742236 14753 5ustar00robstaff000000000000Package-Pkg-0.0020/libPkg.pm100644000765000024 2710611766742236 16220 0ustar00robstaff000000000000Package-Pkg-0.0020/lib/Packagepackage Package::Pkg; { $Package::Pkg::VERSION = '0.0020'; } # ABSTRACT: Handy package munging utilities use strict; use warnings; use Class::Load ':all'; require Sub::Install; use Try::Tiny; use Carp; our $pkg = __PACKAGE__; sub pkg { $pkg } __PACKAGE__->export( pkg => \&pkg ); { no warnings 'once'; *package = \&name; } sub name { my $self = shift; my $package = join '::', map { ref $_ ? ref $_ : $_ } @_; $package =~ s/:{2,}/::/g; return '' if $package eq '::'; if ( $package =~ m/^::/ ) { my $caller = caller; $package = "$caller$package"; } return $package; } sub load_name { my $self = shift; my $package = $self->name( @_ ); $self->load( $package ); return $package; } sub _is_package_loaded ($) { return is_class_loaded( $_[0] ) } sub _package2pm ($) { my $package = shift; my $pm = $package . '.pm'; $pm =~ s{::}{/}g; return $pm; } sub lexicon { my $self = shift; require Package::Pkg::Lexicon; my $lexicon = Package::Pkg::Lexicon->new; $lexicon->add( @_ ) if @_; return $lexicon; } sub loader { my $self = shift; require Package::Pkg::Loader; my $namespacelist = ref $_[0] eq 'ARRAY' ? shift : [ splice @_, 0, @_ ]; Package::Pkg::Loader->new( namespacelist => $namespacelist, @_ ); } sub load { my $self = shift; my $package = @_ > 1 ? $self->name( @_ ) : $_[0]; return Mouse::Util::load_class( $package ); } sub softload { my $self = shift; my $package = @_ > 1 ? $self->name( @_ ) : $_[0]; return $package if _is_package_loaded( $package ); my $pm = _package2pm $package; return $package if try { local $SIG{__DIE__}; require $pm; return 1; } catch { unless (/^Can't locate \Q$pm\E in \@INC/) { confess "Couldn't load package ($package) because: $_"; } return; }; } # pkg->install( name => sub { ... } => sub install { my $self = shift; my %install; if ( @_ == 1 ) { %install = %{ $_[0] } } elsif ( @_ == 2 ) { if ( $_[1] && $_[1] =~ m/::$/ ) { @install{qw/ code into /} = @_ } else { @install{qw/ code as /} = @_ } } elsif ( @_ == 3 ) { @install{qw/ code into as /} = @_ } else { %install = @_ } my ( $from, $code, $into, $_into, $as, ) = @install{qw/ from code into _into as /}; undef %install; die "Missing code (@_)" unless defined $code; if ( ref $code eq 'CODE' ) { die "Invalid (superfluous) from ($from) with code reference (@_)" if defined $from; } else { if ( defined $from ) { die "Invalid code ($code) with from ($from)" if $code =~ m/::/ } elsif ( $code =~ m/::/) { $code =~ s/^split2( $code ); } else { $from = caller } } if ( defined $as && $as =~ m/::/) { die "Invalid as ($as) with into ($into)" if defined $into; ( $into, $as ) = $self->split2( $as ); } elsif ( defined $into ) { if ( $into =~ s/::$// ) { } } elsif ( defined $_into ) { $into = $_into; } if ( defined $as ) {} elsif ( ! ref $code ) { $as = $code } else { die "Missing as (@_)" } die "Missing into (@_)" unless defined $into; @install{qw/ code into as /} = ( $code, $into, $as ); $install{from} = $from if defined $from; Sub::Install::install_sub( \%install ); } sub split { my $self = shift; my $target = shift; return unless defined $target && length $target; return split m/::/, $target; } sub split2 { my $self = shift; return unless my @split = $self->split( @_ ); return $split[0] if 1 == @split; my $name = pop @split; return( join( '::', @split ), $name ); } sub export { my $self = shift; my $exporter = $self->exporter( @_ ); my $package = caller; $self->install( code => $exporter, as => "${package}::import" ); } sub exporter { my $self = shift; my ( %index, %group, $default_export ); %group = ( default => [], optional => [], all => [] ); $default_export = 1; while ( @_ ) { local $_ = shift; my ( $group, @install ); if ( $_ eq '-' ) { undef $default_export } elsif ( $_ eq '+' ) { $default_export = 1 } elsif ( s/^\+// ) { $group = 'default' } elsif ( s/^\-// ) { $group = 'optional' } elsif ( $default_export ) { $group = 'default' } else { $group = 'optional' } my $name = $_; push @install, $name; if ( @_ ) { my $value = shift; if ( ref $value eq 'CODE' ) { push @install, $value } elsif ( $value =~ s/^[0]; my $code = $install->[1] || "${class}::$as"; __PACKAGE__->install( as => $as, code => $code, into => $package ); } }; return $exporter; } 1; __END__ =pod =head1 NAME Package::Pkg - Handy package munging utilities =head1 VERSION version 0.0020 =head1 SYNOPSIS First, import a new keyword: C use Package::Pkg; Package name formation: pkg->name( 'Xy', 'A' ) # Xy::A pkg->name( $object, qw/ Cfg / ); # (ref $object)::Cfg Subroutine installation: pkg->install( sub { ... } => 'MyPackage::myfunction' ); # myfunction in MyPackage is now useable MyPackage->myfunction( ... ); Subroutine exporting: package MyPackage; use Package::Pkg; sub this { ... } # Setup an exporter (literally sub import { ... }) for # MyPackage, exporting 'this' and 'that' pkg->export( that => sub { ... }, 'this' ); package main; use MyPackage; this( ... ); that( ... ); =head1 DESCRIPTION Package::Pkg is a collection of useful, miscellaneous package-munging utilities. Functionality is accessed via the imported C keyword, although you can also invoke functions directly from the package (C) =head1 USAGE =head2 pkg->install( ... ) Install a subroutine, similar to L This method takes a number of parameters and also has a two- and three-argument form (see below) # Install an anonymous subroutine as Banana::magic pkg->install( code => sub { ... } , as => 'Banana::magic' ) pkg->install( code => sub { ... } , into => 'Banana::magic' ) # Bzzzt! Throws an error! # Install the subroutine Apple::xyzzy as Banana::magic pkg->install( code => 'Apple::xyzzy', as => 'Banana::magic' ) pkg->install( code => 'Apple::xyzzy', into => 'Banana', as => 'magic' ) pkg->install( from => 'Apple', code => 'xyzzy', as => 'Banana::magic' ) pkg->install( from => 'Apple', code => 'xyzzy', into => 'Banana', as => 'magic' ) # Install the subroutine Apple::xyzzy as Banana::xyzzy pkg->install( code => 'Apple::xyzzy', as => 'Banana::xyzzy' ) pkg->install( code => 'Apple::xyzzy', into => 'Banana' ) pkg->install( from => 'Apple', code => 'xyzzy', as => 'Banana::xyzzy' ) pkg->install( from => 'Apple', code => 'xyzzy', into => 'Banana' ) With implicit C (via C) package Apple; sub xyzzy { ... } # Install the subroutine Apple::xyzzy as Banana::xyzzy pkg->install( code => 'xyzzy', as => 'Banana::xyzzy' ) # 'from' is implicitly 'Apple' pkg->install( code => \&xyzzy, as => 'Banana::xyzzy' ) Acceptable parameters are: code A subroutine reference, A package-with-name identifier, or The name of a subroutine in the calling package from (optional) A package identifier If :code is an identifier, then :from is the package where the subroutine can be found If :code is an identifier and :from is not given, then :from is assumed to be the calling package (via caller()) as The name of the subroutine to install as. Can be a simple name (when paired with :into) or a full package-with-name into (optional) A package identifier If :as is given, then the full name of the installed subroutine is (:into)::(:as) If :as is not given and we can derive a simple name from :code (It is a package-with-name identifier), then :as will be the name identifier part of :code =head2 pkg->install( $code => $as ) This is the two-argument form of subroutine installation Install $code subroutine as $as pkg->install( sub { ... } => 'Banana::xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana::xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana::' ) pkg->install( sub { ... } => 'Banana::' ) # Bzzzt! Throws an error! $code should be: =over =item * A CODE reference sub { ... } =item * A package-with-name identifier Scalar::Util::blessed =item * The name of a subroutine in the calling package sub xyzzy { ... } pkg->install( 'xyzzy' => ... ) =back $as should be: =over =item * A package-with-name identifier Acme::Xyzzy::magic =item * A package identifier (with a trailing ::) Acme::Xyzzy:: =back =head2 pkg->install( $code => $into, $as ) This is the three-argument form of subroutine installation pkg->install( sub { ... } => 'Banana', 'xyzzy' ) pkg->install( sub { ... } => 'Banana::', 'xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana', 'xyzzy' ) pkg->install( 'Scalar::Util::blessed' => 'Banana::', 'xyzzy' ) $code can be the same as the two argument form $into should be: =over =item * A package identifier (trailing :: is optional) Acme::Xyzzy:: Acme::Xyzzy =back $as should be: =over =item * A name (the name of the subroutine) xyzzy magic =back =head2 $package = pkg->name( $part, [ $part, ..., $part ] ) Return a namespace composed by joining each $part with C<::> Superfluous/redundant C<::> are automatically cleaned up and stripped from the resulting $package If the first part leads with a C<::>, the the calling package will be prepended to $package pkg->name( 'Xy', 'A::', '::B' ) # Xy::A::B pkg->name( 'Xy', 'A::' ) # Xy::A:: { package Zy; pkg->name( '::', 'A::', '::B' ) # Zy::A::B pkg->name( '::Xy::A::B' ) # Zy::Xy::A::B } In addition, if any part is blessed, C will resolve that part to the package that the part makes reference to: my $object = bless {}, 'Xyzzy'; pkg->name( $object, qw/ Cfg / ); # Xyzzy::Cfg =head1 SEE ALSO L L =head1 AUTHOR Robert Krimen =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2012 by Robert Krimen. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Pkg000755000765000024 011766742236 15474 5ustar00robstaff000000000000Package-Pkg-0.0020/lib/PackageLoader.pm100644000765000024 161111766742236 17377 0ustar00robstaff000000000000Package-Pkg-0.0020/lib/Package/Pkgpackage Package::Pkg::Loader; use strict; use warnings; use Mouse; use Package::Pkg; has namespacelist => qw/ is ro required 1 isa ArrayRef /; has alias => qw/ is ro lazy_build 1 isa HashRef /; sub _build_alias { {} } sub load { my $self = shift; my $moniker = @_ > 1 ? Package::Pkg->name( @_ ) : $_[0]; my $package = $self->softload( $moniker ); unless ( $package ) { my @namespacelist = @{ $self->namespacelist }; confess "Unable to load package ($moniker) under any namespace (@namespacelist)"; } return $package; } sub softload { my $self = shift; my $moniker = @_ > 1 ? Package::Pkg->name( @_ ) : $_[0]; my @namespacelist = @{ $self->namespacelist }; for my $namespace (@namespacelist) { if ( my $package = Package::Pkg->softload( $namespace, $moniker ) ) { return $package; } } return; } 1; Lexicon.pm100644000765000024 504411766742236 17576 0ustar00robstaff000000000000Package-Pkg-0.0020/lib/Package/Pkg package Package::Pkg::Lexicon; use strict; use warnings; use Mouse; use Clone qw/ clone /; has lexicon => qw/ is ro lazy_build 1 isa HashRef /; sub _build_lexicon { {} } has prefix => qw/ accessor _prefix isa Maybe[Str] /; has suffix => qw/ accessor _suffix isa Maybe[Str] /; sub prefix { my $self = shift; return $self->_prefix unless @_; $self->_prefix( $_[0] ); return $self; } sub suffix { my $self = shift; return $self->_suffix unless @_; $self->_suffix( $_[0] ); return $self; } sub copy { my $self = shift; my $lexicon; if ( @_ ) { $lexicon = { $self->slice( @_ ) } } else { $lexicon = clone( $self->lexicon ) } return (ref $self)->new( lexicon => $lexicon, prefix => $self->prefix, suffix => $self->suffix, ); } sub add { my $self = shift; die "Missing name & subroutine" unless @_; while ( @_ ) { my $name = shift; my $subroutine = shift; next unless defined $name and defined $subroutine; die "Invalid name ($name)" unless $name =~ m/^\w+$/; die "Invalid subroutine ($subroutine)" unless ref $subroutine eq 'CODE'; $self->lexicon->{$name} = $subroutine; } return $self; } sub remove { my $self = shift; die "Missing name" unless @_; for my $name ( @_ ) { next unless defined $name; delete $self->lexicon->{$name}; } return $self; } sub get { my $self = shift; my @namelist = @_ ? @_ : keys %{ $self->lexicon }; return map { defined $_ ? $self->lexicon->{$_} : undef } @namelist; } sub slice { my $self = shift; return %{ $self->lexicon } unless @_; my @namelist = @_ ? @_ : keys %{ $self->lexicon }; my @valuelist = map { defined $_ ? $self->lexicon->{$_} : undef } @namelist; my %slice; @slice{ @namelist } = @valuelist; return %slice; } sub export { my $self = shift; my @namelist = @_ ? @_ : keys %{ $self->lexicon }; my @valuelist = map { defined $_ ? $self->lexicon->{$_} : undef } @namelist; if ( defined ( my $prefix = $self->prefix ) ) { @namelist = map { defined $_ ? join '_', $prefix, $_ : undef } @namelist; } if ( defined ( my $suffix = $self->suffix ) ) { @namelist = map { defined $_ ? join '_', $_, $suffix : undef } @namelist; } my %export; @export{ @namelist } = @valuelist; return %export; } sub filter { my $self = shift; } sub map { my $self = shift; } sub install { my $self = shift; # overwrite => 0|1 # collide => 0|1|2 } 1;