Mercurial > pub > Impl

comparison Lib/IMPL/declare.pm @ 228:431db7034a88

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Для синхронизации
author andrei <andrei@nap21.upri>
date Thu, 13 Sep 2012 17:55:01 +0400
parents 2b9b55cfb79b
children 6d8092d8ce1b
comparison
equal deleted inserted replaced
227:70ad6bc20908 228:431db7034a88
1 package IMPL::declare; 1 package IMPL::declare;
2 use strict; 2 use strict;
3 3
4 use Scalar::Util qw(set_prototype); 4 use Scalar::Util qw(set_prototype);
5 use Carp qw(carp); 5 use Carp qw(carp);
6 use IMPL::Class::PropertyInfo();
6 7
7 sub import { 8 sub import {
8 my ($self,$args) = @_; 9 my ( $self, $args ) = @_;
9 10
10 return unless $args; 11 return unless $args;
11 12
12 die "A hash reference is required" unless ref $args eq 'HASH'; 13 die "A hash reference is required" unless ref $args eq 'HASH';
13 14
14 no strict 'refs'; 15 no strict 'refs';
15 16
16 my $caller = caller; 17 my $caller = caller;
17 18
18 my $aliases = $args->{require} || {}; 19 my $aliases = $args->{require} || {};
19 20
20 while( my ($alias, $class) = each %$aliases ) { 21 while ( my ( $alias, $class ) = each %$aliases ) {
21 my $c = _require($class); 22 my $c = _require($class);
22 23
23 *{"${caller}::$alias"} = set_prototype(sub { 24 *{"${caller}::$alias"} = set_prototype(
24 $c 25 sub {
25 }, ''); 26 $c;
26 } 27 },
27 28 ''
28 my $base = $args->{base} || {}; 29 );
29 30 }
30 my %ctor; 31
31 my @isa; 32 my $base = $args->{base} || {};
32 33
33 if (ref $base eq 'ARRAY') { 34 my %ctor;
34 carp "Odd elements number in require" unless scalar(@$base)%2 == 0; 35 my @isa;
35 while ( my ($class,$mapper) = splice @$base, 0, 2 ) { 36
36 $class = $aliases->{$class} || _require($class); 37 if ( ref $base eq 'ARRAY' ) {
37 38 carp "Odd elements number in require"
38 push @isa,$class; 39 unless scalar(@$base) % 2 == 0;
39 $ctor{$class} = $mapper; 40 while ( my ( $class, $mapper ) = splice @$base, 0, 2 ) {
40 } 41 $class = $aliases->{$class} || _require($class);
41 } elsif (ref $base eq 'HASH' ) { 42
42 while ( my ($class,$mapper) = each %$base ) { 43 push @isa, $class;
43 $class = $aliases->{$class} || _require($class); 44 $ctor{$class} = $mapper;
44 45 }
45 push @isa,$class; 46 }
46 $ctor{$class} = $mapper; 47 elsif ( ref $base eq 'HASH' ) {
47 } 48 while ( my ( $class, $mapper ) = each %$base ) {
48 } 49 $class = $aliases->{$class} || _require($class);
49 50
50 *{"${caller}::CTOR"} = \%ctor; 51 push @isa, $class;
51 *{"${caller}::ISA"} = \@isa; 52 $ctor{$class} = $mapper;
53 }
54 }
55
56 my $props = $args->{props} || [];
57
58 if ( $props eq 'HASH' ) {
59 $props = [%$props];
60 }
61
62 die "A hash or an array reference is required in the properties list"
63 unless ref $props eq 'ARRAY';
64
65 carp "Odd elements number in properties declaration of $caller"
66 unless scalar(@$props) % 2 == 0;
67
68 if (@$props) {
69 for ( my $i = 0 ; $i < @$props - 1 ; $i = $i + 2 ) {
70 my ( $prop, $spec ) = @{$props}[ $i, $i + 1 ];
71
72 my $propInfo = IMPL::Class::PropertyInfo->new(
73 {
74 Name => $prop,
75 Mutators => $spec,
76 Class => $caller,
77 Access => $prop =~ /^_/
78 ? IMPL::Class::MemberInfo::MOD_PRIVATE
79 : IMPL::Class::MemberInfo::MOD_PUBLIC
80 }
81 );
82 $propInfo->Implement();
83 }
84 }
85
86 *{"${caller}::CTOR"} = \%ctor;
87 *{"${caller}::ISA"} = \@isa;
52 } 88 }
53 89
54 sub _require { 90 sub _require {
55 my ($class) = @_; 91 my ($class) = @_;
56 92
57 if (not $class =~ s/^-//) { 93 if ( not $class =~ s/^-// ) {
58 (my $file = $class) =~ s/::|'/\//g; 94 ( my $file = $class ) =~ s/::|'/\//g;
59 require "$file.pm"; 95 require "$file.pm";
60 } 96 }
61 $class; 97 $class;
62 } 98 }
63
64 99
65 1; 100 1;
66 101
67 __END__ 102 __END__
68 103