Commit | Line | Data |
38bf2a25 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Fatal; |
6 | |
7 | use Class::MOP; |
8 | |
9 | { |
10 | package My::Package::Stash; |
11 | use strict; |
12 | use warnings; |
13 | |
14 | use base 'Package::Stash'; |
15 | |
16 | use metaclass; |
17 | |
18 | use Symbol 'gensym'; |
19 | |
20 | __PACKAGE__->meta->add_attribute( |
21 | 'namespace' => ( |
22 | reader => 'namespace', |
23 | default => sub { {} } |
24 | ) |
25 | ); |
26 | |
27 | sub new { |
28 | my $class = shift; |
29 | $class->meta->new_object(__INSTANCE__ => $class->SUPER::new(@_)); |
30 | } |
31 | |
32 | sub add_symbol { |
33 | my ($self, $variable, $initial_value) = @_; |
34 | |
35 | (my $name = $variable) =~ s/^[\$\@\%\&]//; |
36 | |
37 | my $glob = gensym(); |
38 | *{$glob} = $initial_value if defined $initial_value; |
39 | $self->namespace->{$name} = *{$glob}; |
40 | } |
41 | } |
42 | |
43 | { |
44 | package My::Meta::Package; |
45 | |
46 | use strict; |
47 | use warnings; |
48 | |
49 | use base 'Class::MOP::Package'; |
50 | |
51 | sub _package_stash { |
52 | $_[0]->{_package_stash} ||= My::Package::Stash->new($_[0]->name); |
53 | } |
54 | } |
55 | |
56 | # No actually package Foo exists :) |
57 | my $meta = My::Meta::Package->initialize('Foo'); |
58 | |
59 | isa_ok($meta, 'My::Meta::Package'); |
60 | isa_ok($meta, 'Class::MOP::Package'); |
61 | |
62 | ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet'); |
63 | ok(!$meta->has_package_symbol('%foo'), '... the meta agrees'); |
64 | |
65 | is( exception { |
66 | $meta->add_package_symbol('%foo' => { one => 1 }); |
67 | }, undef, '... the %foo symbol is created succcessfully' ); |
68 | |
69 | ok(!defined($Foo::{foo}), '... the %foo slot has not been created in the actual Foo package'); |
70 | ok($meta->has_package_symbol('%foo'), '... the meta agrees'); |
71 | |
72 | my $foo = $meta->get_package_symbol('%foo'); |
73 | is_deeply({ one => 1 }, $foo, '... got the right package variable back'); |
74 | |
75 | $foo->{two} = 2; |
76 | |
77 | is($foo, $meta->get_package_symbol('%foo'), '... our %foo is the same as the metas'); |
78 | |
79 | ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet'); |
80 | |
81 | is( exception { |
82 | $meta->add_package_symbol('@bar' => [ 1, 2, 3 ]); |
83 | }, undef, '... created @Foo::bar successfully' ); |
84 | |
85 | ok(!defined($Foo::{bar}), '... the @bar slot has still not been created'); |
86 | |
87 | ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet'); |
88 | |
89 | is( exception { |
90 | $meta->add_package_symbol('%baz'); |
91 | }, undef, '... created %Foo::baz successfully' ); |
92 | |
93 | ok(!defined($Foo::{baz}), '... the %baz slot has still not been created'); |
94 | |
95 | done_testing; |