Mercurial > pub > Impl

changeset 427:09e0086a82a7 ref20150831 tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge
author cin
date Tue, 15 May 2018 00:51:33 +0300
parents eed50c01e758 (current diff) c27434cdd611 (diff)
children
files _test/temp.pl lib/IMPL.pm lib/IMPL/Class/Member.pm
diffstat 6 files changed, 135 insertions(+), 127 deletions(-) [+]
line wrap: on
line diff
--- a/_test/temp.pl	Tue May 15 00:51:01 2018 +0300
+++ b/_test/temp.pl	Tue May 15 00:51:33 2018 +0300
@@ -8,44 +8,46 @@
 use Data::Dumper;
 use URI;
 
-package Bar;
-use base qw(IMPL::Object);
-
-sub CTOR {
-}
-
-package Bar2;
-use base qw(Bar);
-
-sub CTOR {
-}
-
 package Foo;
 use base qw(IMPL::Object::_Base);
 
 sub new {
 	my $instance = bless {}, shift;
-	$instance->__construct();
+	$instance->__construct(@_);
 	return $instance;
 }
 
 sub CTOR {
+	say "Foo @_";
 }
 
 package Foo2;
 use base qw(Foo);
 
 sub CTOR {
-	
-} 
+	say "Foo2 @_";	
+}
+
+package Bar;
+
+sub CTOR {
+	say "Bar";
+}
+
+package Baz;
+use base qw(Foo2 Bar);
+
+sub CTOR {
+	say "Baz";
+}
+
+
 
 package main;
 
 my $t = [gettimeofday];
 
-for(my $i=0; $i <1000000; $i++) {
-	my $v = new Foo2;
-}
+new Baz("-hi!");
 
 say tv_interval($t);
 
--- a/_test/test_cgi.pl	Tue May 15 00:51:01 2018 +0300
+++ b/_test/test_cgi.pl	Tue May 15 00:51:33 2018 +0300
@@ -1,11 +1,3 @@
 #!/usr/bin/perl
 use strict;
 
-use CGI qw(-nph);
-
-my $q = CGI->new({});
-
-print $q->header({
-    type => 'text/html',
-    X_My_header => 'some data'
-});
\ No newline at end of file
--- a/lib/IMPL/Class/ClassBuilder.pm	Tue May 15 00:51:01 2018 +0300
+++ b/lib/IMPL/Class/ClassBuilder.pm	Tue May 15 00:51:33 2018 +0300
@@ -19,4 +19,8 @@
 	
 }
 
+sub DefineImport {
+	
+}
+
 1;
\ No newline at end of file
--- a/lib/IMPL/Class/Member.pm	Tue May 15 00:51:01 2018 +0300
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-package IMPL::Class::Member;
-use strict;
-use parent qw(Exporter);
-our @EXPORT = qw(&public &private &protected &_direct);
-
-
-use IMPL::Const qw(:access);
-
-require IMPL::Class::MemberInfo;
-
-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;
-}
-
-1;
--- a/lib/IMPL/Object/_Base.pm	Tue May 15 00:51:01 2018 +0300
+++ b/lib/IMPL/Object/_Base.pm	Tue May 15 00:51:33 2018 +0300
@@ -7,104 +7,129 @@
 sub __destroy;
 
 *__construct = _strap_ctor(__PACKAGE__);
