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