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;