-*__destroy = _strap_dtor(__PACKAGE__);
+*__destroy   = _strap_dtor(__PACKAGE__);
 
 sub DESTROY {
 	shift->__destroy();
 }
 
 sub _strap_ctor {
-	my ($class, $ctor) = @_;
+	my ( $class, $ctor ) = @_;
 	no strict 'refs';
 	no warnings 'redefine';
-	
-	return sub {
-		my $self = ref shift;
+
+	return $ctor
+	  ? sub {
+		my $self = ref $_[0];
 		
-		if ($self ne $class) {
-			my $t = _get_ctor($self,  undef, '@_');
-			*{"${self}::__construct"} = _strap_ctor($self, $t);
+		if ( $self ne $class ) {
+			my $t = _get_ctor( $self, undef, '@_' );
+			*{"${self}::__construct"} = _strap_ctor( $self, $t );
+			goto &$t;
+		}
+
+		goto &$ctor;
+	  }
+	  : sub {
+		my $self = ref $_[0];
+		if ( $self ne $class ) {
+			my $t = _get_ctor( $self, undef, '@_' );
+			*{"${self}::__construct"} = _strap_ctor( $self, $t );
 			goto &$t if $t;
-		} else {
-			goto &$ctor if $ctor;
 		}
-	};
+	  };
 }
 
 sub _strap_dtor {
-	my ($class, $dtor) = @_;
-	
+	my ( $class, $dtor ) = @_;
 	no strict 'refs';
 	no warnings 'redefine';
-	
-	return sub {
-		my $self = ref shift;
+
+	return $dtor
+	  ? sub {
+		my $self = ref $_[0];
 		
-		if ($self ne $class) {
+		if ( $self ne $class ) {
 			my $t = _get_dtor($self);
-			*{"${self}::__destroy"} = _strap_dtor($self, $t);
-			goto &$t if $t;  
-		} else {
-			goto &$dtor if $dtor;
+			*{"${self}::__destroy"} = _strap_dtor( $self, $t );
+			goto &$t;
 		}
-	};
+
+		goto &$dtor;
+	  }
+	  : sub {
+		my $self = ref $_[0];
+		if ( $self ne $class ) {
+			my $t = _get_dtor($self);
+			*{"${self}::__destroy"} = _strap_dtor( $self, $t );
+			goto &$t if $t;
+		}
+	  };
 }
 
 sub _get_ctor {
-	my ($class, $prev, $t) = @_;
+	my ( $class, $prev, $t ) = @_;
 	no strict 'refs';
-	
+
 	#say "_get_ctor($class, $prev, $t)";
-	
-	my $isolate = ((not defined($t)) or ($t ne '@_'));  
-	
-	my $ctor = $isolate ? *{"${class}::CTOR"}{CODE} : _chain_call(*{"${class}::CTOR"}{CODE}, $prev); 
-	
-	foreach my $base (@{"${class}::ISA"}) {
-		$ctor = _get_ctor($base, $ctor, exists ${"${class}::ISA"}{$base} ? ${"${class}::ISA"}{$base} : '@_');
+
+	my $isolate = ( ( not defined($t) ) or ( $t ne '@_' ) );
+
+	my $ctor =
+	  $isolate
+	  ? *{"${class}::CTOR"}{CODE}
+	  : _chain_call( *{"${class}::CTOR"}{CODE}, $prev );
+
+	foreach my $base ( @{"${class}::ISA"} ) {
+		$ctor = _get_ctor( $base, $ctor,
+			exists ${"${class}::ISA"}{$base}
+			? ${"${class}::ISA"}{$base}
+			: '@_' );
 	}
-	
+
 	if ($isolate) {
-		$ctor = _chain_call(_chain_params($ctor, $t), $prev);
+		$ctor = _chain_call( _chain_params( $ctor, $t ), $prev );
 	}
-	
+
 	return $ctor;
 }
 
 sub _get_dtor {
-	my ($class, $prev) = @_;
+	my ( $class, $prev ) = @_;
 	no strict 'refs';
-	
-	my $dtor = _chain_call(*{"${class}::DTOR"}{CODE}, $prev);
-	$dtor = _get_dtor($_, $dtor) foreach @{"${class}::ISA"};
-	
+
+	my $dtor = _chain_call( *{"${class}::DTOR"}{CODE}, $prev );
+	$dtor = _get_dtor( $_, $dtor ) foreach @{"${class}::ISA"};
+
 	return $dtor;
 }
 
 sub _chain_call {
-	my ($method, $next) = @_;
-	
+	my ( $method, $next ) = @_;
+
 	return $method unless $next;
-	return $next unless $method;
-	
+	return $next   unless $method;
+
 	return sub { &$method(@_); goto &$next; }
 }
 
 sub _chain_params {
-	my ($method, $prepare) = @_;
-	
+	my ( $method, $prepare ) = @_;
+
 	return unless $method;
-	
-	if (not defined $prepare) {
+
+	if ( not defined $prepare ) {
 		return sub { @_ = (shift); goto &$method };
-	} elsif ($prepare eq '@_') {
+	}
+	elsif ( $prepare eq '@_' ) {
 		return $method;
-	} elsif (ref $prepare eq 'CODE') {
+	}
+	elsif ( ref $prepare eq 'CODE' ) {
 		return sub {
-			@_ = (shift, &$prepare(@_));
+			@_ = ( shift, &$prepare(@_) );
 			goto &$method;
-		}
+		  }
 	}
 }
 
-1;
\ No newline at end of file
+1;
--- a/lib/IMPL/require.pm	Tue May 15 00:51:01 2018 +0300
+++ b/lib/IMPL/require.pm	Tue May 15 00:51:33 2018 +0300
@@ -11,27 +11,50 @@
 our $level = 0;
 
 sub import {
-	my ( $self, $aliases ) = @_;
+	my $self = shift;
+
+	my $aliases;
 
-	return unless $aliases;
-
-	die "A hash reference is required" unless ref $aliases eq 'HASH';
+	if ( @_ == 1 ) {
+		my $aliases = shift;
+		die "A hash reference is required" unless ref $aliases eq 'HASH';
+	}
+	else {
+		die "A list of pairs is expected" unless @_ % 2 == 0;
+		$aliases = {@_};
+	}
 
 	my $caller = caller;
 
 	$PENDING{$caller} = 1;
 
 	no strict 'refs';
+	while ( my ( $alias, $spec ) = each %$aliases ) {
+		my ( $mode, $class ) = m/^(-|~)(.*)/;
 
-	while ( my ( $alias, $class ) = each %$aliases ) {
-		_trace("$alias => $class");
+		_trace("$alias => $spec [$class]");
+
+		$class =~ s/^SELF(?=\W|$)/${caller}::/;
 		$level++;
 
-		my $c = _require($class);
-
-		*{"${caller}::$alias"} = sub () {
-			$c;
-		};
+		if ( $mode eq '-' ) {
+			*{"${caller}::$alias"} = sub () {
+				$class;
+			};
+		}
+		elsif ( $mode eq '~' ) {
+			*{"${caller}::$alias"} = sub () {
+				my $c = _require($class);
+				*{"${caller}::$alias"} = sub() { $c };
+				return $c;
+			};
+		}
+		else {
+			my $c = _require($class);
+			*{"${caller}::$alias"} = sub () {
+				$c;
+			};
+		}
 
 		$level--;
 	}