File: Instance.pm

package info (click to toggle)
libclass-mop-perl 0.36-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 552 kB
  • ctags: 209
  • sloc: perl: 6,157; makefile: 46
file content (331 lines) | stat: -rw-r--r-- 7,977 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331

package Class::MOP::Instance;

use strict;
use warnings;

use Scalar::Util 'weaken', 'blessed';

our $VERSION   = '0.03';
our $AUTHORITY = 'cpan:STEVAN';

sub meta { 
    require Class::MOP::Class;
    Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
}

sub new { 
    my ($class, $meta, @attrs) = @_;
    my @slots = map { $_->slots } @attrs;
    bless {
        # NOTE:
        # I am not sure that it makes
        # sense to pass in the meta
        # The ideal would be to just 
        # pass in the class name, but 
        # that is placing too much of 
        # an assumption on bless(), 
        # which is *probably* a safe
        # assumption,.. but you can 
        # never tell <:)
        meta  => $meta,
        slots => { map { $_ => undef } @slots },
    } => $class; 
}

sub create_instance {
    my $self = shift;
    $self->bless_instance_structure({});
}

sub bless_instance_structure {
    my ($self, $instance_structure) = @_;
    bless $instance_structure, $self->{meta}->name;
}

sub clone_instance {
    my ($self, $instance) = @_;
    $self->bless_instance_structure({ %$instance });
}

# operations on meta instance

sub get_all_slots {
    my $self = shift;
    return keys %{$self->{slots}};
}

sub is_valid_slot {
    my ($self, $slot_name) = @_;
    exists $self->{slots}->{$slot_name} ? 1 : 0;
}

# operations on created instances

sub get_slot_value {
    my ($self, $instance, $slot_name) = @_;
    return $instance->{$slot_name};
}

sub set_slot_value {
    my ($self, $instance, $slot_name, $value) = @_;
    $instance->{$slot_name} = $value;
}

sub initialize_slot {
    my ($self, $instance, $slot_name) = @_;
    $self->set_slot_value($instance, $slot_name, undef);
}

sub deinitialize_slot {
    my ( $self, $instance, $slot_name ) = @_;
    delete $instance->{$slot_name};
}

sub initialize_all_slots {
    my ($self, $instance) = @_;
    foreach my $slot_name ($self->get_all_slots) {
        $self->initialize_slot($instance, $slot_name);
    }
}

sub deinitialize_all_slots {
    my ($self, $instance) = @_;
    foreach my $slot_name ($self->get_all_slots) {
        $self->deinitialize_slot($instance, $slot_name);
    }
}

sub is_slot_initialized {
    my ($self, $instance, $slot_name, $value) = @_;
    exists $instance->{$slot_name} ? 1 : 0;
}

sub weaken_slot_value {
	my ($self, $instance, $slot_name) = @_;
	weaken $instance->{$slot_name};
}

sub strengthen_slot_value {
	my ($self, $instance, $slot_name) = @_;
	$self->set_slot_value($instance, $slot_name, $self->get_slot_value($instance, $slot_name));
}

# inlinable operation snippets

sub is_inlinable { 1 }

sub inline_create_instance {
    my ($self, $class_variable) = @_;
    'bless {} => ' . $class_variable;
}

sub inline_slot_access {
    my ($self, $instance, $slot_name) = @_;
    sprintf "%s->{%s}", $instance, $slot_name;
}

sub inline_get_slot_value {
    my ($self, $instance, $slot_name) = @_;
    $self->inline_slot_access($instance, $slot_name);
}

sub inline_set_slot_value {
    my ($self, $instance, $slot_name, $value) = @_;
    $self->inline_slot_access($instance, $slot_name) . " = $value", 
}

sub inline_initialize_slot {
    my ($self, $instance, $slot_name) = @_;
    $self->inline_set_slot_value($instance, $slot_name, 'undef'),
}

sub inline_deinitialize_slot {
    my ($self, $instance, $slot_name) = @_;
    "delete " . $self->inline_slot_access($instance, $slot_name);
}
sub inline_is_slot_initialized {
    my ($self, $instance, $slot_name) = @_;
    "exists " . $self->inline_slot_access($instance, $slot_name) . " ? 1 : 0";
}

