Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Package; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Scalar::Util 'blessed', 'reftype'; |
8 | use Carp 'confess'; |
9 | use Package::Stash; |
10 | |
38bf2a25 |
11 | use base 'Class::MOP::Object'; |
12 | |
13 | # creation ... |
14 | |
15 | sub initialize { |
16 | my ( $class, @args ) = @_; |
17 | |
18 | unshift @args, "package" if @args % 2; |
19 | |
20 | my %options = @args; |
21 | my $package_name = $options{package}; |
22 | |
23 | |
24 | # we hand-construct the class |
25 | # until we can bootstrap it |
26 | if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) { |
27 | return $meta; |
28 | } else { |
29 | my $meta = ( ref $class || $class )->_new({ |
30 | 'package' => $package_name, |
31 | %options, |
32 | }); |
33 | Class::MOP::store_metaclass_by_name($package_name, $meta); |
34 | |
35 | return $meta; |
36 | } |
37 | } |
38 | |
39 | sub reinitialize { |
40 | my ( $class, @args ) = @_; |
41 | |
42 | unshift @args, "package" if @args % 2; |
43 | |
44 | my %options = @args; |
45 | my $package_name = delete $options{package}; |
46 | |
47 | (defined $package_name && $package_name |
48 | && (!blessed $package_name || $package_name->isa('Class::MOP::Package'))) |
49 | || confess "You must pass a package name or an existing Class::MOP::Package instance"; |
50 | |
51 | $package_name = $package_name->name |
52 | if blessed $package_name; |
53 | |
54 | Class::MOP::remove_metaclass_by_name($package_name); |
55 | |
56 | $class->initialize($package_name, %options); # call with first arg form for compat |
57 | } |
58 | |
59 | sub _new { |
60 | my $class = shift; |
61 | |
62 | return Class::MOP::Class->initialize($class)->new_object(@_) |
63 | if $class ne __PACKAGE__; |
64 | |
65 | my $params = @_ == 1 ? $_[0] : {@_}; |
66 | |
67 | return bless { |
9c1bf11e |
68 | # Need to quote package to avoid a problem with PPI mis-parsing this |
69 | # as a package statement. |
70 | 'package' => $params->{package}, |
38bf2a25 |
71 | |
72 | # NOTE: |
73 | # because of issues with the Perl API |
74 | # to the typeglob in some versions, we |
75 | # need to just always grab a new |
76 | # reference to the hash in the accessor. |
77 | # Ideally we could just store a ref and |
78 | # it would Just Work, but oh well :\ |
79 | |
80 | namespace => \undef, |
81 | |
82 | } => $class; |
83 | } |
84 | |
85 | # Attributes |
86 | |
87 | # NOTE: |
88 | # all these attribute readers will be bootstrapped |
89 | # away in the Class::MOP bootstrap section |
90 | |
91 | sub _package_stash { |
92 | $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name) |
93 | } |
94 | sub namespace { |
95 | $_[0]->_package_stash->namespace |
96 | } |
97 | |
98 | # Class attributes |
99 | |
100 | # ... these functions have to touch the symbol table itself,.. yuk |
101 | |
102 | sub add_package_symbol { |
103 | my $self = shift; |
104 | $self->_package_stash->add_symbol(@_); |
105 | } |
106 | |
107 | sub remove_package_glob { |
108 | my $self = shift; |
109 | $self->_package_stash->remove_glob(@_); |
110 | } |
111 | |
112 | # ... these functions deal with stuff on the namespace level |
113 | |
114 | sub has_package_symbol { |
115 | my $self = shift; |
116 | $self->_package_stash->has_symbol(@_); |
117 | } |
118 | |
119 | sub get_package_symbol { |
120 | my $self = shift; |
121 | $self->_package_stash->get_symbol(@_); |
122 | } |
123 | |
124 | sub get_or_add_package_symbol { |
125 | my $self = shift; |
126 | $self->_package_stash->get_or_add_symbol(@_); |
127 | } |
128 | |
129 | sub remove_package_symbol { |
130 | my $self = shift; |
131 | $self->_package_stash->remove_symbol(@_); |
132 | } |
133 | |
134 | sub list_all_package_symbols { |
135 | my $self = shift; |
136 | $self->_package_stash->list_all_symbols(@_); |
137 | } |
138 | |
139 | sub get_all_package_symbols { |
140 | my $self = shift; |
141 | $self->_package_stash->get_all_symbols(@_); |
142 | } |
143 | |
144 | 1; |
145 | |
146 | # ABSTRACT: Package Meta Object |
147 | |
148 | __END__ |
149 | |
150 | =pod |
151 | |
152 | =head1 DESCRIPTION |
153 | |
154 | The Package Protocol provides an abstraction of a Perl 5 package. A |
155 | package is basically namespace, and this module provides methods for |
156 | looking at and changing that namespace's symbol table. |
157 | |
158 | =head1 METHODS |
159 | |
160 | =over 4 |
161 | |
162 | =item B<< Class::MOP::Package->initialize($package_name) >> |
163 | |
164 | This method creates a new C<Class::MOP::Package> instance which |
165 | represents specified package. If an existing metaclass object exists |
166 | for the package, that will be returned instead. |
167 | |
168 | =item B<< Class::MOP::Package->reinitialize($package) >> |
169 | |
170 | This method forcibly removes any existing metaclass for the package |
171 | before calling C<initialize>. In contrast to C<initialize>, you may |
172 | also pass an existing C<Class::MOP::Package> instance instead of just |
173 | a package name as C<$package>. |
174 | |
175 | Do not call this unless you know what you are doing. |
176 | |
177 | =item B<< $metapackage->name >> |
178 | |
179 | This is returns the package's name, as passed to the constructor. |
180 | |
181 | =item B<< $metapackage->namespace >> |
182 | |
183 | This returns a hash reference to the package's symbol table. The keys |
184 | are symbol names and the values are typeglob references. |
185 | |
186 | =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >> |
187 | |
188 | This method accepts a variable name and an optional initial value. The |
189 | C<$variable_name> must contain a leading sigil. |
190 | |
191 | This method creates the variable in the package's symbol table, and |
192 | sets it to the initial value if one was provided. |
193 | |
194 | =item B<< $metapackage->get_package_symbol($variable_name) >> |
195 | |
196 | Given a variable name, this method returns the variable as a reference |
197 | or undef if it does not exist. The C<$variable_name> must contain a |
198 | leading sigil. |
199 | |
200 | =item B<< $metapackage->get_or_add_package_symbol($variable_name) >> |
201 | |
202 | Given a variable name, this method returns the variable as a reference. |
203 | If it does not exist, a default value will be generated if possible. The |
204 | C<$variable_name> must contain a leading sigil. |
205 | |
206 | =item B<< $metapackage->has_package_symbol($variable_name) >> |
207 | |
208 | Returns true if there is a package variable defined for |
209 | C<$variable_name>. The C<$variable_name> must contain a leading sigil. |
210 | |
211 | =item B<< $metapackage->remove_package_symbol($variable_name) >> |
212 | |
213 | This will remove the package variable specified C<$variable_name>. The |
214 | C<$variable_name> must contain a leading sigil. |
215 | |
216 | =item B<< $metapackage->remove_package_glob($glob_name) >> |
217 | |
218 | Given the name of a glob, this will remove that glob from the |
219 | package's symbol table. Glob names do not include a sigil. Removing |
220 | the glob removes all variables and subroutines with the specified |
221 | name. |
222 | |
223 | =item B<< $metapackage->list_all_package_symbols($type_filter) >> |
224 | |
225 | This will list all the glob names associated with the current |
226 | package. These names do not have leading sigils. |
227 | |
228 | You can provide an optional type filter, which should be one of |
229 | 'SCALAR', 'ARRAY', 'HASH', or 'CODE'. |
230 | |
231 | =item B<< $metapackage->get_all_package_symbols($type_filter) >> |
232 | |
233 | This works much like C<list_all_package_symbols>, but it returns a |
234 | hash reference. The keys are glob names and the values are references |
235 | to the value for that name. |
236 | |
237 | =item B<< Class::MOP::Package->meta >> |
238 | |
239 | This will return a L<Class::MOP::Class> instance for this class. |
240 | |
241 | =back |
242 | |
243 | =cut |