← Back to branch summary

~ubuntu-branches/ubuntu/karmic/libclass-meta-perl/karmic

« back to all changes in this revision

Viewing changes to lib/Class/Meta/Constructor.pm

  • Committer: Bazaar Package Importer
  • Author(s): Krzysztof Krzyzaniak (eloy)
  • Date: 2006-01-03 17:29:20 UTC
  • Revision ID: james.westby@ubuntu.com-20060103172920-h94p8qrrav90bzq0
Tags: upstream-0.52
Import upstream version 0.52

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Class/Meta/Constructor.pm
 
1
package Class::Meta::Constructor;
 
2
 
 
3
# $Id: Constructor.pm 2449 2005-12-30 00:07:53Z theory $
 
4
 
 
5
=head1 NAME
 
6
 
 
7
Class::Meta::Constructor - Class::Meta class constructor introspection
 
8
 
 
9
=head1 SYNOPSIS
 
10
 
 
11
  # Assuming MyApp::Thingy was generated by Class::Meta.
 
12
  my $class = MyApp::Thingy->my_class;
 
13
 
 
14
  print "\nConstructors:\n";
 
15
  for my $ctor ($class->constructors) {
 
16
      print "  o ", $ctor->name, $/;
 
17
      my $thingy = $ctor->call($class->package);
 
18
  }
 
19
 
 
20
=head1 DESCRIPTION
 
21
 
 
22
This class provides an interface to the C<Class::Meta> objects that describe
 
23
class constructors. It supports a simple description of the constructor, a
 
24
label, and the constructor visibility (private, protected, trusted,or public).
 
25
 
 
26
Class::Meta::Constructor objects are created by Class::Meta; they are never
 
27
instantiated directly in client code. To access the constructor objects for a
 
28
Class::Meta-generated class, simply call its C<my_class()> method to retrieve
 
29
its Class::Meta::Class object, and then call the C<constructors()> method on
 
30
the Class::Meta::Class object.
 
31
 
 
32
=cut
 
33
 
 
34
##############################################################################
 
35
# Dependencies                                                               #
 
36
##############################################################################
 
37
use strict;
 
38
 
 
39
##############################################################################
 
40
# Package Globals                                                            #
 
41
##############################################################################
 
42
our $VERSION = "0.52";
 
43
 
 
44
##############################################################################
 
45
# Constructors                                                               #
 
46
##############################################################################
 
47
 
 
48
=head1 INTERFACE
 
49
 
 
50
=head2 Constructors
 
51
 
 
52
=head3 new
 
53
 
 
54
A protected method for constructing a Class::Meta::Constructor object. Do not
 
55
call this method directly; Call the
 
56
L<C<add_constructor()>|Class::Meta/"add_constructor"> method on a Class::Meta
 
57
object, instead.
 
58
 
 
59
=cut
 
60
 
 
61
sub new {
 
62
    my $pkg = shift;
 
63
    my $class = shift;
 
64
 
 
65
    # Check to make sure that only Class::Meta or a subclass is constructing a
 
66
    # Class::Meta::Constructor object.
 
67
    my $caller = caller;
 
68
    Class::Meta->handle_error("Package '$caller' cannot create $pkg "
 
69
                              . "objects")
 
70
      unless UNIVERSAL::isa($caller, 'Class::Meta')
 
71
        || UNIVERSAL::isa($caller, __PACKAGE__);
 
72
 
 
73
    # Make sure we can get all the arguments.
 
74
    $class->handle_error("Odd number of parameters in call to new() when "
 
75
                         . "named parameters were expected")
 
76
      if @_ % 2;
 
77
    my %p = @_;
 
78
 
 
79
    # Validate the name.
 
80
    $class->handle_error("Parameter 'name' is required in call to new()")
 
81
      unless $p{name};
 
82
    $class->handle_error("Constructor '$p{name}' is not a valid constructor "
 
83
                         . "name -- only alphanumeric and '_' characters "
 
84
                         . "allowed")
 
85
      if $p{name} =~ /\W/;
 
86
 
 
87
    # Make sure the name hasn't already been used for another constructor or
 
88
    # method.
 
89
    $class->handle_error("Method '$p{name}' already exists in class "
 
90
                         . "'$class->{package}'")
 
91
      if exists $class->{ctors}{$p{name}}
 
92
      or exists $class->{meths}{$p{name}};
 
93
 
 
94
    # Check the visibility.
 
95
    if (exists $p{view}) {
 
96
        $class->handle_error("Not a valid view parameter: '$p{view}'")
 
97
          unless $p{view} == Class::Meta::PUBLIC
 
98
          ||     $p{view} == Class::Meta::PROTECTED
 
99
          ||     $p{view} == Class::Meta::TRUSTED
 
100
          ||     $p{view} == Class::Meta::PRIVATE;
 
101
    } else {
 
102
        # Make it public by default.
 
103
        $p{view} = Class::Meta::PUBLIC;
 
104
    }
 
105
 
 
106
    # Check the creation constant.
 
107
    $p{create} = 1 unless defined $p{create};
 
108
 
 
109
    # Validate or create the method caller if necessary.
 
110
    if ($p{caller}) {
 
111
        my $ref = ref $p{caller};
 
112
        $class->handle_error("Parameter caller must be a code reference")
 
113
          unless $ref && $ref eq 'CODE';
 
114
    } else {
 
115
        $p{caller} = UNIVERSAL::can($class->{package}, $p{name})
 
116
          unless $p{create};
 
117
    }
 
118
 
 
119
    # Create and cache the constructor object.
 
120
    $p{package} = $class->{package};
 
121
    $class->{ctors}{$p{name}} = bless \%p, ref $pkg || $pkg;
 
122
 
 
123
    # Index its view.
 
124
    push @{ $class->{all_ctor_ord} }, $p{name};
 
125
    if ($p{view} > Class::Meta::PRIVATE) {
 
126
        push @{$class->{prot_ctor_ord}}, $p{name}
 
127
          unless $p{view} == Class::Meta::TRUSTED;
 
128
        if ($p{view} > Class::Meta::PROTECTED) {
 
129
            push @{$class->{trst_ctor_ord}}, $p{name};
 
130
            push @{$class->{ctor_ord}}, $p{name}
 
131
              if $p{view} == Class::Meta::PUBLIC;
 
132
        }
 
133
    }
 
134
 
 
135
    # Store a reference to the class object.
 
136
    $p{class} = $class;
 
137
 
 
138
    # Let 'em have it.
 
139
    return $class->{ctors}{$p{name}};
 
140
}
 
141
 
 
142
 
 
143
##############################################################################
 
144
# Instance Methods                                                           #
 
145
##############################################################################
 
146
 
 
147
=head2 Instance Methods
 
148
 
 
149
=head3 name
 
150
 
 
151
  my $name = $ctor->name;
 
152
 
 
153
Returns the constructor name.
 
154
 
 
155
=head3 package
 
156
 
 
157
  my $package = $ctor->package;
 
158
 
 
159
Returns the package name of the class that constructor is associated with.
 
160
 
 
161
=head3 desc
 
162
 
 
163
  my $desc = $ctor->desc;
 
164
 
 
165
Returns the description of the constructor.
 
166
 
 
167
=head3 label
 
168
 
 
169
  my $desc = $ctor->label;
 
170
 
 
171
Returns label for the constructor.
 
172
 
 
173
=head3 view
 
174
 
 
175
  my $view = $ctor->view;
 
176
 
 
177
Returns the view of the constructor, reflecting its visibility. The possible
 
178
values are defined by the following constants:
 
179
 
 
180
=over 4
 
181
 
 
182
=item Class::Meta::PUBLIC
 
183
 
 
184
=item Class::Meta::PRIVATE
 
185
 
 
186
=item Class::Meta::TRUSTED
 
187
 
 
188
=item Class::Meta::PROTECTED
 
189
 
 
190
=back
 
191
 
 
192
=head3 class
 
193
 
 
194
  my $class = $ctor->class;
 
195
 
 
196
Returns the Class::Meta::Class object that this constructor is associated
 
197
with. Note that this object will always represent the class in which the
 
198
constructor is defined, and I<not> any of its subclasses.
 
199
 
 
200
=cut
 
201
 
 
202
sub name    { $_[0]->{name}    }
 
203
sub package { $_[0]->{package} }
 
204
sub desc    { $_[0]->{desc}    }
 
205
sub label   { $_[0]->{label}   }
 
206
sub view    { $_[0]->{view}    }
 
207
sub class   { $_[0]->{class}   }
 
208
 
 
209
=head3 call
 
210
 
 
211
  my $obj = $ctor->call($package, @params);
 
212
 
 
213
Executes the constructor. Pass in the name of the class for which it is being
 
214
executed (since, thanks to subclassing, it may be different than the class
 
215
with which the constructor is associated). All other parameters will be passed
 
216
to the constructor. Note that it uses a C<goto> to execute the constructor, so
 
217
the call to C<call()> itself will not appear in a call stack trace.
 
218
 
 
219
=cut
 
220
 
 
221
sub call {
 
222
    my $self = shift;
 
223
    my $code = $self->{caller}
 
224
      or $self->class->handle_error("Cannot call constructor '",
 
225
                                    $self->name, "'");
 
226
    goto &$code;
 
227
}
 
228
 
 
229
##############################################################################
 
230
 
 
231
=head3 build
 
232
 
 
233
  $ctor->build($class);
 
234
 
 
235
This is a protected method, designed to be called only by the Class::Meta
 
236
class or a subclass of Class::Meta. It takes a single argument, the
 
237
Class::Meta::Class object for the class in which the constructor was defined,
 
238
and generates constructor methods for the Class::Meta::Constructor object.
 
239
 
 
240
Although you should never call this method directly, subclasses of
 
241
Class::Meta::Constructor may need to override its behavior.
 
242
 
 
243
=cut
 
244
 
 
245
sub build {
 
246
    my ($self, $specs) = @_;
 
247
 
 
248
    # Check to make sure that only Class::Meta or a subclass is building
 
249
    # constructors.
 
250
    my $caller = caller;
 
251
    $self->class->handle_error("Package '$caller' cannot call " . ref($self)
 
252
                               . "->build")
 
253
      unless UNIVERSAL::isa($caller, 'Class::Meta')
 
254
        || UNIVERSAL::isa($caller, __PACKAGE__);
 
255
 
 
256
    # Just bail if we're not creating the constructor.
 
257
    return $self unless delete $self->{create};
 
258
 
 
259
    # Build a construtor that takes a parameter list and assigns the
 
260
    # the values to the appropriate attributes.
 
261
    my $name = $self->name;
 
262
 
 
263
    my $sub = sub {
 
264
        my $package = ref $_[0] ? ref shift : shift;
 
265
        my $class = $specs->{$package};
 
266
 
 
267
        # Throw an exception for attempts to create items of an abstract
 
268
        # class.
 
269
        $class->handle_error(
 
270
            "Cannot construct objects of astract class $package"
 
271
        ) if $class->abstract;
 
272
 
 
273
        # Just grab the parameters and let an error be thrown by Perl
 
274
        # if there aren't the right number of them.
 
275
        my %p = @_;
 
276
        my $new = bless {}, $package;
 
277
 
 
278
        # Assign all of the attribute values.
 
279
        if (my $attrs = $class->{attrs}) {
 
280
            foreach my $attr (@{ $attrs }{ @{ $class->{all_attr_ord} } }) {
 
281
                # Skip class attributes.
 
282
                next if $attr->context == Class::Meta::CLASS;
 
283
                my $key = $attr->name;
 
284
                if (exists $p{$key} && $attr->authz >= Class::Meta::SET) {
 
285
                    # Let them set the value.
 
286
                    $attr->set($new, delete $p{$key});
 
287
                } else {
 
288
                    # Use the default value.
 
289
                    $new->{$key} = $attr->default unless exists $new->{$key};
 
290
                }
 
291
            }
 
292
        }
 
293
 
 
294
        # Check for params for which attributes are private or don't exist.
 
295
        if (my @attributes = keys %p) {
 
296
            # Attempts to assign to non-existent attributes fail.
 
297
            my $c = $#attributes > 0 ? 'attributes' : 'attribute';
 
298
            local $" = "', '";
 
299
            $class->handle_error(
 
300
                "No such $c '@attributes' in $self->{package} objects"
 
301
            );
 
302
        }
 
303
        return $new;
 
304
    };
 
305
 
 
306
    # Add protected, private, or trusted checks, if required.
 
307
    if ($self->view == Class::Meta::PROTECTED) {
 
308
        my $real_sub = $sub;
 
309
        my $pkg      = $self->package;
 
310
        my $class    = $self->class;
 
311
        $sub = sub {
 
312
             $class->handle_error("$name is a protected constrctor of $pkg")
 
313
                 unless caller->isa($pkg);
 
314
             goto &$real_sub;
 
315
        };
 
316
    } elsif ($self->view == Class::Meta::PRIVATE) {
 
317
        my $real_sub = $sub;
 
318
        my $pkg      = $self->package;
 
319
        my $class    = $self->class;
 
320
        $sub = sub {
 
321
            $class->handle_error("$name is a private constructor of $pkg")
 
322
                unless caller eq $pkg;
 
323
             goto &$real_sub;
 
324
         };
 
325
    }
 
326
 
 
327
    # Install the constructor.
 
328
    $self->{caller} ||= $sub;
 
329
    no strict 'refs';
 
330
    *{"$self->{package}::$name"} = $sub;
 
331
}
 
332
 
 
333
1;
 
334
__END__
 
335
 
 
336
=head1 BUGS
 
337
 
 
338
Please send bug reports to <bug-class-meta@rt.cpan.org> or report them via the
 
339
CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
 
340
 
 
341
=head1 AUTHOR
 
342
 
 
343
David Wheeler <david@kineticode.com>
 
344
 
 
345
=head1 SEE ALSO
 
346
 
 
347
Other classes of interest within the Class::Meta distribution include:
 
348
 
 
349
=over 4
 
350
 
 
351
=item L<Class::Meta|Class::Meta>
 
352
 
 
353
=item L<Class::Meta::Class|Class::Meta::Class>
 
354
 
 
355
=item L<Class::Meta::Method|Class::Meta::Method>
 
356
 
 
357
=item L<Class::Meta::Attribute|Class::Meta::Attribute>
 
358
 
 
359
=back
 
360
 
 
361
=head1 COPYRIGHT AND LICENSE
 
362
 
 
363
Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
 
364
 
 
365
This module is free software; you can redistribute it and/or modify it under
 
366
the same terms as Perl itself.
 
367
 
 
368
=cut