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.04';
  11
  12 use base 'Class::MOP::Attribute';
  13
  14 sub initialize_instance_slot {
  15     my ($self, $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                 $self->associated_class
  24                      ->get_meta_instance
  25                      ->set_slot_value($instance, $self->name, $val);
  26         }
  27 }
  28
  29 sub generate_accessor_method {
  30     my $attr = shift;
  31
  32         my $attr_name = $attr->name;
  33         my $meta_instance = $attr->associated_class->get_meta_instance;
  34
  35     sub {
  36         if (scalar(@_) == 2) {
  37                         $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
  38         }
  39         else {
  40                         unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
  41                                 my $value = $attr->has_default ? $attr->default($_[0]) : undef;
  42                                 $meta_instance->set_slot_value($_[0], $attr_name, $value);
  43             }
  44
  45             $meta_instance->get_slot_value($_[0], $attr_name);
  46         }
  47     };
  48 }
  49
  50 sub generate_reader_method {
  51         my $attr = shift;
  52
  53         my $attr_name = $attr->name;
  54         my $meta_instance = $attr->associated_class->get_meta_instance;
  55
  56     sub {
  57         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
  58
  59                 unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
  60                         my $value = $attr->has_default ? $attr->default($_[0]) : undef;
  61                         $meta_instance->set_slot_value($_[0], $attr_name, $value);
  62                 }
  63
  64                 $meta_instance->get_slot_value($_[0], $attr_name);
  65     };
  66 }
  67
  68 1;
  69
  70 __END__
  71
  72 =pod
  73
  74 =head1 NAME
  75
  76 LazyClass - An example metaclass with lazy initialization
  77
  78 =head1 SYNOPSIS
  79
  80   package BinaryTree;
  81
  82   use metaclass 'Class::MOP::Class' => (
  83       ':attribute_metaclass' => 'LazyClass::Attribute'
  84   );
  85
  86   BinaryTree->meta->add_attribute('$:node' => (
  87       accessor => 'node',
  88       init_arg => ':node'
  89   ));
  90
  91   BinaryTree->meta->add_attribute('$:left' => (
  92       reader  => 'left',
  93       default => sub { BinaryTree->new() }
  94   ));
  95
  96   BinaryTree->meta->add_attribute('$:right' => (
  97       reader  => 'right',
  98       default => sub { BinaryTree->new() }
  99   ));
 100
 101   sub new  {
 102       my $class = shift;
 103       $class->meta->new_object(@_);
 104   }
 105
 106   # ... later in code
 107
 108   my $btree = BinaryTree->new();
 109   # ... $btree is an empty hash, no keys are initialized yet
 110
 111 =head1 DESCRIPTION
 112
 113 This is an example metclass in which all attributes are created
 114 lazily. This means that no entries are made in the instance HASH
 115 until the last possible moment.
 116
 117 The example above of a binary tree is a good use for such a
 118 metaclass because it allows the class to be space efficient
 119 without complicating the programing of it. This would also be
 120 ideal for a class which has a large amount of attributes,
 121 several of which are optional.
 122
 123 =head1 AUTHOR
 124
 125 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 126
 127 =head1 COPYRIGHT AND LICENSE
 128
 129 Copyright 2006 by Infinity Interactive, Inc.
 130
 131 L<http://www.iinteractive.com>
 132
 133 This library is free software; you can redistribute it and/or modify
 134 it under the same terms as Perl itself.
 135
 136 =cut