lib/Mouse/Object.pm

   1 #!/usr/bin/env perl
   2 package Mouse::Object;
   3 use strict;
   4 use warnings;
   5 use MRO::Compat;
   6
   7 use Scalar::Util 'blessed';
   8 use Carp 'confess';
   9
  10 sub new {
  11     my $class = shift;
  12     my %args  = @_;
  13     my $instance = bless {}, $class;
  14
  15     for my $attribute ($class->meta->attributes) {
  16         my $key = $attribute->init_arg;
  17         my $default;
  18
  19         if (!exists($args{$key})) {
  20             if (exists($attribute->{default}) || exists($attribute->{builder})) {
  21                 unless ($attribute->{lazy}) {
  22                     my $builder = $attribute->{builder};
  23                     my $default = exists($attribute->{builder})
  24                                 ? $instance->$builder
  25                                 : ref($attribute->{default}) eq 'CODE'
  26                                     ? $attribute->{default}->()
  27                                     : $attribute->{default};
  28
  29                     $attribute->verify_type_constraint($default)
  30                         if $attribute->has_type_constraint;
  31
  32                     $instance->{$key} = $default;
  33
  34                     Scalar::Util::weaken($instance->{$key})
  35                         if $attribute->{weak_ref};
  36                 }
  37             }
  38             else {
  39                 if ($attribute->{required}) {
  40                     confess "Attribute '$attribute->{name}' is required";
  41                 }
  42             }
  43         }
  44
  45         if (exists($args{$key})) {
  46             $attribute->verify_type_constraint($args{$key})
  47                 if $attribute->has_type_constraint;
  48
  49             $instance->{$key} = $args{$key};
  50
  51             Scalar::Util::weaken($instance->{$key})
  52                 if $attribute->{weak_ref};
  53
  54             if ($attribute->{trigger}) {
  55                 $attribute->{trigger}->($instance, $args{$key}, $attribute);
  56             }
  57         }
  58     }
  59
  60     $instance->BUILDALL(\%args);
  61
  62     return $instance;
  63 }
  64
  65 sub DESTROY { shift->DEMOLISHALL }
  66
  67 sub BUILDALL {
  68     my $self = shift;
  69
  70     # short circuit
  71     return unless $self->can('BUILD');
  72
  73     no strict 'refs';
  74
  75     for my $class ($self->meta->linearized_isa) {
  76         my $code = *{ $class . '::BUILD' }{CODE}
  77             or next;
  78         $code->($self, @_);
  79     }
  80 }
  81
  82 sub DEMOLISHALL {
  83     my $self = shift;
  84
  85     # short circuit
  86     return unless $self->can('DEMOLISH');
  87
  88     no strict 'refs';
  89
  90     for my $class ($self->meta->linearized_isa) {
  91         my $code = *{ $class . '::DEMOLISH' }{CODE}
  92             or next;
  93         $code->($self, @_);
  94     }
  95 }
  96
  97 1;
  98
  99 __END__
 100
 101 =head1 NAME
 102
 103 Mouse::Object - we don't need to steenkin' constructor
 104
 105 =head1 METHODS
 106
 107 =head2 new arguments -> object
 108
 109 Instantiates a new Mouse::Object. This is obviously intended for subclasses.
 110
 111 =head2 BUILDALL \%args
 112
 113 Calls L</BUILD> on each class in the class hierarchy. This is called at the
 114 end of L</new>.
 115
 116 =head2 BUILD \%args
 117
 118 You may put any business logic initialization in BUILD methods. You don't
 119 need to redispatch or return any specific value.
 120
 121 =head2 DEMOLISHALL
 122
 123 Calls L</DEMOLISH> on each class in the class hierarchy. This is called at
 124 L</DESTROY> time.
 125
 126 =head2 DEMOLISH
 127
 128 You may put any business logic deinitialization in DEMOLISH methods. You don't
 129 need to redispatch or return any specific value.
 130
 131 =cut
 132