From 988beb418b12b8cc4821055d79361f807c98aa36 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Tue, 15 Jun 2010 19:11:16 -0500 Subject: updated dzil stuff --- .gitignore | 2 + Changes | 24 ++--- dist.ini | 7 +- lib/Package/Stash.pm | 78 +++------------ t/000-load.t | 8 -- t/001-basic.t | 273 --------------------------------------------------- t/002-extension.t | 70 ------------- t/003-io.t | 50 ---------- t/004-get.t | 66 ------------- t/005-isa.t | 21 ---- t/006-addsub.t | 45 --------- t/01-basic.t | 273 +++++++++++++++++++++++++++++++++++++++++++++++++++ t/010-synopsis.t | 18 ---- t/02-extension.t | 70 +++++++++++++ t/03-io.t | 50 ++++++++++ t/04-get.t | 66 +++++++++++++ t/05-isa.t | 21 ++++ t/06-addsub.t | 45 +++++++++ t/10-synopsis.t | 18 ++++ weaver.ini | 37 +++++++ 20 files changed, 612 insertions(+), 630 deletions(-) delete mode 100644 t/000-load.t delete mode 100644 t/001-basic.t delete mode 100644 t/002-extension.t delete mode 100644 t/003-io.t delete mode 100644 t/004-get.t delete mode 100644 t/005-isa.t delete mode 100644 t/006-addsub.t create mode 100644 t/01-basic.t delete mode 100644 t/010-synopsis.t create mode 100644 t/02-extension.t create mode 100644 t/03-io.t create mode 100644 t/04-get.t create mode 100644 t/05-isa.t create mode 100644 t/06-addsub.t create mode 100644 t/10-synopsis.t create mode 100644 weaver.ini diff --git a/.gitignore b/.gitignore index c38068c..a2bd8da 100644 --- a/.gitignore +++ b/.gitignore @@ -9,3 +9,5 @@ Makefile.old nytprof.out MANIFEST.bak *.sw[po] +.build +Package-Stash-* diff --git a/Changes b/Changes index ae17172..5844fde 100644 --- a/Changes +++ b/Changes @@ -1,16 +1,18 @@ -Revision history for Package::Stash +Revision history for Package-Stash -0.04 2010-06-13 - get_package_symbol now doesn't autovivify stash entries. A new method - get_or_add_package_symbol can now be used for that behavior. +{{$NEXT}} - Update %DB::sub on add_package_symbol (Tim Bunce). +0.04 2010-06-13 + - get_package_symbol now doesn't autovivify stash entries. A new method + get_or_add_package_symbol can now be used for that behavior. -0.03 2010-05-14 - Rename from Stash::Manip to Package::Stash + - Update %DB::sub on add_package_symbol (Tim Bunce). -0.02 2010-05-13 - Need to dep on Test::Exception +0.03 2010-05-14 + - Rename from Stash::Manip to Package::Stash -0.01 2010-05-12 - Initial release +0.02 2010-05-13 + - Need to dep on Test::Exception + +0.01 2010-05-12 + - Initial release diff --git a/dist.ini b/dist.ini index aad335c..f4aed77 100644 --- a/dist.ini +++ b/dist.ini @@ -1,13 +1,14 @@ name = Package-Stash -version = 0.04 author = Jesse Luehrs license = Perl_5 copyright_holder = Jesse Luehrs -abstract = routines for manipulating stashes -[@Classic] +[@DOY] +dist = Package-Stash [Prereq] Scalar::Util = 0 + +[Prereq / TestRequires] Test::Exception = 0 Test::More = 0.88 diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm index 6396ed5..ddc158b 100644 --- a/lib/Package/Stash.pm +++ b/lib/Package/Stash.pm @@ -1,14 +1,11 @@ package Package::Stash; use strict; use warnings; +# ABSTRACT: routines for manipulating stashes use Carp qw(confess); use Scalar::Util qw(reftype); -=head1 NAME - -Package::Stash - routines for manipulating stashes - =head1 SYNOPSIS my $stash = Package::Stash->new('Foo'); @@ -27,11 +24,7 @@ simple API. NOTE: Most methods in this class require a variable specification that includes a sigil. If this sigil is absent, it is assumed to represent the IO slot. -=head1 METHODS - -=cut - -=head2 new $package_name +=method new $package_name Creates a new C object, for the package given as the only argument. @@ -44,7 +37,7 @@ sub new { return bless { 'package' => $namespace }, $class; } -=head2 name +=method name Returns the name of the package that this object represents. @@ -54,7 +47,7 @@ sub name { return $_[0]->{package}; } -=head2 namespace +=method namespace Returns the raw stash itself. @@ -98,7 +91,7 @@ sub namespace { } } -=head2 add_package_symbol $variable $value %opts +=method add_package_symbol $variable $value %opts Adds a new package symbol, for the symbol given as C<$variable>, and optionally gives it an initial value of C<$value>. C<$variable> should be the name of @@ -172,7 +165,7 @@ sub add_package_symbol { *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value; } -=head2 remove_package_glob $name +=method remove_package_glob $name Removes all package variables with the given name, regardless of sigil. @@ -186,7 +179,7 @@ sub remove_package_glob { # ... these functions deal with stuff on the namespace level -=head2 has_package_symbol $variable +=method has_package_symbol $variable Returns whether or not the given package variable (including sigil) exists. @@ -219,7 +212,7 @@ sub has_package_symbol { } } -=head2 get_package_symbol $variable +=method get_package_symbol $variable Returns the value of the given package variable (including sigil). @@ -269,7 +262,7 @@ sub get_package_symbol { } } -=head2 get_or_add_package_symbol $variable +=method get_or_add_package_symbol $variable Like C, except that it will return an empty hashref or arrayref if the variable doesn't exist. @@ -281,7 +274,7 @@ sub get_or_add_package_symbol { $self->get_package_symbol(@_, vivify => 1); } -=head2 remove_package_symbol $variable +=method remove_package_symbol $variable Removes the package variable described by C<$variable> (which includes the sigil); other variables with the same name but different sigils will be @@ -352,7 +345,7 @@ sub remove_package_symbol { $self->add_package_symbol($io_desc => $io) if defined $io; } -=head2 list_all_package_symbols $type_filter +=method list_all_package_symbols $type_filter Returns a list of package variable names in the package, without sigils. If a C is passed, it is used to select package variables of a given @@ -382,61 +375,16 @@ sub list_all_package_symbols { } } -=head1 BUGS - -No known bugs. - -Please report any bugs through RT: email -C, or browse to -L. - =head1 SEE ALSO -L - this module is a factoring out of code that used to -live here - -=head1 SUPPORT - -You can find this documentation for this module with the perldoc command. - - perldoc Package::Stash - -You can also look for information at: - =over 4 -=item * AnnoCPAN: Annotated CPAN documentation +=item * L -L - -=item * CPAN Ratings - -L - -=item * RT: CPAN's request tracker - -L - -=item * Search CPAN - -L +This module is a factoring out of code that used to live here =back -=head1 AUTHOR - - Jesse Luehrs - -Mostly copied from code from L, by Stevan Little and the -Moose Cabal. - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by Jesse Luehrs. - -This is free software; you can redistribute it and/or modify it under -the same terms as perl itself. - =cut 1; diff --git a/t/000-load.t b/t/000-load.t deleted file mode 100644 index 0420fe7..0000000 --- a/t/000-load.t +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More tests => 1; - -package Foo; -::use_ok('Package::Stash') - or ::BAIL_OUT("couldn't load Package::Stash"); diff --git a/t/001-basic.t b/t/001-basic.t deleted file mode 100644 index efd82b4..0000000 --- a/t/001-basic.t +++ /dev/null @@ -1,273 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use Test::Exception; - -use Package::Stash; - -dies_ok { Package::Stash->name } q{... can't call name() as a class method}; - -{ - package Foo; - - use constant SOME_CONSTANT => 1; -} - -# ---------------------------------------------------------------------- -## tests adding a HASH - -my $foo_stash = Package::Stash->new('Foo'); -ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); -ok(!$foo_stash->has_package_symbol('%foo'), '... the object agrees'); -ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); - -lives_ok { - $foo_stash->add_package_symbol('%foo' => { one => 1 }); -} '... created %Foo::foo successfully'; - -# ... scalar should NOT be created here - -ok(!$foo_stash->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); - -ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); -ok($foo_stash->has_package_symbol('%foo'), '... the meta agrees'); - -# check the value ... - -{ - no strict 'refs'; - ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); - is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); -} - -my $foo = $foo_stash->get_package_symbol('%foo'); -is_deeply({ one => 1 }, $foo, '... got the right package variable back'); - -# ... make sure changes propogate up - -$foo->{two} = 2; - -{ - no strict 'refs'; - is(\%{'Foo::foo'}, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the metas'); - - ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); - is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); -} - -# ---------------------------------------------------------------------- -## test adding an ARRAY - -ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); - -lives_ok { - $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]); -} '... created @Foo::bar successfully'; - -ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); -ok($foo_stash->has_package_symbol('@bar'), '... the meta agrees'); - -# ... why does this not work ... - -ok(!$foo_stash->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); - -# check the value itself - -{ - no strict 'refs'; - is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); - is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); -} - -# ---------------------------------------------------------------------- -## test adding a SCALAR - -ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); - -lives_ok { - $foo_stash->add_package_symbol('$baz' => 10); -} '... created $Foo::baz successfully'; - -ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); -ok($foo_stash->has_package_symbol('$baz'), '... the meta agrees'); - -ok(!$foo_stash->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); - -is(${$foo_stash->get_package_symbol('$baz')}, 10, '... got the right value back'); - -{ - no strict 'refs'; - ${'Foo::baz'} = 1; - - is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); - is(${$foo_stash->get_package_symbol('$baz')}, 1, '... the meta agrees'); -} - -# ---------------------------------------------------------------------- -## test adding a CODE - -ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); - -lives_ok { - $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk" }); -} '... created &Foo::funk successfully'; - -ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); -ok($foo_stash->has_package_symbol('&funk'), '... the meta agrees'); - -ok(!$foo_stash->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); -ok(!$foo_stash->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); - -{ - no strict 'refs'; - ok(defined &{'Foo::funk'}, '... our &funk exists'); -} - -is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); - -# ---------------------------------------------------------------------- -## test multiple slots in the glob - -my $ARRAY = [ 1, 2, 3 ]; -my $CODE = sub { "Foo::foo" }; - -lives_ok { - $foo_stash->add_package_symbol('@foo' => $ARRAY); -} '... created @Foo::foo successfully'; - -ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot was added successfully'); -is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); - -lives_ok { - $foo_stash->add_package_symbol('&foo' => $CODE); -} '... created &Foo::foo successfully'; - -ok($foo_stash->has_package_symbol('&foo'), '... the meta agrees'); -is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); - -lives_ok { - $foo_stash->add_package_symbol('$foo' => 'Foo::foo'); -} '... created $Foo::foo successfully'; - -ok($foo_stash->has_package_symbol('$foo'), '... the meta agrees'); -my $SCALAR = $foo_stash->get_package_symbol('$foo'); -is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); - -{ - no strict 'refs'; - is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); -} - -lives_ok { - $foo_stash->remove_package_symbol('%foo'); -} '... removed %Foo::foo successfully'; - -ok(!$foo_stash->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); -ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); -ok($foo_stash->has_package_symbol('&foo'), '... the &foo slot still exists'); -ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists'); - -is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); -is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -lives_ok { - $foo_stash->remove_package_symbol('&foo'); -} '... removed &Foo::foo successfully'; - -ok(!$foo_stash->has_package_symbol('&foo'), '... the &foo slot no longer exists'); - -ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); -ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists'); - -is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); -is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); - ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); -} - -lives_ok { - $foo_stash->remove_package_symbol('$foo'); -} '... removed $Foo::foo successfully'; - -ok(!$foo_stash->has_package_symbol('$foo'), '... the $foo slot no longer exists'); - -ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); - -is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); - -{ - no strict 'refs'; - ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); - ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); - ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); - ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); -} - -# check some errors - -dies_ok { - $foo_stash->add_package_symbol('@bar', {}) -} "can't initialize a slot with the wrong type of value"; - -dies_ok { - $foo_stash->add_package_symbol('bar', []) -} "can't initialize a slot with the wrong type of value"; - -dies_ok { - $foo_stash->add_package_symbol('$bar', sub { }) -} "can't initialize a slot with the wrong type of value"; - -{ - package Bar; - open *foo, '<', $0; -} - -dies_ok { - $foo_stash->add_package_symbol('$bar', *Bar::foo{IO}) -} "can't initialize a slot with the wrong type of value"; - -# check compile time manipulation - -{ - package Baz; - - our $foo = 23; - our @foo = "bar"; - our %foo = (baz => 1); - sub foo { } - open *foo, '<', $0; - BEGIN { Package::Stash->new(__PACKAGE__)->remove_package_symbol('&foo') } -} - -{ - my $stash = Package::Stash->new('Baz'); - is(${ $stash->get_package_symbol('$foo') }, 23, "got \$foo"); - is_deeply($stash->get_package_symbol('@foo'), ['bar'], "got \@foo"); - is_deeply($stash->get_package_symbol('%foo'), {baz => 1}, "got \%foo"); - ok(!$stash->has_package_symbol('&foo'), "got \&foo"); - is($stash->get_package_symbol('foo'), *Baz::foo{IO}, "got foo"); -} - -done_testing; diff --git a/t/002-extension.t b/t/002-extension.t deleted file mode 100644 index 2f95f15..0000000 --- a/t/002-extension.t +++ /dev/null @@ -1,70 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use Test::Exception; - -{ - package My::Package::Stash; - use strict; - use warnings; - - use base 'Package::Stash'; - - use Symbol 'gensym'; - - sub namespace { - $_[0]->{namespace} ||= {} - } - - sub add_package_symbol { - my ($self, $variable, $initial_value) = @_; - - my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); - - my $glob = gensym(); - *{$glob} = $initial_value if defined $initial_value; - $self->namespace->{$name} = *{$glob}; - } -} - -# No actually package Foo exists :) -my $foo_stash = My::Package::Stash->new('Foo'); - -isa_ok($foo_stash, 'My::Package::Stash'); -isa_ok($foo_stash, 'Package::Stash'); - -ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); -ok(!$foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees'); - -lives_ok { - $foo_stash->add_package_symbol('%foo' => { one => 1 }); -} '... the %foo symbol is created succcessfully'; - -ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); -ok($foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees'); - -my $foo = $foo_stash->get_package_symbol('%foo'); -is_deeply({ one => 1 }, $foo, '... got the right package variable back'); - -$foo->{two} = 2; - -is($foo, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the foo_stashs'); - -ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); - -lives_ok { - $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]); -} '... created @Foo::bar successfully'; - -ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); - -ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); - -lives_ok { - $foo_stash->add_package_symbol('%baz'); -} '... created %Foo::baz successfully'; - -ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); - -done_testing; diff --git a/t/003-io.t b/t/003-io.t deleted file mode 100644 index 43a7dd8..0000000 --- a/t/003-io.t +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Exception; - -{ - package Foo; - open *foo, "<", $0; - - sub foo { } -} - -{ - package Bar; - open *bar, "<", $0; - - sub bar { } -} - -use Package::Stash; - -{ - my $stash = Package::Stash->new('Foo'); - ok($stash->has_package_symbol('&foo'), "has &foo"); - ok($stash->has_package_symbol('foo'), "has foo"); - $stash->remove_package_symbol('&foo'); - ok(!$stash->has_package_symbol('&foo'), "has &foo"); - ok($stash->has_package_symbol('foo'), "has foo"); -} - -{ - my $stash = Package::Stash->new('Bar'); - ok($stash->has_package_symbol('&bar'), "has &bar"); - ok($stash->has_package_symbol('bar'), "has bar"); - $stash->remove_package_symbol('bar'); - ok($stash->has_package_symbol('&bar'), "has &bar"); - ok(!$stash->has_package_symbol('bar'), "has bar"); -} - -{ - my $stash = Package::Stash->new('Baz'); - lives_ok { - $stash->add_package_symbol('baz', *Foo::foo{IO}); - } "can add an IO symbol"; - ok($stash->has_package_symbol('baz'), "has baz"); - is($stash->get_package_symbol('baz'), *Foo::foo{IO}, "got the right baz"); -} - -done_testing; diff --git a/t/004-get.t b/t/004-get.t deleted file mode 100644 index ebeb864..0000000 --- a/t/004-get.t +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -use Package::Stash; - -{ - BEGIN { - my $stash = Package::Stash->new('Foo'); - my $val = $stash->get_package_symbol('%foo'); - is($val, undef, "got nothing yet"); - } - { - no warnings 'void', 'once'; - %Foo::foo; - } - BEGIN { - my $stash = Package::Stash->new('Foo'); - my $val = $stash->get_package_symbol('%foo'); - is(ref($val), 'HASH', "got something"); - $val->{bar} = 1; - is_deeply($stash->get_package_symbol('%foo'), {bar => 1}, - "got the right variable"); - } -} - -{ - BEGIN { - my $stash = Package::Stash->new('Bar'); - my $val = $stash->get_package_symbol('@foo'); - is($val, undef, "got something"); - } - { - no warnings 'void', 'once'; - @Bar::foo; - } - BEGIN { - my $stash = Package::Stash->new('Bar'); - my $val = $stash->get_package_symbol('@foo'); - is(ref($val), 'ARRAY', "got something"); - push @$val, 1; - is_deeply($stash->get_package_symbol('@foo'), [1], - "got the right variable"); - } -} - -{ - my $stash = Package::Stash->new('Baz'); - my $val = $stash->get_or_add_package_symbol('%foo'); - is(ref($val), 'HASH', "got something"); - $val->{bar} = 1; - is_deeply($stash->get_or_add_package_symbol('%foo'), {bar => 1}, - "got the right variable"); -} - -{ - my $stash = Package::Stash->new('Quux'); - my $val = $stash->get_or_add_package_symbol('@foo'); - is(ref($val), 'ARRAY', "got something"); - push @$val, 1; - is_deeply($stash->get_or_add_package_symbol('@foo'), [1], - "got the right variable"); -} - -done_testing; diff --git a/t/005-isa.t b/t/005-isa.t deleted file mode 100644 index 3198fb1..0000000 --- a/t/005-isa.t +++ /dev/null @@ -1,21 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -use Package::Stash; - -{ - package Foo; -} - -{ - package Bar; -} - -my $stash = Package::Stash->new('Foo'); -my @ISA = ('Bar'); -@{$stash->get_package_symbol('@ISA')} = @ISA; -isa_ok('Foo', 'Bar'); - -done_testing; diff --git a/t/006-addsub.t b/t/006-addsub.t deleted file mode 100644 index 3c0dfc8..0000000 --- a/t/006-addsub.t +++ /dev/null @@ -1,45 +0,0 @@ -use strict; -use warnings; - -use Test::More; -use Test::Exception; - -BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE - -use Package::Stash; - -my $foo_stash = Package::Stash->new('Foo'); - -# ---------------------------------------------------------------------- -## test adding a CODE - -ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); - -lives_ok { - $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk", __LINE__ }); -} '... created &Foo::funk successfully'; - -ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); - -{ - no strict 'refs'; - ok(defined &{'Foo::funk'}, '... our &funk exists'); -} - -is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function'); - -my $line = (Foo->funk())[1]; -is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line, - '... got the right %DB::sub value for funk default args'; - -$foo_stash->add_package_symbol( - '&dunk' => sub { "Foo::dunk" }, - filename => "FileName", - first_line_num => 100, - last_line_num => 199 -); - -is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199, - '... got the right %DB::sub value for dunk with specified args'; - -done_testing; diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..efd82b4 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,273 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +use Package::Stash; + +dies_ok { Package::Stash->name } q{... can't call name() as a class method}; + +{ + package Foo; + + use constant SOME_CONSTANT => 1; +} + +# ---------------------------------------------------------------------- +## tests adding a HASH + +my $foo_stash = Package::Stash->new('Foo'); +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_package_symbol('%foo'), '... the object agrees'); +ok(!defined($Foo::{foo}), '... checking doesn\' vivify'); + +lives_ok { + $foo_stash->add_package_symbol('%foo' => { one => 1 }); +} '... created %Foo::foo successfully'; + +# ... scalar should NOT be created here + +ok(!$foo_stash->has_package_symbol('$foo'), '... SCALAR shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('@foo'), '... ARRAY shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('&foo'), '... CODE shouldnt have been created too'); + +ok(defined($Foo::{foo}), '... the %foo slot was created successfully'); +ok($foo_stash->has_package_symbol('%foo'), '... the meta agrees'); + +# check the value ... + +{ + no strict 'refs'; + ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly'); + is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly'); +} + +my $foo = $foo_stash->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +# ... make sure changes propogate up + +$foo->{two} = 2; + +{ + no strict 'refs'; + is(\%{'Foo::foo'}, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the metas'); + + ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly'); + is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly'); +} + +# ---------------------------------------------------------------------- +## test adding an ARRAY + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]); +} '... created @Foo::bar successfully'; + +ok(defined($Foo::{bar}), '... the @bar slot was created successfully'); +ok($foo_stash->has_package_symbol('@bar'), '... the meta agrees'); + +# ... why does this not work ... + +ok(!$foo_stash->has_package_symbol('$bar'), '... SCALAR shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('%bar'), '... HASH shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('&bar'), '... CODE shouldnt have been created too'); + +# check the value itself + +{ + no strict 'refs'; + is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly'); + is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly'); +} + +# ---------------------------------------------------------------------- +## test adding a SCALAR + +ok(!defined($Foo::{baz}), '... the $baz slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('$baz' => 10); +} '... created $Foo::baz successfully'; + +ok(defined($Foo::{baz}), '... the $baz slot was created successfully'); +ok($foo_stash->has_package_symbol('$baz'), '... the meta agrees'); + +ok(!$foo_stash->has_package_symbol('@baz'), '... ARRAY shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('%baz'), '... HASH shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('&baz'), '... CODE shouldnt have been created too'); + +is(${$foo_stash->get_package_symbol('$baz')}, 10, '... got the right value back'); + +{ + no strict 'refs'; + ${'Foo::baz'} = 1; + + is(${'Foo::baz'}, 1, '... our $baz was assigned to correctly'); + is(${$foo_stash->get_package_symbol('$baz')}, 1, '... the meta agrees'); +} + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk" }); +} '... created &Foo::funk successfully'; + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); +ok($foo_stash->has_package_symbol('&funk'), '... the meta agrees'); + +ok(!$foo_stash->has_package_symbol('$funk'), '... SCALAR shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('@funk'), '... ARRAY shouldnt have been created too'); +ok(!$foo_stash->has_package_symbol('%funk'), '... HASH shouldnt have been created too'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is(Foo->funk(), 'Foo::funk', '... got the right value from the function'); + +# ---------------------------------------------------------------------- +## test multiple slots in the glob + +my $ARRAY = [ 1, 2, 3 ]; +my $CODE = sub { "Foo::foo" }; + +lives_ok { + $foo_stash->add_package_symbol('@foo' => $ARRAY); +} '... created @Foo::foo successfully'; + +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot was added successfully'); +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +lives_ok { + $foo_stash->add_package_symbol('&foo' => $CODE); +} '... created &Foo::foo successfully'; + +ok($foo_stash->has_package_symbol('&foo'), '... the meta agrees'); +is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); + +lives_ok { + $foo_stash->add_package_symbol('$foo' => 'Foo::foo'); +} '... created $Foo::foo successfully'; + +ok($foo_stash->has_package_symbol('$foo'), '... the meta agrees'); +my $SCALAR = $foo_stash->get_package_symbol('$foo'); +is($$SCALAR, 'Foo::foo', '... got the right scalar value back'); + +{ + no strict 'refs'; + is(${'Foo::foo'}, 'Foo::foo', '... got the right value from the scalar'); +} + +lives_ok { + $foo_stash->remove_package_symbol('%foo'); +} '... removed %Foo::foo successfully'; + +ok(!$foo_stash->has_package_symbol('%foo'), '... the %foo slot was removed successfully'); +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok($foo_stash->has_package_symbol('&foo'), '... the &foo slot still exists'); +ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_package_symbol('&foo'), $CODE, '... got the right value for &Foo::foo'); +is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(*{"Foo::foo"}{CODE}), '... the &foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +lives_ok { + $foo_stash->remove_package_symbol('&foo'); +} '... removed &Foo::foo successfully'; + +ok(!$foo_stash->has_package_symbol('&foo'), '... the &foo slot no longer exists'); + +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); +ok($foo_stash->has_package_symbol('$foo'), '... the $foo slot still exists'); + +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); +is($foo_stash->get_package_symbol('$foo'), $SCALAR, '... got the right value for $Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); + ok(defined(${"Foo::foo"}), '... the $foo slot has NOT been removed'); +} + +lives_ok { + $foo_stash->remove_package_symbol('$foo'); +} '... removed $Foo::foo successfully'; + +ok(!$foo_stash->has_package_symbol('$foo'), '... the $foo slot no longer exists'); + +ok($foo_stash->has_package_symbol('@foo'), '... the @foo slot still exists'); + +is($foo_stash->get_package_symbol('@foo'), $ARRAY, '... got the right values for @Foo::foo'); + +{ + no strict 'refs'; + ok(!defined(*{"Foo::foo"}{HASH}), '... the %foo slot has been removed successfully'); + ok(!defined(*{"Foo::foo"}{CODE}), '... the &foo slot has now been removed'); + ok(!defined(${"Foo::foo"}), '... the $foo slot has now been removed'); + ok(defined(*{"Foo::foo"}{ARRAY}), '... the @foo slot has NOT been removed'); +} + +# check some errors + +dies_ok { + $foo_stash->add_package_symbol('@bar', {}) +} "can't initialize a slot with the wrong type of value"; + +dies_ok { + $foo_stash->add_package_symbol('bar', []) +} "can't initialize a slot with the wrong type of value"; + +dies_ok { + $foo_stash->add_package_symbol('$bar', sub { }) +} "can't initialize a slot with the wrong type of value"; + +{ + package Bar; + open *foo, '<', $0; +} + +dies_ok { + $foo_stash->add_package_symbol('$bar', *Bar::foo{IO}) +} "can't initialize a slot with the wrong type of value"; + +# check compile time manipulation + +{ + package Baz; + + our $foo = 23; + our @foo = "bar"; + our %foo = (baz => 1); + sub foo { } + open *foo, '<', $0; + BEGIN { Package::Stash->new(__PACKAGE__)->remove_package_symbol('&foo') } +} + +{ + my $stash = Package::Stash->new('Baz'); + is(${ $stash->get_package_symbol('$foo') }, 23, "got \$foo"); + is_deeply($stash->get_package_symbol('@foo'), ['bar'], "got \@foo"); + is_deeply($stash->get_package_symbol('%foo'), {baz => 1}, "got \%foo"); + ok(!$stash->has_package_symbol('&foo'), "got \&foo"); + is($stash->get_package_symbol('foo'), *Baz::foo{IO}, "got foo"); +} + +done_testing; diff --git a/t/010-synopsis.t b/t/010-synopsis.t deleted file mode 100644 index 4c93f32..0000000 --- a/t/010-synopsis.t +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -use Package::Stash; - -my $stash = Package::Stash->new('Foo'); -$stash->add_package_symbol('%foo', {bar => 1}); -{ - no warnings 'once'; - is($Foo::foo{bar}, 1, "set in the stash properly"); -} -ok(!$stash->has_package_symbol('$foo'), "doesn't have anything in scalar slot"); -my $namespace = $stash->namespace; -is_deeply(*{ $namespace->{foo} }{HASH}, {bar => 1}, "namespace works properly"); - -done_testing; diff --git a/t/02-extension.t b/t/02-extension.t new file mode 100644 index 0000000..2f95f15 --- /dev/null +++ b/t/02-extension.t @@ -0,0 +1,70 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +{ + package My::Package::Stash; + use strict; + use warnings; + + use base 'Package::Stash'; + + use Symbol 'gensym'; + + sub namespace { + $_[0]->{namespace} ||= {} + } + + sub add_package_symbol { + my ($self, $variable, $initial_value) = @_; + + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); + + my $glob = gensym(); + *{$glob} = $initial_value if defined $initial_value; + $self->namespace->{$name} = *{$glob}; + } +} + +# No actually package Foo exists :) +my $foo_stash = My::Package::Stash->new('Foo'); + +isa_ok($foo_stash, 'My::Package::Stash'); +isa_ok($foo_stash, 'Package::Stash'); + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); +ok(!$foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees'); + +lives_ok { + $foo_stash->add_package_symbol('%foo' => { one => 1 }); +} '... the %foo symbol is created succcessfully'; + +ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); +ok($foo_stash->has_package_symbol('%foo'), '... the foo_stash agrees'); + +my $foo = $foo_stash->get_package_symbol('%foo'); +is_deeply({ one => 1 }, $foo, '... got the right package variable back'); + +$foo->{two} = 2; + +is($foo, $foo_stash->get_package_symbol('%foo'), '... our %foo is the same as the foo_stashs'); + +ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('@bar' => [ 1, 2, 3 ]); +} '... created @Foo::bar successfully'; + +ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); + +ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('%baz'); +} '... created %Foo::baz successfully'; + +ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); + +done_testing; diff --git a/t/03-io.t b/t/03-io.t new file mode 100644 index 0000000..43a7dd8 --- /dev/null +++ b/t/03-io.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Exception; + +{ + package Foo; + open *foo, "<", $0; + + sub foo { } +} + +{ + package Bar; + open *bar, "<", $0; + + sub bar { } +} + +use Package::Stash; + +{ + my $stash = Package::Stash->new('Foo'); + ok($stash->has_package_symbol('&foo'), "has &foo"); + ok($stash->has_package_symbol('foo'), "has foo"); + $stash->remove_package_symbol('&foo'); + ok(!$stash->has_package_symbol('&foo'), "has &foo"); + ok($stash->has_package_symbol('foo'), "has foo"); +} + +{ + my $stash = Package::Stash->new('Bar'); + ok($stash->has_package_symbol('&bar'), "has &bar"); + ok($stash->has_package_symbol('bar'), "has bar"); + $stash->remove_package_symbol('bar'); + ok($stash->has_package_symbol('&bar'), "has &bar"); + ok(!$stash->has_package_symbol('bar'), "has bar"); +} + +{ + my $stash = Package::Stash->new('Baz'); + lives_ok { + $stash->add_package_symbol('baz', *Foo::foo{IO}); + } "can add an IO symbol"; + ok($stash->has_package_symbol('baz'), "has baz"); + is($stash->get_package_symbol('baz'), *Foo::foo{IO}, "got the right baz"); +} + +done_testing; diff --git a/t/04-get.t b/t/04-get.t new file mode 100644 index 0000000..ebeb864 --- /dev/null +++ b/t/04-get.t @@ -0,0 +1,66 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Package::Stash; + +{ + BEGIN { + my $stash = Package::Stash->new('Foo'); + my $val = $stash->get_package_symbol('%foo'); + is($val, undef, "got nothing yet"); + } + { + no warnings 'void', 'once'; + %Foo::foo; + } + BEGIN { + my $stash = Package::Stash->new('Foo'); + my $val = $stash->get_package_symbol('%foo'); + is(ref($val), 'HASH', "got something"); + $val->{bar} = 1; + is_deeply($stash->get_package_symbol('%foo'), {bar => 1}, + "got the right variable"); + } +} + +{ + BEGIN { + my $stash = Package::Stash->new('Bar'); + my $val = $stash->get_package_symbol('@foo'); + is($val, undef, "got something"); + } + { + no warnings 'void', 'once'; + @Bar::foo; + } + BEGIN { + my $stash = Package::Stash->new('Bar'); + my $val = $stash->get_package_symbol('@foo'); + is(ref($val), 'ARRAY', "got something"); + push @$val, 1; + is_deeply($stash->get_package_symbol('@foo'), [1], + "got the right variable"); + } +} + +{ + my $stash = Package::Stash->new('Baz'); + my $val = $stash->get_or_add_package_symbol('%foo'); + is(ref($val), 'HASH', "got something"); + $val->{bar} = 1; + is_deeply($stash->get_or_add_package_symbol('%foo'), {bar => 1}, + "got the right variable"); +} + +{ + my $stash = Package::Stash->new('Quux'); + my $val = $stash->get_or_add_package_symbol('@foo'); + is(ref($val), 'ARRAY', "got something"); + push @$val, 1; + is_deeply($stash->get_or_add_package_symbol('@foo'), [1], + "got the right variable"); +} + +done_testing; diff --git a/t/05-isa.t b/t/05-isa.t new file mode 100644 index 0000000..3198fb1 --- /dev/null +++ b/t/05-isa.t @@ -0,0 +1,21 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Package::Stash; + +{ + package Foo; +} + +{ + package Bar; +} + +my $stash = Package::Stash->new('Foo'); +my @ISA = ('Bar'); +@{$stash->get_package_symbol('@ISA')} = @ISA; +isa_ok('Foo', 'Bar'); + +done_testing; diff --git a/t/06-addsub.t b/t/06-addsub.t new file mode 100644 index 0000000..3c0dfc8 --- /dev/null +++ b/t/06-addsub.t @@ -0,0 +1,45 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; + +BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE + +use Package::Stash; + +my $foo_stash = Package::Stash->new('Foo'); + +# ---------------------------------------------------------------------- +## test adding a CODE + +ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet'); + +lives_ok { + $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk", __LINE__ }); +} '... created &Foo::funk successfully'; + +ok(defined($Foo::{funk}), '... the &funk slot was created successfully'); + +{ + no strict 'refs'; + ok(defined &{'Foo::funk'}, '... our &funk exists'); +} + +is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function'); + +my $line = (Foo->funk())[1]; +is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line, + '... got the right %DB::sub value for funk default args'; + +$foo_stash->add_package_symbol( + '&dunk' => sub { "Foo::dunk" }, + filename => "FileName", + first_line_num => 100, + last_line_num => 199 +); + +is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199, + '... got the right %DB::sub value for dunk with specified args'; + +done_testing; diff --git a/t/10-synopsis.t b/t/10-synopsis.t new file mode 100644 index 0000000..4c93f32 --- /dev/null +++ b/t/10-synopsis.t @@ -0,0 +1,18 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Package::Stash; + +my $stash = Package::Stash->new('Foo'); +$stash->add_package_symbol('%foo', {bar => 1}); +{ + no warnings 'once'; + is($Foo::foo{bar}, 1, "set in the stash properly"); +} +ok(!$stash->has_package_symbol('$foo'), "doesn't have anything in scalar slot"); +my $namespace = $stash->namespace; +is_deeply(*{ $namespace->{foo} }{HASH}, {bar => 1}, "namespace works properly"); + +done_testing; diff --git a/weaver.ini b/weaver.ini new file mode 100644 index 0000000..31f851b --- /dev/null +++ b/weaver.ini @@ -0,0 +1,37 @@ +[@CorePrep] + +[Name] +[Version] + +[Region / prelude] + +[Generic / SYNOPSIS] +[Generic / DESCRIPTION] +[Generic / OVERVIEW] + +[Collect / ATTRIBUTES] +command = attr + +[Collect / METHODS] +command = method + +[Collect / FUNCTIONS] +command = func + +[Leftovers] + +[Region / postlude] + +[Template / BUGS] +template = ~/.dzil/pod_templates/bugs.section +main_module_only = 1 + +[Generic / SEEALSO] +header = SEE ALSO + +[Template / SUPPORT] +template = ~/.dzil/pod_templates/support.section +main_module_only = 1 + +[Authors] +[Legal] -- cgit v1.2.3-54-g00ecf