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