# HG changeset patch
# User wizard
# Date 1277073593 -14400
# Node ID 44977efed303aee33aa474d6bf60ec6e55ce86fe
# Parent  a07a66fd8d5cb2dc7c58feb8ec460dd628bfd60f
Significant performance optimizations
Fixed recursion problems due converting objects to JSON
Added cache support for the templates
Added discovery feature for the web methods

diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Class/MemberInfo.pm
--- 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;
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Class/Meta.pm
--- 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;
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Class/MethodInfo.pm
--- 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
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Class/Property/Base.pm
--- 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) 
 	); 
 }
 
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Class/PropertyInfo.pm
--- 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;
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Profiler.pm
--- 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;
     }
     
 }
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Web/Application/ControllerUnit.pm
--- 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
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Web/QueryHandler/JsonFormat.pm
--- 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
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Web/QueryHandler/PageFormat.pm
--- 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 {
 
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/Web/TT/Document.pm
--- 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]
     );
     
diff -r a07a66fd8d5c -r 44977efed303 Lib/IMPL/base.pm
--- /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
diff -r a07a66fd8d5c -r 44977efed303 _test/DOM.t
--- 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
diff -r a07a66fd8d5c -r 44977efed303 _test/temp.pl
--- 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