lib/Moose/Cookbook/Meta/Recipe7.pod

   1
   2 =pod
   3
   4 =begin testing-SETUP
   5
   6 {
   7     package My::Meta::Instance;
   8     use Moose;
   9
  10     # This needs to be in a BEGIN block so to avoid a metaclass
  11     # incompatibility error from Moose. In normal usage,
  12     # My::Meta::Instance would be in a separate file from MyApp::User,
  13     # and this would be a non-issue.
  14     BEGIN { extends 'Moose::Meta::Instance' }
  15 }
  16
  17 =end testing-SETUP
  18
  19 =head1 NAME
  20
  21 Moose::Cookbook::Meta::Recipe7 - Creating a glob reference meta-instance class
  22
  23 =head1 SYNOPSIS
  24
  25   package My::Meta::Instance;
  26
  27   use Scalar::Util qw( weaken );
  28   use Symbol qw( gensym );
  29
  30   use Moose;
  31   extends 'Moose::Meta::Instance';
  32
  33   sub create_instance {
  34       my $self = shift;
  35       my $sym = gensym();
  36       bless $sym, $self->_class_name;
  37   }
  38
  39   sub clone_instance {
  40       my ( $self, $instance ) = @_;
  41
  42       my $new_sym = gensym();
  43       %{*$new_sym} = %{*$instance};
  44
  45       bless $new_sym, $self->_class_name;
  46   }
  47
  48   sub get_slot_value {
  49       my ( $self, $instance, $slot_name ) = @_;
  50       return *$instance->{$slot_name};
  51   }
  52
  53   sub set_slot_value {
  54       my ( $self, $instance, $slot_name, $value ) = @_;
  55       *$instance->{$slot_name} = $value;
  56   }
  57
  58   sub deinitialize_slot {
  59       my ( $self, $instance, $slot_name ) = @_;
  60       delete *$instance->{$slot_name};;
  61   }
  62
  63   sub is_slot_initialized {
  64       my ( $self, $instance, $slot_name, $value ) = @_;
  65       exists *$instance->{$slot_name};;
  66   }
  67
  68   sub weaken_slot_value {
  69       my ( $self, $instance, $slot_name ) = @_;
  70       weaken *$instance->{$slot_name};;
  71   }
  72
  73   sub inline_create_instance {
  74       my ( $self, $class_variable ) = @_;
  75       return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }';
  76   }
  77
  78   sub inline_slot_access {
  79       my ( $self, $instance, $slot_name ) = @_;
  80       return '*{' . $instance . '}->{' . $slot_name . '}';
  81   }
  82
  83   package MyApp::User;
  84
  85   use metaclass 'Moose::Meta::Class' =>
  86       ( instance_metaclass => 'My::Meta::Instance' );
  87
  88   use Moose;
  89
  90   has 'name' => (
  91       is  => 'rw',
  92       isa => 'Str',
  93   );
  94
  95   has 'email' => (
  96       is  => 'rw',
  97       isa => 'Str',
  98   );
  99
 100 =head1 DESCRIPTION
 101
 102 This recipe shows how to build your own meta-instance. The meta
 103 instance is the metaclass that creates object instances and helps
 104 manages access to attribute slots.
 105
 106 In this example, we're creating a meta-instance that is based on a
 107 glob reference rather than a hash reference. This example is largely
 108 based on the Piotr Roszatycki's L<MooseX::GlobRef> module.
 109
 110 Our class is a subclass of L<Moose::Meta::Instance>, which creates
 111 hash reference based objects. We need to override all the methods
 112 which make assumptions about the object's data structure.
 113
 114 The first method we override is C<create_instance>:
 115
 116
 117   sub create_instance {
 118       my $self = shift;
 119       my $sym = gensym();
 120       bless $sym, $self->_class_name;
 121   }
 122
 123 This returns an glob reference which has been blessed into our
 124 meta-instance's associated class.
 125
 126 We also override C<clone_instance> to create a new array reference:
 127
 128   sub clone_instance {
 129       my ( $self, $instance ) = @_;
 130
 131       my $new_sym = gensym();
 132       %{*$new_sym} = %{*$instance};
 133
 134       bless $new_sym, $self->_class_name;
 135   }
 136
 137 After that, we have a series of methods which mediate access to the
 138 object's slots (attributes are stored in "slots"). In the default
 139 instance class, these expect the object to be a hash reference, but we
 140 need to change this to expect a glob reference instead.
 141
 142   sub get_slot_value {
 143       my ( $self, $instance, $slot_name ) = @_;
 144       *$instance->{$slot_name};;
 145   }
 146
 147 This level of indirection probably makes our instance class I<slower>
 148 than the default. However, when attribute access is inlined, this
 149 lookup will be cached:
 150
 151   sub inline_create_instance {
 152       my ( $self, $class_variable ) = @_;
 153       return 'do { my $sym = Symbol::gensym(); bless $sym, ' . $class_variable . ' }';
 154   }
 155
 156 The code snippet that the C<inline_slot_access> method returns will
 157 get C<eval>'d once per attribute.
 158
 159 Finally, we use this meta-instance in our C<MyApp::User> class:
 160
 161   use metaclass 'Moose::Meta::Class' =>
 162       ( instance_metaclass => 'My::Meta::Instance' );
 163
 164 We actually don't recommend the use of L<metaclass> in most
 165 cases. However, the other ways of using alternate metaclasses are more
 166 complex, and would complicate our example code unnecessarily.
 167
 168 =head1 CONCLUSION
 169
 170 This recipe shows how to create your own meta-instance class. It's
 171 unlikely that you'll need to do this yourself, but it's interesting to
 172 take a peek at how Moose works under the hood.
 173
 174 =head1 SEE ALSO
 175
 176 There are a few meta-instance class extensions on CPAN:
 177
 178 =over 4
 179
 180 =item * L<MooseX::Singleton>
 181
 182 This module extends the instance class in order to ensure that the
 183 object is a singleton. The instance it uses is still a blessed hash
 184 reference.
 185
 186 =item * L<MooseX::GlobRef>
 187
 188 This module makes the instance a blessed glob reference. This lets you
 189 use a handle as an object instance.
 190
 191 =back
 192
 193 =head1 AUTHOR
 194
 195 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 196
 197 =head1 COPYRIGHT AND LICENSE
 198
 199 Copyright 2006-2009 by Infinity Interactive, Inc.
 200
 201 L<http://www.iinteractive.com>
 202
 203 This library is free software; you can redistribute it and/or modify
 204 it under the same terms as Perl itself.
 205
 206 =begin testing
 207
 208 {
 209     package MyApp::Employee;
 210
 211     use Moose;
 212     extends 'MyApp::User';
 213
 214     has 'employee_number' => ( is => 'rw' );
 215 }
 216
 217 for my $x ( 0 .. 1 ) {
 218     MyApp::User->meta->make_immutable if $x;
 219
 220     my $user = MyApp::User->new(
 221         name  => 'Faye',
 222         email => 'faye@example.com',
 223     );
 224
 225     ok( eval { *{$user} }, 'user object is an glob ref with some values' );
 226
 227     is( $user->name,  'Faye',             'check name' );
 228     is( $user->email, 'faye@example.com', 'check email' );
 229
 230     $user->name('Ralph');
 231     is( $user->name, 'Ralph', 'check name after changing it' );
 232
 233     $user->email('ralph@example.com');
 234     is( $user->email, 'ralph@example.com', 'check email after changing it' );
 235 }
 236
 237 for my $x ( 0 .. 1 ) {
 238     MyApp::Employee->meta->make_immutable if $x;
 239
 240     my $emp = MyApp::Employee->new(
 241         name            => 'Faye',
 242         email           => 'faye@example.com',
 243         employee_number => $x,
 244     );
 245
 246     ok( eval { *{$emp} }, 'employee object is an glob ref with some values' );
 247
 248     is( $emp->name,            'Faye',             'check name' );
 249     is( $emp->email,           'faye@example.com', 'check email' );
 250     is( $emp->employee_number, $x,                 'check employee_number' );
 251
 252     $emp->name('Ralph');
 253     is( $emp->name, 'Ralph', 'check name after changing it' );
 254
 255     $emp->email('ralph@example.com');
 256     is( $emp->email, 'ralph@example.com', 'check email after changing it' );
 257
 258     $emp->employee_number(42);
 259     is( $emp->employee_number, 42, 'check employee_number after changing it' );
 260 }
 261
 262 =end testing
 263
 264 =pod