49
+ − 1 package IMPL::Object::Autofill;
+ − 2 use strict;
+ − 3 use IMPL::Class::Property;
+ − 4
+ − 5 sub CTOR {
+ − 6 my $this = shift;
+ − 7 no strict 'refs';
+ − 8
+ − 9 my $fields = @_ == 1 ? $_[0] : {@_};
+ − 10
+ − 11 $this->_fill(ref $this,$fields);
+ − 12 }
+ − 13
+ − 14 sub _fill {
+ − 15 my ($this,$class,$fields) = @_;
+ − 16
+ − 17 $class->_autofill_method->($this,$fields);
+ − 18
+ − 19 no strict 'refs';
+ − 20 $this->_fill($_,$fields) foreach grep $_->isa('IMPL::Object::Autofill'), @{"${class}::ISA"};
+ − 21 }
+ − 22
+ − 23 sub DisableAutofill {
+ − 24 my $self = shift;
+ − 25
+ − 26 my $class = ref $self || $self;
+ − 27
+ − 28 *{"${class}::_impl_object_autofill"} = sub {};
+ − 29 }
+ − 30
+ − 31 sub _autofill_method {
+ − 32 my ($class) = @_;
+ − 33
+ − 34 $class = ref $class if ref $class;
+ − 35
+ − 36 # ��� �������������� ����� ���� ����� �������� ������
+ − 37 my $method;
+ − 38 {
+ − 39 no strict 'refs';
+ − 40 $method = ${$class.'::'}{_impl_object_autofill};
+ − 41 }
+ − 42
+ − 43 if ($method) {
+ − 44 return $method;
+ − 45 } else {
+ − 46 my $text = <<HEADER;
+ − 47 package $class;
+ − 48 sub _impl_object_autofill {
+ − 49 my (\$this,\$fields) = \@_;
+ − 50 HEADER
+ − 51
+ − 52
+ − 53 if ($class->can('get_meta')) {
+ − 54 # meta supported
+ − 55 foreach my $prop_info (grep {
+ − 56 my $mutators = $_->Mutators;
+ − 57 ref $mutators ? (exists $mutators->{set}) : ($mutators & prop_set || $_->Implementor->isa('IMPL::Class::Property::Direct'));
+ − 58 } $class->get_meta('IMPL::Class::PropertyInfo')) {
+ − 59 my $name = $prop_info->Name;
+ − 60 if (ref $prop_info->Mutators || !$prop_info->Implementor->isa('IMPL::Class::Property::Direct')) {
+ − 61 $text .= "\t\$this->$name(\$fields->{$name}) if exists \$fields->{$name};\n";
+ − 62 } else {
+ − 63 my $fld = $prop_info->Implementor->FieldName($prop_info);
+ − 64 if ($prop_info->Mutators & prop_list) {
+ − 65 $text .= "\t\$this->{$fld} = ref \$fields->{$name} ? \$fields->{$name} : [\$fields->{$name}] if exists \$fields->{$name};\n";
+ − 66 } else {
+ − 67 $text .= "\t\$this->{$fld} = \$fields->{$name} if exists \$fields->{$name};\n";
+ − 68 }
+ − 69 }
+ − 70 }
+ − 71 } else {
+ − 72 # meta not supported
+ − 73 #$text .= "\t".'$this->$_($fields->{$_}) foreach keys %$fields;'."\n";
+ − 74 }
+ − 75 $text .= "}\n\\&_impl_object_autofill;";
+ − 76 return eval $text;
+ − 77 }
+ − 78 }
+ − 79
+ − 80 1;
+ − 81
+ − 82 __END__
+ − 83
+ − 84 =pod
+ − 85 =head1 SYNOPSIS
+ − 86 package MyClass;
+ − 87 use base qw(IMPL::Object IMPL::Object::Autofill);
+ − 88
+ − 89 BEGIN {
+ − 90 private property PrivateData => prop_all;
+ − 91 public property PublicData => prop_get;
+ − 92 }
+ − 93
+ − 94 sub CTOR {
+ − 95 my $this = shift;
+ − 96 $this->superCTOR(@_);
+ − 97 # or eqvivalent
+ − 98 # $this->supercall::CTOR(@_);
+ − 99
+ − 100 print $this->PrivateData,"\n";
+ − 101 print $this->PublicData,"\n";
+ − 102 }
+ − 103
+ − 104 my $obj = new MyClass(PrivateData => 'private', PublicData => 'public', Other => 'some data');
+ − 105
+ − 106 will print
+ − 107 private
+ − 108 public
+ − 109
+ − 110 =cut
