Mercurial > pub > Impl
diff lib/IMPL/lang.pm @ 421:7798345304bc ref20150831
working on IMPL::Config, removed old stuff
author | cin |
---|---|
date | Sun, 16 Jul 2017 22:59:39 +0300 |
parents | bbc4739c4d48 |
children |
line wrap: on
line diff
--- a/lib/IMPL/lang.pm Sat Feb 25 22:35:26 2017 +0300 +++ b/lib/IMPL/lang.pm Sun Jul 16 22:59:39 2017 +0300 @@ -22,29 +22,6 @@ &isglob ) ], - - 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 @@ -64,98 +41,45 @@ ] ); -our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; +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] ); + 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] ) }; + eval { not ref $_[0] and $_[0]->isa( $_[1] ) }; } sub typeof(*) { - blessed($_[0]); + blessed( $_[0] ); } sub isarray { - not blessed($_[0]) and ref $_[0] eq 'ARRAY'; + not blessed( $_[0] ) and ref $_[0] eq 'ARRAY'; } sub ishash { - not blessed($_[0]) and ref $_[0] eq 'HASH'; + not blessed( $_[0] ) and ref $_[0] eq 'HASH'; } sub isscalar { - not blessed($_[0]) and ref $_[0] eq 'SCALAR'; + not blessed( $_[0] ) and ref $_[0] eq 'SCALAR'; } sub isglob { - not blessed($_[0]) and ref $_[0] eq 'GLOB'; -} - -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 ); + not blessed( $_[0] ) and ref $_[0] eq 'GLOB'; } sub coarsen { - my ( $value, $resolution ) = @_; - return $resolution ? ceil( $value / $resolution ) * $resolution : $value; + my ( $value, $resolution ) = @_; + return $resolution ? ceil( $value / $resolution ) * $resolution : $value; } # datetime is DateTime object @@ -176,117 +100,109 @@ } sub equals { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - + if ( defined $_[0] ) { + return 0 if ( not defined $_[1] ); + return $_[0] == $_[1]; - } else { + } + else { return 0 if defined $_[1]; - + return 1; } } sub equals_s { - if (defined $_[0]) { - return 0 if (not defined $_[1]); - + if ( defined $_[0] ) { + return 0 if ( not defined $_[1] ); + return $_[0] eq $_[1]; - } else { + } + else { return 0 if defined $_[1]; - + return 1; } } sub hashDiff { - my ($src,$dst) = @_; - - $dst = $dst ? { %$dst } : {} ; + 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}); + if ( exists $dst->{$key} ) { + $result{"+$key"} = $dst->{$key} + unless equals_s( $dst->{$key}, $src->{$key} ); delete $dst->{$key}; - } else { + } + else { $result{"-$key"} = 1; } } - + $result{"+$_"} = $dst->{$_} foreach keys %$dst; - + return \%result; } sub hashMerge { - return hashApply( { %{$_[0] || {}} }, $_[1] ); + return hashApply( { %{ $_[0] || {} } }, $_[1] ); } sub hashApply { - my ($target,$diff) = @_; - + my ( $target, $diff ) = @_; + return $target unless ref $diff eq 'HASH'; - - while ( my ($key,$value) = each %$diff) { + + while ( my ( $key, $value ) = each %$diff ) { $key =~ /^(\+|-)?(.*)$/; my $op = $1 || '+'; $key = $2; - - if ($op eq '-') { + + if ( $op eq '-' ) { delete $target->{$key}; - } else { + } + else { $target->{$key} = $value; } } - + return $target; } sub hashCompare { - my ($l,$r,$cmp) = @_; - + my ( $l, $r, $cmp ) = @_; + $cmp ||= \&equals_s; - + return 0 unless scalar keys %$l == scalar keys %$r; - &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; - + &$cmp( $l->{$_}, $r->{$_} ) || return 0 foreach keys %$l; + return 1; } sub hashParse { - my ($s,$p,$d) = @_; - + 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) - }; + + return { map split( $d, $_, 2 ), split( $p, $s ) }; } sub hashSave { - my ($hash,$p,$d) = @_; - + my ( $hash, $p, $d ) = @_; + return "" unless ref $hash eq 'HASH'; - + $p ||= "\n"; $d ||= " = "; - - return - join( - $p, - map( - join( - $d, - $_, - $hash->{$_} - ), - keys %$hash - ) - ); + + return join( $p, map( join( $d, $_, $hash->{$_} ), keys %$hash ) ); } 1;