Mercurial > pub > Impl
diff lib/IMPL/lang.pm @ 407:c6e90e02dd17 ref20150831
renamed Lib->lib
author | cin |
---|---|
date | Fri, 04 Sep 2015 19:40:23 +0300 |
parents | |
children | 5c80e33f1218 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/lang.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,251 @@ +package IMPL::lang; +use strict; +use warnings; + +use parent qw(Exporter); +use IMPL::_core::version; +use IMPL::clone qw(clone); +use Scalar::Util qw(blessed); +use Carp qw(carp); + +our @EXPORT = qw(&is &isclass &typeof); +our %EXPORT_TAGS = ( + base => [ + qw( + &is + &clone + &isclass + &typeof + ) + ], + + declare => [ + qw( + &public + &protected + &private + &property + &static + &property + &_direct + &ACCESS_PUBLIC + &ACCESS_PROTECTED + &ACCESS_PRIVATE + &PROP_GET + &PROP_SET + &PROP_OWNERSET + &PROP_LIST + &PROP_ALL + &PROP_RO + &PROP_RW + &PROP_DIRECT + ) + ], + compare => [ + qw( + &equals + &equals_s + &hashCompare + ) + ], + hash => [ + qw( + &hashApply + &hashMerge + &hashDiff + &hashCompare + &hashParse + &hashSave + ) + ] +); + +our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; + +use IMPL::Const qw(:all); + +sub is($$) { + carp "A typename can't be undefined" unless $_[1]; + blessed($_[0]) and $_[0]->isa( $_[1] ); +} + +sub isclass { + carp "A typename can't be undefined" unless $_[1]; + local $@; + eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; +} + +sub typeof(*) { + local $@; + eval { $_[0]->_typeof } || blessed($_[0]) || ref($_[0]); +} + +sub public($) { + my $info = shift; + $info->{access} = ACCESS_PUBLIC; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub private($) { + my $info = shift; + $info->{access} = ACCESS_PRIVATE; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub protected($) { + my $info = shift; + $info->{access} = ACCESS_PROTECTED; + my $implementor = delete $info->{implementor}; + $implementor->Implement($info); +} + +sub _direct ($) { + my $info = shift; + $info->{direct} = 1; + return $info; +} + +sub property($$) { + my ($propName,$attributes) = @_; + + $attributes = { + get => $attributes & PROP_GET, + set => $attributes & PROP_SET, + isList => $attributes & PROP_LIST + } unless ref $attributes; + + my $class = caller; + + return hashMerge ( + $attributes, + { + implementor => $class->ClassPropertyImplementor, + name => $propName, + class => scalar(caller), + } + ); +} + +sub static($$) { + my ( $name, $value ) = @_; + my $class = caller; + $class->static_accessor( $name, $value ); +} + +sub equals { + if (defined $_[0]) { + return 0 if (not defined $_[1]); + + return $_[0] == $_[1]; + } else { + return 0 if defined $_[1]; + + return 1; + } +} + +sub equals_s { + if (defined $_[0]) { + return 0 if (not defined $_[1]); + + return $_[0] eq $_[1]; + } else { + return 0 if defined $_[1]; + + return 1; + } +} + +sub hashDiff { + my ($src,$dst) = @_; + + $dst = $dst ? { %$dst } : {} ; + $src ||= {}; + + my %result; + + foreach my $key ( keys %$src ) { + if (exists $dst->{$key}) { + $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); + delete $dst->{$key}; + } else { + $result{"-$key"} = 1; + } + } + + $result{"+$_"} = $dst->{$_} foreach keys %$dst; + + return \%result; +} + +sub hashMerge { + return hashApply( { %{$_[0] || {}} }, $_[1] ); +} + +sub hashApply { + my ($target,$diff) = @_; + + return $target unless ref $diff eq 'HASH'; + + while ( my ($key,$value) = each %$diff) { + $key =~ /^(\+|-)?(.*)$/; + my $op = $1 || '+'; + $key = $2; + + if ($op eq '-') { + delete $target->{$key}; + } else { + $target->{$key} = $value; + } + } + + return $target; +} + +sub hashCompare { + my ($l,$r,$cmp) = @_; + + $cmp ||= \&equals_s; + + return 0 unless scalar keys %$l == scalar keys %$r; + &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; + + return 1; +} + +sub hashParse { + my ($s,$p,$d) = @_; + + $p = $p ? qr/$p/ : qr/\n+/; + $d = $d ? qr/$d/ : qr/\s*=\s*/; + + return { + map split($d,$_,2), split($p,$s) + }; +} + +sub hashSave { + my ($hash,$p,$d) = @_; + + return "" unless ref $hash eq 'HASH'; + + $p ||= "\n"; + $d ||= " = "; + + return + join( + $p, + map( + join( + $d, + $_, + $hash->{$_} + ), + keys %$hash + ) + ); +} + +1;