Mercurial > pub > Impl
annotate Lib/IMPL/lang.pm @ 284:f2a6bc5f3184
+IMPL::Object::InlineFactory: implement object factory as subroutine
| author | sergey |
|---|---|
| date | Thu, 14 Feb 2013 19:14:02 +0400 |
| parents | c6d0f889ef87 |
| children | 77df11605d3a |
| 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); |
| 274 | 8 use Scalar::Util qw(blessed); |
| 280 | 9 use Carp qw(carp); |
| 164 | 10 |
| 274 | 11 our @EXPORT = qw(&is &isclass &typeof); |
| 167 | 12 our %EXPORT_TAGS = ( |
| 194 | 13 base => [ |
| 14 qw( | |
| 15 &is | |
| 16 &clone | |
|
271
56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
cin
parents:
241
diff
changeset
|
17 &isclass |
| 274 | 18 &typeof |
| 194 | 19 ) |
| 20 ], | |
| 167 | 21 |
| 194 | 22 declare => [ |
| 23 qw( | |
| 24 &public | |
| 25 &protected | |
| 26 &private | |
| 27 &property | |
| 28 &static | |
| 29 &property | |
| 278 | 30 &_direct |
| 213 | 31 &ACCESS_PUBLIC |
| 32 &ACCESS_PROTECTED | |
| 33 &ACCESS_PRIVATE | |
| 34 &PROP_GET | |
| 35 &PROP_SET | |
| 36 &PROP_OWNERSET | |
| 37 &PROP_LIST | |
| 38 &PROP_ALL | |
| 230 | 39 &PROP_RO |
| 40 &PROP_RW | |
| 278 | 41 &PROP_DIRECT |
| 194 | 42 ) |
| 43 ], | |
| 44 compare => [ | |
| 45 qw( | |
| 46 &equals | |
| 47 &equals_s | |
| 48 &hashCompare | |
| 49 ) | |
| 50 ], | |
| 51 hash => [ | |
| 52 qw( | |
| 53 &hashApply | |
| 54 &hashMerge | |
| 55 &hashDiff | |
| 56 &hashCompare | |
| 57 &hashParse | |
| 58 &hashSave | |
| 59 ) | |
| 60 ] | |
| 167 | 61 ); |
| 62 | |
| 63 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; | |
| 64 | |
| 230 | 65 use IMPL::Const qw(:all); |
| 164 | 66 |
| 67 sub is($$) { | |
| 280 | 68 carp "A typename can't be undefined" unless $_[1]; |
|
271
56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
cin
parents:
241
diff
changeset
|
69 eval {ref $_[0] and $_[0]->isa( $_[1] ) }; |
|
56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
cin
parents:
241
diff
changeset
|
70 } |
|
56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
cin
parents:
241
diff
changeset
|
71 |
|
56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
cin
parents:
241
diff
changeset
|
72 sub isclass { |
| 280 | 73 carp "A typename can't be undefined" unless $_[1]; |
|
271
56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
cin
parents:
241
diff
changeset
|
74 eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; |
| 167 | 75 } |
| 76 | |
| 274 | 77 sub typeof(*) { |
| 280 | 78 eval { $_[0]->_typeof } || blessed($_[0]) || ref($_[0]) || $_[0]; |
| 274 | 79 } |
| 80 | |
| 167 | 81 sub public($) { |
| 278 | 82 my $info = shift; |
| 83 $info->{access} = ACCESS_PUBLIC; | |
| 84 my $implementor = delete $info->{implementor}; | |
| 85 $implementor->Implement($info); | |
| 167 | 86 } |
| 87 | |
| 88 sub private($) { | |
| 278 | 89 my $info = shift; |
| 90 $info->{access} = ACCESS_PRIVATE; | |
| 91 my $implementor = delete $info->{implementor}; | |
| 92 $implementor->Implement($info); | |
| 167 | 93 } |
| 94 | |
| 95 sub protected($) { | |
| 278 | 96 my $info = shift; |
| 97 $info->{access} = ACCESS_PROTECTED; | |
| 98 my $implementor = delete $info->{implementor}; | |
| 99 $implementor->Implement($info); | |
| 100 } | |
| 101 | |
| 102 sub _direct ($) { | |
| 103 my $info = shift; | |
| 104 $info->{direct} = 1; | |
| 105 return $info; | |
| 164 | 106 } |
| 107 | |
| 278 | 108 sub property($$) { |
| 109 my ($propName,$attributes) = @_; | |
| 110 | |
| 111 $attributes = { | |
| 112 get => $attributes & PROP_GET, | |
| 113 set => $attributes & PROP_SET, | |
| 114 isList => $attributes & PROP_LIST | |
| 115 } unless ref $attributes; | |
| 116 | |
| 117 my $class = caller; | |
| 118 | |
| 119 return hashMerge ( | |
| 120 $attributes, | |
| 194 | 121 { |
| 278 | 122 implementor => $class->ClassPropertyImplementor, |
| 123 name => $propName, | |
| 124 class => scalar(caller), | |
| 194 | 125 } |
| 126 ); | |
| 167 | 127 } |
| 128 | |
| 129 sub static($$) { | |
| 194 | 130 my ( $name, $value ) = @_; |
| 131 my $class = caller; | |
| 132 $class->static_accessor( $name, $value ); | |
| 167 | 133 } |
| 134 | |
| 135 sub equals { | |
| 194 | 136 if (defined $_[0]) { |
| 137 return 0 if (not defined $_[1]); | |
| 138 | |
| 139 return $_[0] == $_[1]; | |
| 140 } else { | |
| 141 return 0 if defined $_[1]; | |
| 142 | |
| 143 return 1; | |
| 144 } | |
| 167 | 145 } |
| 146 | |
| 147 sub equals_s { | |
| 194 | 148 if (defined $_[0]) { |
| 149 return 0 if (not defined $_[1]); | |
| 150 | |
| 151 return $_[0] eq $_[1]; | |
| 152 } else { | |
| 153 return 0 if defined $_[1]; | |
| 154 | |
| 155 return 1; | |
| 156 } | |
| 167 | 157 } |
| 158 | |
| 168 | 159 sub hashDiff { |
| 194 | 160 my ($src,$dst) = @_; |
| 161 | |
| 162 $dst = $dst ? { %$dst } : {} ; | |
| 163 $src ||= {}; | |
| 164 | |
| 165 my %result; | |
| 166 | |
| 167 foreach my $key ( keys %$src ) { | |
| 168 if (exists $dst->{$key}) { | |
| 169 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); | |
| 170 delete $dst->{$key}; | |
| 171 } else { | |
| 172 $result{"-$key"} = 1; | |
| 173 } | |
| 174 } | |
| 175 | |
| 176 $result{"+$_"} = $dst->{$_} foreach keys %$dst; | |
| 177 | |
| 178 return \%result; | |
| 168 | 179 } |
| 180 | |
| 181 sub hashMerge { | |
| 210 | 182 return hashApply( { %{$_[0] || {}} }, $_[1] ); |
| 168 | 183 } |
| 184 | |
| 185 sub hashApply { | |
| 194 | 186 my ($target,$diff) = @_; |
| 187 | |
|
241
f48a1a9f4fa2
+Added ViewResult to allow implementation of the view environment.
sergey
parents:
230
diff
changeset
|
188 return $target unless ref $diff eq 'HASH'; |
|
f48a1a9f4fa2
+Added ViewResult to allow implementation of the view environment.
sergey
parents:
230
diff
changeset
|
189 |
| 194 | 190 while ( my ($key,$value) = each %$diff) { |
| 191 $key =~ /^(\+|-)?(.*)$/; | |
| 192 my $op = $1 || '+'; | |
| 193 $key = $2; | |
| 194 | |
| 195 if ($op eq '-') { | |
| 196 delete $target->{$key}; | |
| 197 } else { | |
| 198 $target->{$key} = $value; | |
| 199 } | |
| 200 } | |
| 201 | |
| 202 return $target; | |
| 168 | 203 } |
| 204 | |
| 205 sub hashCompare { | |
| 194 | 206 my ($l,$r,$cmp) = @_; |
| 207 | |
| 208 $cmp ||= \&equals_s; | |
| 209 | |
| 210 return 0 unless scalar keys %$l == scalar keys %$r; | |
| 211 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; | |
| 212 | |
| 213 return 1; | |
| 168 | 214 } |
| 215 | |
| 174 | 216 sub hashParse { |
| 194 | 217 my ($s,$p,$d) = @_; |
| 218 | |
| 219 $p = $p ? qr/$p/ : qr/\n+/; | |
| 220 $d = $d ? qr/$d/ : qr/\s*=\s*/; | |
| 221 | |
| 222 return { | |
| 223 map split($d,$_,2), split($p,$s) | |
| 224 }; | |
| 174 | 225 } |
| 226 | |
| 227 sub hashSave { | |
| 194 | 228 my ($hash,$p,$d) = @_; |
| 229 | |
| 230 return "" unless ref $hash eq 'HASH'; | |
| 231 | |
| 232 $p ||= "\n"; | |
| 233 $d ||= " = "; | |
| 234 | |
| 235 return | |
| 236 join( | |
| 237 $p, | |
| 238 map( | |
| 239 join( | |
| 240 $d, | |
| 241 $_, | |
| 242 $hash->{$_} | |
| 243 ), | |
| 244 keys %$hash | |
| 245 ) | |
| 246 ); | |
| 174 | 247 } |
| 248 | |
| 167 | 249 1; |