examples/LazyClass.pod

   1
   2 package # hide the package from PAUSE
   3     LazyClass::Attribute;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Carp 'confess';
   9
  10 our $VERSION = '0.05';
  11
  12 use base 'Class::MOP::Attribute';
  13
  14 sub initialize_instance_slot {
  15     my ($self, $meta_instance, $instance, $params) = @_;
  16
  17     # if the attr has an init_arg, use that, otherwise,
  18     # use the attributes name itself as the init_arg
  19     my $init_arg = $self->init_arg();
  20
  21         if ( exists $params->{$init_arg} ) {
  22                 my $val = $params->{$init_arg};
  23                 $meta_instance->set_slot_value($instance, $self->name, $val);
  24         }
  25 }
  26
  27 sub accessor_metaclass { 'LazyClass::Method::Accessor' }
  28
  29 package # hide the package from PAUSE
  30     LazyClass::Method::Accessor;
  31
  32 use strict;
  33 use warnings;
  34
  35 use Carp 'confess';
  36
  37 our $VERSION = '0.01';
  38
  39 use base 'Class::MOP::Method::Accessor';
  40
  41 sub is_inline{ 0 }
  42
  43 sub _generate_accessor_method {
  44     my $attr = (shift)->associated_attribute;
  45
  46         my $attr_name = $attr->name;
  47         my $meta_instance = $attr->associated_class->get_meta_instance;
  48
  49     sub {
  50         if (scalar(@_) == 2) {
  51                         $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
  52         }
  53         else {
  54                         unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
  55                                 my $value = $attr->has_default ? $attr->default($_[0]) : undef;
  56                                 $meta_instance->set_slot_value($_[0], $attr_name, $value);
  57             }
  58
  59             $meta_instance->get_slot_value($_[0], $attr_name);
  60         }
  61     };
  62 }
  63
  64 sub _generate_reader_method {
  65     my $attr = (shift)->associated_attribute;
  66
  67         my $attr_name = $attr->name;
  68         my $meta_instance = $attr->associated_class->get_meta_instance;
  69
  70     sub {
  71         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  72
  73                 unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
  74                         my $value = $attr->has_default ? $attr->default($_[0]) : undef;
  75                         $meta_instance->set_slot_value($_[0], $attr_name, $value);
  76                 }
  77
  78                 $meta_instance->get_slot_value($_[0], $attr_name);
  79     };
  80 }
  81
  82 package # hide the package from PAUSE
  83     LazyClass::Instance;
  84
  85 use strict;
  86 use warnings;
  87
  88 our $VERSION = '0.01';
  89
  90 use base 'Class::MOP::Instance';
  91
  92 sub initialize_all_slots {}
  93
  94 1;
  95
  96 __END__
  97
  98 =pod
  99
 100 =head1 NAME
 101
 102 LazyClass - An example metaclass with lazy initialization
 103
 104 =head1 SYNOPSIS
 105
 106   package BinaryTree;
 107
 108   use metaclass (
 109       ':attribute_metaclass' => 'LazyClass::Attribute',
 110       ':instance_metaclass'  => 'LazyClass::Instance',
 111   );
 112
 113   BinaryTree->meta->add_attribute('node' => (
 114       accessor => 'node',
 115       init_arg => ':node'
 116   ));
 117
 118   BinaryTree->meta->add_attribute('left' => (
 119       reader  => 'left',
 120       default => sub { BinaryTree->new() }
 121   ));
 122
 123   BinaryTree->meta->add_attribute('right' => (
 124       reader  => 'right',
 125       default => sub { BinaryTree->new() }
 126   ));
 127
 128   sub new  {
 129       my $class = shift;
 130       $class->meta->new_object(@_);
 131   }
 132
 133   # ... later in code
 134
 135   my $btree = BinaryTree->new();
 136   # ... $btree is an empty hash, no keys are initialized yet
 137
 138 =head1 DESCRIPTION
 139
 140 This is an example metclass in which all attributes are created
 141 lazily. This means that no entries are made in the instance HASH
 142 until the last possible moment.
 143
 144 The example above of a binary tree is a good use for such a
 145 metaclass because it allows the class to be space efficient
 146 without complicating the programing of it. This would also be
 147 ideal for a class which has a large amount of attributes,
 148 several of which are optional.
 149
 150 =head1 AUTHORS
 151
 152 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 153
 154 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 155
 156 =head1 COPYRIGHT AND LICENSE
 157
 158 Copyright 2006-2008 by Infinity Interactive, Inc.
 159
 160 L<http://www.iinteractive.com>
 161
 162 This library is free software; you can redistribute it and/or modify
 163 it under the same terms as Perl itself.
 164
 165 =cut