sub inline_weaken_slot_value {
    my ($self, $instance, $slot_name) = @_;
    sprintf "Scalar::Util::weaken( %s )", $self->inline_slot_access($instance, $slot_name);
}

sub inline_strengthen_slot_value {
    my ($self, $instance, $slot_name) = @_;
    $self->inline_set_slot_value($instance, $slot_name, $self->inline_slot_access($instance, $slot_name));
}

1;

__END__

=pod

=head1 NAME 

Class::MOP::Instance - Instance Meta Object

=head1 SYNOPSIS

  # for the most part, this protocol is internal 
  # and not for public usage, but this how one 
  # might use it
  
  package Foo;
  
  use strict;
  use warnings;
  use metaclass (
      ':instance_metaclass'  => 'ArrayBasedStorage::Instance',
  );
  
  # now Foo->new produces blessed ARRAY ref based objects

=head1 DESCRIPTION

This is a sub-protocol which governs instance creation 
and access to the slots of the instance structure.

This may seem like over-abstraction, but by abstracting 
this process into a sub-protocol we make it possible to 
easily switch the details of how an object's instance is 
stored with minimal impact. In most cases just subclassing 
this class will be all you need to do (see the examples; 
F<examples/ArrayBasedStorage.pod> and 
F<examples/InsideOutClass.pod> for details).

=head1 METHODS

=over 4

=item B<new ($meta, @attrs)>

Creates a new instance meta-object and gathers all the slots from 
the list of C<@attrs> given.

=item B<meta>

This will return a B<Class::MOP::Class> instance which is related 
to this class.

=back

=head2 Creation of Instances

=over 4

=item B<create_instance>

This creates the appropriate structure needed for the instance and 
then calls C<bless_instance_structure> to bless it into the class.

=item B<bless_instance_structure ($instance_structure)>

This does just exactly what it says it does.

=item B<clone_instance ($instance_structure)>

=back

=head2 Instrospection

NOTE: There might be more methods added to this part of the API, 
we will add then when we need them basically.

=over 4

=item B<get_all_slots>

This will return the current list of slots based on what was 
given to this object in C<new>.

=item B<is_valid_slot ($slot_name)>

=back

=head2 Operations on Instance Structures

An important distinction of this sub-protocol is that the 
instance meta-object is a different entity from the actual 
instance it creates. For this reason, any actions on slots 
require that the C<$instance_structure> is passed into them.

=over 4

=item B<get_slot_value ($instance_structure, $slot_name)>

=item B<set_slot_value ($instance_structure, $slot_name, $value)>

=item B<initialize_slot ($instance_structure, $slot_name)>

=item B<deinitialize_slot ($instance_structure, $slot_name)>

=item B<initialize_all_slots ($instance_structure)>

=item B<deinitialize_all_slots ($instance_structure)>

=item B<is_slot_initialized ($instance_structure, $slot_name)>

=item B<weaken_slot_value ($instance_structure, $slot_name)>

=item B<strengthen_slot_value ($instance_structure, $slot_name)>

=back

=head2 Inlineable Instance Operations

This part of the API is currently un-used. It is there for use 
in future experiments in class finailization mostly. Best to 
ignore this for now.

=over 4

=item B<is_inlinable>

Each meta-instance should override this method to tell Class::MOP if it's 
possible to inline the slot access. 

This is currently only used by Class::MOP::Class::Immutable when performing 
optimizations.

=item B<inline_create_instance>

=item B<inline_slot_access ($instance_structure, $slot_name)>

=item B<inline_get_slot_value ($instance_structure, $slot_name)>

=item B<inline_set_slot_value ($instance_structure, $slot_name, $value)>

=item B<inline_initialize_slot ($instance_structure, $slot_name)>

=item B<inline_deinitialize_slot ($instance_structure, $slot_name)>

=item B<inline_is_slot_initialized ($instance_structure, $slot_name)>

=item B<inline_weaken_slot_value ($instance_structure, $slot_name)>

=item B<inline_strengthen_slot_value ($instance_structure, $slot_name)>

=back

=head1 AUTHORS

Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut