Mercurial > pub > Impl

changeset 134:44977efed303

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Significant performance optimizations Fixed recursion problems due converting objects to JSON Added cache support for the templates Added discovery feature for the web methods
author wizard
date Mon, 21 Jun 2010 02:39:53 +0400
parents a07a66fd8d5c
children 5b849974bed8
files Lib/IMPL/Class/MemberInfo.pm Lib/IMPL/Class/Meta.pm Lib/IMPL/Class/MethodInfo.pm Lib/IMPL/Class/Property/Base.pm Lib/IMPL/Class/PropertyInfo.pm Lib/IMPL/Profiler.pm Lib/IMPL/Web/Application/ControllerUnit.pm Lib/IMPL/Web/QueryHandler/JsonFormat.pm Lib/IMPL/Web/QueryHandler/PageFormat.pm Lib/IMPL/Web/TT/Document.pm Lib/IMPL/base.pm _test/DOM.t _test/temp.pl
diffstat 13 files changed, 252 insertions(+), 95 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/Class/MemberInfo.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Class/MemberInfo.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -38,12 +38,13 @@
     return;
 }
 
-sub set {
-    my $this = shift;
-    if ($this->Frozen) {
-        die new IMPL::Exception('The member information is frozen', $this->Name);
-    }
-    $this->SUPER::set(@_);
-}
+#TODO: Debug version
+#sub set {
+#    my $this = shift;
+#    if ($this->Frozen) {
+#        die new IMPL::Exception('The member information is frozen', $this->Name);
+#    }
+#    $this->SUPER::set(@_);
+#}
 
 1;
--- a/Lib/IMPL/Class/Meta.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Class/Meta.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -1,7 +1,6 @@
 package IMPL::Class::Meta;
 use strict;
 
-use Class::Data::Inheritable;
 use Storable qw(dclone);
 
 my %class_meta;
--- a/Lib/IMPL/Class/MethodInfo.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Class/MethodInfo.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -5,4 +5,9 @@
 
 __PACKAGE__->PassThroughArgs;
 
+__PACKAGE__->mk_accessors(qw(
+	ReturnType
+	Parameters
+));
+
 1;
\ No newline at end of file
--- a/Lib/IMPL/Class/Property/Base.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Class/Property/Base.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -143,7 +143,7 @@
 		ref $mutators ?
 			('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0)
 			:
-			(($mutators & prop_list) ? 'l' : 's' , ($mutators & prop_get) ? 1 : 0, ($mutators & prop_set) ? ((($mutators & owner_set) == owner_set) ? 2 : 1 ) : 0 ) 
+			('s',$mutators) 
 	); 
 }
 
--- a/Lib/IMPL/Class/PropertyInfo.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Class/PropertyInfo.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -20,9 +20,7 @@
 
 sub Implementor {
     my $this = shift;
-    
-    my $implementor;
-    
+        
     if (@_) {
         $this->SUPER::Implementor(@_);
     } else {
@@ -32,26 +30,16 @@
         $implementor = $this->SelectImplementor();
         
         if (my $class = ref $implementor ? undef : $implementor) {
-            if (not $LoadedModules{$class}) {
-                (my $package = $class.'.pm') =~ s/::/\//g;
-                require $package;
-                $LoadedModules{$class} = 1;
-            }
+            eval "require $class; 1;" or die $@ unless $LoadedModules{$class}++;
         }
         
         $this->Implementor($implementor);
-        return $implementor;
     }
     
 }
 
 sub SelectImplementor {
-    my ($this) = @_;
-    
-    if ($this->Class->can('_PropertyImplementor')) {
-        return $this->Class->_PropertyImplementor;
-    }
-    die new IMPL::Exception('Can\'t find a property implementor for the specified class',$this->Class);
+    eval {$_[0]->Class->_PropertyImplementor} or die new IMPL::Exception('Can\'t find a property implementor for the specified class',$_[0]->Class);
 }
 
 1;
--- a/Lib/IMPL/Profiler.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Profiler.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -1,15 +1,64 @@
 package IMPL::Profiler;
 
+use strict;
+use warnings;
+use Time::HiRes;
+require Scalar::Util;
+
 our $Enabled;
 our %TrappedModules;
 our %InvokeInfo;
 our $InvokeTime = 0;
+our @TrapQueue;
+our $Filter ||= qr//;
 my $level;
 
 BEGIN {
     $level = 0;
     if ($Enabled) {
         warn "profiler enabled";
+        
+        unshift @INC, sub {
+			my ($self,$filename) = @_;
+			
+			(my $module = $filename) =~ s/\//::/g;
+			$module =~ s/\.\w+$//;
+			
+			return unless $module =~ $Filter;
+			
+			foreach my $dir (@INC) {
+				my $fullName = "$dir/$filename";
+				if (-f $fullName) {
+					open my $hmod, $fullName or	die "$fullName: $!" if $!;
+
+					
+
+					my @source;					
+					local $/ = "\n";
+					while (my $line = <$hmod>) {
+						last if $line =~ /^\s*__END__/;
+						push @source, $line;
+					}
+					
+					undef $hmod;
+					
+					push @source,
+					"IMPL::Profiler::trap_all(__PACKAGE__);\n",
+					"1;\n";
+					
+					
+					return (sub {
+						if (@source) {
+							$_ = shift @source;
+							return 1;
+						} else {
+							return 0;
+						}
+					}, undef );
+				}
+			}
+		};
+        
         no warnings 'once';
         *CORE::GLOBAL::caller = sub {
             my $target = (shift || 0)+1;
@@ -32,12 +81,6 @@
         };
     }
 }
-use strict;
-use warnings;
-use Time::HiRes;
-require Scalar::Util;
-
-
 
 sub trap_all {    
     return if not $Enabled;
@@ -51,7 +94,7 @@
         
         no strict 'refs';
         my $table = \%{"${class}::"};
-        trap($class,$_) foreach (grep *{$table->{$_}}{CODE}, keys %$table);
+        trap($class,$_) foreach (grep eval { *{$table->{$_}}{CODE} }, keys %$table); # here can be a not a GLOB reference
     }
 }
 
@@ -60,6 +103,8 @@
     
     return if not $Enabled;
     
+    return if $method eq 'import';
+    
     no strict 'refs';
     my $prevCode = \&{"${class}::${method}"};
     my $proto = prototype $prevCode;
@@ -68,43 +113,43 @@
         return;
     }
     {
-    package IMPL::Profiler::Proxy;
-    no warnings 'redefine';
-    my $sub = sub {
-        my $t0 = [Time::HiRes::gettimeofday];
-        my @arr;
-        my $scalar;
-        my $entry = $prevCode;
-        my ($timeOwn,$timeTotal);
-        my $context = wantarray;
-        {
-            local $InvokeTime = 0;
-            #warn "\t"x$level,"enter ${class}::$method";
-            $level ++;
-            if ($context) {
-                @arr = &$entry(@_);
-            } else {
-                if (defined $context) {
-                    $scalar = &$entry(@_);
-                } else {
-                    &$entry(@_);
-                }
-            }
-            $timeTotal = Time::HiRes::tv_interval($t0);
-            $timeOwn = $timeTotal - $InvokeTime;
-        }
-        $InvokeInfo{"${class}::${method}"}{Count} ++;
-        $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
-        $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
-        $InvokeTime += $timeTotal;
-        $level --;
-        #warn "\t"x$level,"leave ${class}::$method";
-        return $context ? @arr : $scalar;
-    };
-    if ($proto) {
-        Scalar::Util::set_prototype($sub => $proto);
-    }
-    *{"${class}::${method}"} = $sub;
+	    package IMPL::Profiler::Proxy;
+	    no warnings 'redefine';
+	    my $sub = sub {
+	        my $t0 = [Time::HiRes::gettimeofday];
+	        my @arr;
+	        my $scalar;
+	        my $entry = $prevCode;
+	        my ($timeOwn,$timeTotal);
+	        my $context = wantarray;
+	        {
+	            local $InvokeTime = 0;
+	            #warn "\t"x$level,"enter ${class}::$method";
+	            $level ++;
+	            if ($context) {
+	                @arr = &$entry(@_);
+	            } else {
+	                if (defined $context) {
+	                    $scalar = &$entry(@_);
+	                } else {
+	                    &$entry(@_);
+	                }
+	            }
+	            $timeTotal = Time::HiRes::tv_interval($t0);
+	            $timeOwn = $timeTotal - $InvokeTime;
+	        }
+	        $InvokeInfo{"${class}::${method}"}{Count} ++;
+	        $InvokeInfo{"${class}::${method}"}{Total} += $timeTotal;
+	        $InvokeInfo{"${class}::${method}"}{Own} += $timeOwn;
+	        $InvokeTime += $timeTotal;
+	        $level --;
+	        #warn "\t"x$level,"leave ${class}::$method";
+	        return $context ? @arr : $scalar;
+	    };
+	    if ($proto) {
+	        Scalar::Util::set_prototype($sub => $proto);
+	    }
+	    *{"${class}::${method}"} = $sub;
     }
     
 }
--- a/Lib/IMPL/Web/Application/ControllerUnit.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Web/Application/ControllerUnit.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -39,6 +39,24 @@
 	$this->$_($args->{$_}) foreach qw(formData formSchema formErrors);
 }
 
+sub unitNamespace() {
+	""
+}
+
+sub transactions {
+	my ($self,%methods) = @_;
+	
+	while (my ($method,$info) = each %methods) {
+		if ($info and ref $info ne 'HASH') {
+			warn "Bad transaction $method description";
+			$info = {};
+		}
+		
+		$info->{wrapper} = 'TransactionWrapper';
+		$self->class_data(CONTROLLER_METHODS)->{$method} = $info;
+	}
+}
+
 sub forms {
 	my ($self,%forms) = @_;
 	
@@ -165,20 +183,31 @@
 	}
 }
 
-sub webMethod($$;$$) {
-	my ($name,$args,$body,$options) = @_;
+sub discover {
+	my ($this) = @_;
+	
+	my $methods = $this->class_data(CONTROLLER_METHODS);
+	
+	my $namespace = $this->unitNamespace;
+	(my $module = typeof $this) =~ s/^$namespace//;
 	
-	my %info = %$options;
-	$info{parameters} = $args;
-	$info{name} = $name;
-	$info{module} = scalar caller;
+	my %smd = (
+		module => [grep $_, split /::/, $module ],
+	);
 	
-	
+	while (my ($method,$info) = each %$methods) {
+		my %methodInfo = (
+			name => $method
+		);
+		$methodInfo{parameters} = $info->{parameters} if $info->{parameters};
+		push @{$smd{methods}},\%methodInfo; 
+	}
+	return \%smd;
 }
 
-public webMethod discover => sub {
-	
-}, { schema => 'some schema', returns => 'HASH' } ;
+__PACKAGE__->transactions(
+	discover => undef
+);
 
 1;
 
@@ -316,6 +345,25 @@
 Обертка для конструирования форм, может быть переопределен для конструирования контекста по
 своим правилам.
 
+=item C<discover()>
+
+Метод, опубликованный для вызова контроллером, возвращает описание методов в формате C<Simple Module Definition>.
+
+=begin code
+
+# SMD structure
+{
+	module => ['Foo','Bar'],
+	methods => [
+		{
+			name => 'search',
+			parameters => ['text','limit'] #optional
+		}
+	]
+}
+
+=end code
+
 =back
 
 =head1 EXAMPLE
@@ -328,34 +376,40 @@
 
 __PACKAGE__->PassThroughArgs;
 
-__PACKAGE__->transactions(qw(
-	find 
-	info
-));
+sub unitDataClass { 'My::Books' }
+
+__PACKAGE__->transactions(
+	find => {
+		parameters => [qw(author)]
+	},
+	info => {
+		parameters => [qw(id)]
+	}
+);
 __PACKAGE__->forms(
 	create => 'books.create.xml'
 );
 
 sub find {
-	my ($this) = @_;
+	my ($this,$author) = @_;
 	
-	return $this->application->dataSource->resultset('Books')->find({author => $this->query->param('author')});
+	return $this->ds->find({author => $author});
 }
 
 sub info {
-	my ($this) = @_;
+	my ($this,$id) = @_;
 	
-	return $this->application->dataSource->resultset('Books')->find({id => $this->query->param('id')});
+	return $this->ds->find({id => $id});
 }
 
 sub create {
 	my ($this) = @_;
 	
 	my %book = map {
-		$_ => $this->formData->selectSingleNode($_)->nodeValue
-	} qw(author_id title year ISBN);
+		$_->nodeName, $_->nodeValue
+	} $this->formData->selectNodes([qw(author_id title year ISBN)]);
 	
-	return $this->application->datasource->resultset('Books')->create(\%book);
+	return $this->ds->create(\%book);
 }
 
 =end code
--- a/Lib/IMPL/Web/QueryHandler/JsonFormat.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Web/QueryHandler/JsonFormat.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -30,6 +30,13 @@
 
 use base qw(IMPL::Transform);
 use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+use Scalar::Util qw(refaddr);
+
+BEGIN {
+	private _direct property _visited => prop_none;
+}
+
 my %propListCache;
 
 our %CTOR = (
@@ -89,4 +96,17 @@
 	}
 );
 
+sub Transform {
+	my ($this,$object) = @_;
+	
+	return $this->SUPER::Transform($object) unless ref $object;
+	
+	if (exists $this->{$_visited}{refaddr $object}) {
+		return $this->{$_visited}{refaddr $object};
+	} else {
+		$this->{$_visited}{refaddr $object} = undef;
+		return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object);
+	}
+}
+
 1;
\ No newline at end of file
--- a/Lib/IMPL/Web/QueryHandler/PageFormat.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Web/QueryHandler/PageFormat.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -14,18 +14,21 @@
 	public property templatesBase => prop_all;
 	public property defaultTarget => prop_all;
 	public property pathinfoPrefix => prop_all;
+	public property cache => prop_all;
 }
 
 sub CTOR {
 	my ($this) = @_;
 	
 	$this->templatesCharset('utf-8') unless $this->templatesCharset;
+	$this->cache(File::Spec->rel2abs($this->cache)) if $this->cache;
+	$this->templatesBase(File::Spec->rel2abs($this->templatesBase)) if $this->templatesBase;
 }
 
 sub Process {
 	my ($this,$action,$nextHandler) = @_;
 	
-	my $doc = new IMPL::Web::TT::Document();
+	my $doc = new IMPL::Web::TT::Document(cache => $this->cache);
 	
 	try {
 
--- a/Lib/IMPL/Web/TT/Document.pm	Fri Jun 18 16:27:28 2010 +0400
+++ b/Lib/IMPL/Web/TT/Document.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -15,6 +15,7 @@
 BEGIN {
     private property _provider => prop_all;
     private property _context => prop_all;
+    public property cache => prop_all;
     public property template => prop_get | owner_set;
     public property presenter => prop_all, { validate => \&_validatePresenter };
     private property _controlClassMap => prop_all;
@@ -25,12 +26,13 @@
 );
 
 sub CTOR {
-	my ($this) = @_;
+	my ($this,%args) = @_;
 	
 	$this->_controlClassMap({});
 	$this->registerControlClass( Control => 'IMPL::Web::TT::Control' );
 	$this->appendChild( $this->Create(body => 'IMPL::Web::TT::Collection') );
 	$this->appendChild( $this->Create(head => 'IMPL::Web::TT::Collection') );
+	$this->cache($args{cache}) if $args{cache};
 }
 
 sub CreateControl {
@@ -171,6 +173,8 @@
         INTERPOLATE => 1,
         PRE_CHOMP => 1,
         POST_CHOMP => 1,
+        COMPILE_EXT => $this->cache ? '.ttc' : undef,
+        COMPILE_DIR => $this->cache,
         INCLUDE_PATH => [$inc,@includes]
     );
     
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/base.pm	Mon Jun 21 02:39:53 2010 +0400
@@ -0,0 +1,38 @@
+package IMPL::base;
+use strict;
+
+my %loaded;
+
+sub import {
+	shift;
+	
+	no strict 'refs';
+	my $class = caller;
+	
+	foreach my $baseClass (@_) {
+		unless ($loaded{$baseClass}) {
+			undef $!;
+			undef $@;
+			$loaded{$baseClass} = 1;
+			eval "require $baseClass;";
+			
+			die $@ if $@ and not $!;
+		}
+		
+		#TODO debug warn if base class is empty;
+		
+		push @{"${class}::ISA"}, $baseClass;
+	}
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::base> быстрая версия директивы C<base>.
+
+=cut
--- a/_test/DOM.t	Fri Jun 18 16:27:28 2010 +0400
+++ b/_test/DOM.t	Mon Jun 21 02:39:53 2010 +0400
@@ -15,4 +15,4 @@
 
 $plan->AddListener(new IMPL::Test::TAPListener);
 $plan->Prepare();
-$plan->Run();
+$plan->Run();
\ No newline at end of file
--- a/_test/temp.pl	Fri Jun 18 16:27:28 2010 +0400
+++ b/_test/temp.pl	Mon Jun 21 02:39:53 2010 +0400
@@ -1,6 +1,6 @@
 #!/usr/bin/perl
 use strict;
 
-my $var ;
-$var->{dool} = '';
-print $var;
\ No newline at end of file
+
+
+IMPL::Profiler::PrintStatistics();
\ No newline at end of file