t/lib/InsideOutClass.pm

   1
   2 package InsideOutClass;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP 'meta';
   8
   9 use Scalar::Util 'refaddr';
  10
  11 our $VERSION = '0.01';
  12
  13 __PACKAGE__->meta->superclasses('Class::MOP::Class');
  14
  15 sub construct_instance {
  16     my ($class, %params) = @_;
  17     my $instance = \(my $var);
  18     foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
  19         # if the attr has an init_arg, use that, otherwise,
  20         # use the attributes name itself as the init_arg
  21         my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
  22         # try to fetch the init arg from the %params ...
  23         my $val;
  24         $val = $params{$init_arg} if exists $params{$init_arg};
  25         # if nothing was in the %params, we can use the
  26         # attribute's default value (if it has one)
  27         $val ||= $attr->default($instance) if $attr->has_default();
  28         # now add this to the instance structure
  29         $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val;
  30     }
  31     return $instance;
  32 }
  33
  34
  35 package InsideOutAttribute;
  36
  37 use strict;
  38 use warnings;
  39
  40 use Carp         'confess';
  41 use Scalar::Util 'blessed', 'reftype', 'refaddr';
  42
  43 use Class::MOP 'meta';
  44
  45 our $VERSION = '0.01';
  46
  47 __PACKAGE__->meta->superclasses('Class::MOP::Attribute');
  48
  49 {
  50     # this is just a utility routine to
  51     # handle the details of accessors
  52     my $_inspect_accessor = sub {
  53         my ($attr_name, $type, $accessor) = @_;
  54
  55         my %ACCESSOR_TEMPLATES = (
  56             'accessor' => 'sub {
  57                 $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2;
  58                 $' . $attr_name . '{ refaddr($_[0]) };
  59             }',
  60             'reader' => 'sub {
  61                 $' . $attr_name . '{ refaddr($_[0]) };
  62             }',
  63             'writer' => 'sub {
  64                 $' . $attr_name . '{ refaddr($_[0]) } = $_[1];
  65             }',
  66             'predicate' => 'sub {
  67                 defined($' . $attr_name . '{ refaddr($_[0]) }) ? 1 : 0;
  68             }'
  69         );
  70
  71         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
  72             my ($name, $method) = each %{$accessor};
  73             return ($name, Class::MOP::Attribute::Accessor->wrap($method));
  74         }
  75         else {
  76             my $method = eval $ACCESSOR_TEMPLATES{$type};
  77             confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
  78             return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
  79         }
  80     };
  81
  82     sub install_accessors {
  83         my ($self, $class) = @_;
  84         (blessed($class) && $class->isa('Class::MOP::Class'))
  85             || confess "You must pass a Class::MOP::Class instance (or a subclass)";
  86
  87         $class->add_package_variable('%' . $self->name);
  88
  89         $class->add_method(
  90             $_inspect_accessor->($class->name . '::' . $self->name, 'accessor' => $self->accessor())
  91         ) if $self->has_accessor();
  92
  93         $class->add_method(
  94             $_inspect_accessor->($class->name . '::' . $self->name, 'reader' => $self->reader())
  95         ) if $self->has_reader();
  96
  97         $class->add_method(
  98             $_inspect_accessor->($class->name . '::' . $self->name, 'writer' => $self->writer())
  99         ) if $self->has_writer();
 100
 101         $class->add_method(
 102             $_inspect_accessor->($class->name . '::' . $self->name, 'predicate' => $self->predicate())
 103         ) if $self->has_predicate();
 104         return;
 105     }
 106
 107 }
 108
 109 ## &remove_attribute is left as an exercise for the reader :)
 110
 111 1;