Mercurial > pub > Impl
annotate Lib/IMPL/lang.pm @ 270:3f59fd828d5f
merge
| author | cin |
|---|---|
| date | Fri, 25 Jan 2013 00:25:02 +0400 |
| parents | f48a1a9f4fa2 |
| children | 56364d0c4b4f |
| rev | line source |
|---|---|
| 164 | 1 package IMPL::lang; |
| 2 use strict; | |
| 3 use warnings; | |
| 4 | |
| 165 | 5 use parent qw(Exporter); |
| 164 | 6 use IMPL::_core::version; |
| 173 | 7 use IMPL::clone qw(clone); |
| 164 | 8 |
| 167 | 9 require IMPL::Class::PropertyInfo; |
| 164 | 10 |
| 167 | 11 our @EXPORT = qw(&is); |
| 12 our %EXPORT_TAGS = ( | |
| 194 | 13 base => [ |
| 14 qw( | |
| 15 &is | |
| 16 &clone | |
| 17 ) | |
| 18 ], | |
| 167 | 19 |
| 194 | 20 declare => [ |
| 21 qw( | |
| 22 &public | |
| 23 &protected | |
| 24 &private | |
| 25 &virtual | |
| 26 &property | |
| 27 &static | |
| 28 &property | |
| 213 | 29 &ACCESS_PUBLIC |
| 30 &ACCESS_PROTECTED | |
| 31 &ACCESS_PRIVATE | |
| 32 &PROP_GET | |
| 33 &PROP_SET | |
| 34 &PROP_OWNERSET | |
| 35 &PROP_LIST | |
| 36 &PROP_ALL | |
| 230 | 37 &PROP_RO |
| 38 &PROP_RW | |
| 194 | 39 ) |
| 40 ], | |
| 41 compare => [ | |
| 42 qw( | |
| 43 &equals | |
| 44 &equals_s | |
| 45 &hashCompare | |
| 46 ) | |
| 47 ], | |
| 48 hash => [ | |
| 49 qw( | |
| 50 &hashApply | |
| 51 &hashMerge | |
| 52 &hashDiff | |
| 53 &hashCompare | |
| 54 &hashParse | |
| 55 &hashSave | |
| 56 ) | |
| 57 ] | |
| 167 | 58 ); |
| 59 | |
| 60 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; | |
| 61 | |
| 230 | 62 use IMPL::Const qw(:all); |
| 164 | 63 |
| 64 sub is($$) { | |
| 194 | 65 eval { $_[0]->isa( $_[1] ) }; |
| 167 | 66 } |
| 67 | |
| 68 sub virtual($) { | |
| 194 | 69 $_[0]->Virtual(1); |
| 70 $_[0]; | |
| 167 | 71 } |
| 72 | |
| 73 sub public($) { | |
| 194 | 74 $_[0]->Access(ACCESS_PUBLIC); |
| 75 $_[0]->Implement; | |
| 76 $_[0]; | |
| 167 | 77 } |
| 78 | |
| 79 sub private($) { | |
| 194 | 80 $_[0]->Access(ACCESS_PRIVATE); |
| 81 $_[0]->Implement; | |
| 82 $_[0]; | |
| 167 | 83 } |
| 84 | |
| 85 sub protected($) { | |
| 194 | 86 $_[0]->Access(ACCESS_PROTECTED); |
| 87 $_[0]->Implement; | |
| 88 $_[0]; | |
| 164 | 89 } |
| 90 | |
| 167 | 91 sub property($$;$) { |
| 194 | 92 my ( $propName, $mutators, $attributes ) = @_; |
| 93 my $Info = new IMPL::Class::PropertyInfo( | |
| 94 { | |
| 95 Name => $propName, | |
| 96 Mutators => $mutators, | |
| 97 Class => scalar(caller), | |
| 98 Attributes => $attributes | |
| 99 } | |
| 100 ); | |
| 101 return $Info; | |
| 167 | 102 } |
| 103 | |
| 104 sub static($$) { | |
| 194 | 105 my ( $name, $value ) = @_; |
| 106 my $class = caller; | |
| 107 $class->static_accessor( $name, $value ); | |
| 167 | 108 } |
| 109 | |
| 110 sub equals { | |
| 194 | 111 if (defined $_[0]) { |
| 112 return 0 if (not defined $_[1]); | |
| 113 | |
| 114 return $_[0] == $_[1]; | |
| 115 } else { | |
| 116 return 0 if defined $_[1]; | |
| 117 | |
| 118 return 1; | |
| 119 } | |
| 167 | 120 } |
| 121 | |
| 122 sub equals_s { | |
| 194 | 123 if (defined $_[0]) { |
| 124 return 0 if (not defined $_[1]); | |
| 125 | |
| 126 return $_[0] eq $_[1]; | |
| 127 } else { | |
| 128 return 0 if defined $_[1]; | |
| 129 | |
| 130 return 1; | |
| 131 } | |
| 167 | 132 } |
| 133 | |
| 168 | 134 sub hashDiff { |
| 194 | 135 my ($src,$dst) = @_; |
| 136 | |
| 137 $dst = $dst ? { %$dst } : {} ; | |
| 138 $src ||= {}; | |
| 139 | |
| 140 my %result; | |
| 141 | |
| 142 foreach my $key ( keys %$src ) { | |
| 143 if (exists $dst->{$key}) { | |
| 144 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); | |
| 145 delete $dst->{$key}; | |
| 146 } else { | |
| 147 $result{"-$key"} = 1; | |
| 148 } | |
| 149 } | |
| 150 | |
| 151 $result{"+$_"} = $dst->{$_} foreach keys %$dst; | |
| 152 | |
| 153 return \%result; | |
| 168 | 154 } |
| 155 | |
| 156 sub hashMerge { | |
| 210 | 157 return hashApply( { %{$_[0] || {}} }, $_[1] ); |
| 168 | 158 } |
| 159 | |
| 160 sub hashApply { | |
| 194 | 161 my ($target,$diff) = @_; |
| 162 | |
|
241
f48a1a9f4fa2
+Added ViewResult to allow implementation of the view environment.
sergey
parents:
230
diff
changeset
|
163 return $target unless ref $diff eq 'HASH'; |
|
f48a1a9f4fa2
+Added ViewResult to allow implementation of the view environment.
sergey
parents:
230
diff
changeset
|
164 |
| 194 | 165 while ( my ($key,$value) = each %$diff) { |
| 166 $key =~ /^(\+|-)?(.*)$/; | |
| 167 my $op = $1 || '+'; | |
| 168 $key = $2; | |
| 169 | |
| 170 if ($op eq '-') { | |
| 171 delete $target->{$key}; | |
| 172 } else { | |
| 173 $target->{$key} = $value; | |
| 174 } | |
| 175 } | |
| 176 | |
| 177 return $target; | |
| 168 | 178 } |
| 179 | |
| 180 sub hashCompare { | |
| 194 | 181 my ($l,$r,$cmp) = @_; |
| 182 | |
| 183 $cmp ||= \&equals_s; | |
| 184 | |
| 185 return 0 unless scalar keys %$l == scalar keys %$r; | |
| 186 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; | |
| 187 | |
| 188 return 1; | |
| 168 | 189 } |
| 190 | |
| 174 | 191 sub hashParse { |
| 194 | 192 my ($s,$p,$d) = @_; |
| 193 | |
| 194 $p = $p ? qr/$p/ : qr/\n+/; | |
| 195 $d = $d ? qr/$d/ : qr/\s*=\s*/; | |
| 196 | |
| 197 return { | |
| 198 map split($d,$_,2), split($p,$s) | |
| 199 }; | |
| 174 | 200 } |
| 201 | |
| 202 sub hashSave { | |
| 194 | 203 my ($hash,$p,$d) = @_; |
| 204 | |
| 205 return "" unless ref $hash eq 'HASH'; | |
| 206 | |
| 207 $p ||= "\n"; | |
| 208 $d ||= " = "; | |
| 209 | |
| 210 return | |
| 211 join( | |
| 212 $p, | |
| 213 map( | |
| 214 join( | |
| 215 $d, | |
| 216 $_, | |
| 217 $hash->{$_} | |
| 218 ), | |
| 219 keys %$hash | |
| 220 ) | |
| 221 ); | |
| 174 | 222 } |
| 223 | |
| 167 | 224 1; |