diff Lib/IMPL/Web/Handler/TTView.pm @ 229:47f77e6409f7

heavily reworked the resource model of the web application: *some ResourcesContraact functionality moved to Resource +Added CustomResource *Corrected action handlers
author sergey
date Sat, 29 Sep 2012 02:34:47 +0400
parents c8fe3f84feba
children 3cebcf6fdb9b
line wrap: on
line diff
--- a/Lib/IMPL/Web/Handler/TTView.pm	Thu Sep 13 17:55:01 2012 +0400
+++ b/Lib/IMPL/Web/Handler/TTView.pm	Sat Sep 29 02:34:47 2012 +0400
@@ -4,195 +4,211 @@
 use List::Util qw(first);
 use IMPL::lang qw(:declare :constants);
 use IMPL::declare {
-	require => {
-		Factory => 'IMPL::Object::Factory'
-	},
-	base => {
-		'IMPL::Object' => undef,
-		'IMPL::Object::Autofill' => '@_',
-		'IMPL::Object::Serializable' => undef
-	}
+    require => {
+        Factory      => 'IMPL::Object::Factory',
+        HttpResponse => 'IMPL::Web::HttpResponse'
+      },
+      base => [
+        'IMPL::Object'               => undef,
+        'IMPL::Object::Autofill'     => '@_',
+        'IMPL::Object::Serializable' => undef
+      ],
+
+      props => [
+        contentType     => PROP_GET | PROP_OWNERSET,
+        contentCharset  => PROP_GET | PROP_OWNERSET,
+        loader          => PROP_GET | PROP_OWNERSET,
+        selectors       => PROP_GET | PROP_LIST | PROP_OWNERSET,
+        defaultDocument => PROP_ALL,
+        indexResource   => PROP_ALL,
+        _selectorsCache => PROP_ALL,
+        _classTemplates => PROP_ALL
+      ]
 };
 
-BEGIN {
-	public property contentType => PROP_GET | PROP_OWNERSET;
-	public property loader => PROP_GET | PROP_OWNERSET;
-	public property selectors => PROP_GET | PROP_LIST | PROP_OWNERSET;
-	public property defaultDocument => PROP_ALL;
-	public property indexResource => PROP_ALL;
-	private property _selectorsCache => PROP_ALL;
-	private property _classTemplates => PROP_ALL;
-}
+sub CTOR {
+    my ($this) = @_;
 
-sub CTOR {
-	my ($this) = @_;
-	
-	$this->indexResource('index') unless $this->indexResource;
+    $this->indexResource('index') unless $this->indexResource;
 }
 
 sub Invoke {
-	my ($this,$action,$next) = @_;
-	
-	my $result = $next ? $next->($action) : undef;
-	
-	my $vars = {
-        data => $result,
-        action => $action,
-        app => $action->application,
+    my ( $this, $action, $next ) = @_;
+
+    my $result = $next ? $next->($action) : undef;
+
+    my $vars = {
+        data        => $result,
+        action      => $action,
+        app         => $action->application,
         LoadFactory => sub {
-        	my $class = shift;
-        	
-        	my $module = $class;
-        	
-        	$module =~ s/::/\//g;
-        	$module .= ".pm";
-        	
-        	require $module;
-        	return Factory->new($class);
+            my $class = shift;
+
+            my $module = $class;
+
+            $module =~ s/::/\//g;
+            $module .= ".pm";
+
+            require $module;
+            return Factory->new($class);
         }
-    }; 
-	
-	my $doc = $this->loader->document(
-        $this->SelectView($action,ref $result),
-        $vars
+    };
+
+    my $doc =
+      $this->loader->document( $this->SelectView( $action, ref $result ),
+        $vars );
+
+    return HttpResponse->new(
+        type => $this->contentType,
+        charset => $this->contentCharset,
+        body => $doc->Render($vars)
     );
-    
-    $action->response->contentType($this->contentType);
-	
-	my $hout = $action->response->streamBody;
-    
-    print $hout $doc->Render($vars);
 }
 
 sub SelectView {
-	my ($this,$action,$class) = @_;
-	
-	my @path = split /\//, $action->query->path_info(), -1;
-	
-	shift @path; # remove always empty leading segment
-	
-	my $last = pop @path;
-	$last =~ s/\.\w+$//;
-	$last ||= $this->indexResource;
-	push @path,$last;
-	
-	$this->BuildCache unless $this->_selectorsCache;
-	my $cache = $this->_selectorsCache;
-	
-	@path = reverse @path;
-	
-	foreach my $subclass ( $class ? (_GetHierarchy($class), '-default') : '-plain') {
-		my @results;
-		push @results, { result => $this->_classTemplates->{$subclass}, level => 0 } if $this->_classTemplates->{$subclass};
-		if ($cache->{$subclass}) { 
-            my $alternatives = [ { selector => $cache->{$subclass}, immediate => 1 } ];
-            $alternatives = $this->MatchAlternatives($_,$alternatives,\@results) foreach @path;
-		}
-		
-		if (@results) {
-			@results = sort { $b->{level} <=> $a->{level} } @results;
-			return (shift @results)->{result};
-		}
-	}
-		
-	return $this->defaultDocument;
+    my ( $this, $action, $class ) = @_;
+
+    my @path = split /\//, $action->query->path_info(), -1;
+
+    shift @path;    # remove always empty leading segment
+
+    my $last = pop @path;
+    $last =~ s/\.\w+$//;
+    $last ||= $this->indexResource;
+    push @path, $last;
+
+    $this->BuildCache unless $this->_selectorsCache;
+    my $cache = $this->_selectorsCache;
+
+    @path = reverse @path;
+
+    foreach
+      my $subclass ( $class ? ( _GetHierarchy($class), '-default' ) : '-plain' )
+    {
+        my @results;
+        push @results,
+          { result => $this->_classTemplates->{$subclass}, level => 0 }
+          if $this->_classTemplates->{$subclass};
+        if ( $cache->{$subclass} ) {
+            my $alternatives =
+              [ { selector => $cache->{$subclass}, immediate => 1 } ];
+            $alternatives =
+              $this->MatchAlternatives( $_, $alternatives, \@results )
+              foreach @path;
+        }
+
+        if (@results) {
+            @results = sort { $b->{level} <=> $a->{level} } @results;
+            return ( shift @results )->{result};
+        }
+    }
+
+    return $this->defaultDocument;
 }
 
 sub _GetHierarchy {
-	my ($class) = @_;
-	return unless $class;
-	
-	no strict 'refs';
-	
-	return $class, map { _GetHierarchy($_) } @{"${class}::ISA"};
+    my ($class) = @_;
+    return unless $class;
+
+    no strict 'refs';
+
+    return $class, map { _GetHierarchy($_) } @{"${class}::ISA"};
 }
 
 sub BuildCache {
-	my ($this) = @_;
-	
-	my @selectors;
-	
-	my $cache = $this->_selectorsCache({});
-	$this->_classTemplates({});
-	
-	foreach my $selector ($this->selectors) {
-		if (not ref $selector) {
-			
-			my ($path,$data) = split(/\s*=>\s*/, $selector);
-			
-			my @path = split(/\s+/,$path);
-			
-			my $class;
-			
-			# if this selector has a class part
-			if ($path[$#path] =~ m/^\@(.*)/) {
-				$class = $1;
-				pop @path;
-			} else {
-				$class = '-default';
-			}
-			
-			#if this selector has a path
-			if (@path) {
-				@path = reverse @path;
-				my $last = pop @path;
-				my $t = ( $cache->{$class} ||= {} );
-				my $level = 1;
-		        foreach my $prim (@path ) {
-		            $t = ($t->{$prim}->{next} ||= {});
-		            $level ++;
+    my ($this) = @_;
+
+    my @selectors;
+
+    my $cache = $this->_selectorsCache( {} );
+    $this->_classTemplates( {} );
+
+    foreach my $selector ( $this->selectors ) {
+        if ( not ref $selector ) {
+
+            my ( $path, $data ) = split( /\s*=>\s*/, $selector );
+
+            my @path = split( /\s+/, $path );
+
+            my $class;
+
+            # if this selector has a class part
+            if ( $path[$#path] =~ m/^\@(.*)/ ) {
+                $class = $1;
+                pop @path;
+            }
+            else {
+                $class = '-default';
+            }
+
+            #if this selector has a path
+            if (@path) {
+                @path = reverse @path;
+                my $last  = pop @path;
+                my $t     = ( $cache->{$class} ||= {} );
+                my $level = 1;
+                foreach my $prim (@path) {
+                    $t = ( $t->{$prim}->{next} ||= {} );
+                    $level++;
                 }
                 $t->{$last}->{level} = $level;
-                $t->{$last}->{data} = $data;
-			
-			} else {
-				# we dont have a selector, only class
-				
-				$this->_classTemplates->{$class} = $data;
-			}
-			
-		}
-	}
+                $t->{$last}->{data}  = $data;
+
+            }
+            else {
+
+                # we dont have a selector, only class
+
+                $this->_classTemplates->{$class} = $data;
+            }
+
+        }
+    }
 }
 
 sub MatchAlternatives {
-    my ($this,$segment,$alternatives,$results) = @_;
-    
+    my ( $this, $segment, $alternatives, $results ) = @_;
+
     my @next;
-    
+
     foreach my $alt (@$alternatives) {
-        while (my ($selector,$match) = each %{$alt->{selector}} ) {
-            
-            
+        while ( my ( $selector, $match ) = each %{ $alt->{selector} } ) {
+
             my $context = {
                 vars => \%{ $alt->{vars} || {} },
                 selector => $match->{next}
             };
-            
-            if ($selector =~ s/^>//) {
+
+            if ( $selector =~ s/^>// ) {
                 $context->{immediate} = 1;
             }
-                
-            if (my ($name,$rx) = ($selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/) ) {
+
+            if ( my ( $name, $rx ) =
+                ( $selector =~ m/^\{(?:(\w+)\:)?(.*)\}$/ ) )
+            {
+
                 #this is a regexp
-                
-                if ( my @captures = ($segment =~ m/($rx)/) ) {
+
+                if ( my @captures = ( $segment =~ m/($rx)/ ) ) {
                     $context->{success} = 1;
-                    
+
                     if ($name) {
                         $context->{vars}->{$name} = \@captures;
                     }
                 }
-            } else {
+            }
+            else {
+
                 #this is a segment name
-                if ($segment eq $selector) {
+                if ( $segment eq $selector ) {
                     $context->{success} = 1;
                 }
             }
-            
+
             # test if there were a match
-            if (delete $context->{success}) {
-                if (my $data = $match->{data}) {
+            if ( delete $context->{success} ) {
+                if ( my $data = $match->{data} ) {
+
                     # interpolate data
                     $data =~ s/{(\w+)(?:\:(\d+))?}/
                         my ($name,$index) = ($1,$2 || 0);
@@ -203,20 +219,25 @@
                             "";
                         }
                     /gex;
-                    
-                    push @$results, { level => $match->{level}, result => $data };
+
+                    push @$results,
+                      { level => $match->{level}, result => $data };
                 }
                 push @next, $context if $context->{selector};
-            } else {
+            }
+            else {
+
                 #repeat current alternative if it's not required to be immediate
-                push @next, {
+                push @next,
+                  {
                     selector => { $selector, $match },
-                    vars => $alt->{vars}
-                } unless $alt->{immediate};
+                    vars     => $alt->{vars}
+                  }
+                  unless $alt->{immediate};
             }
         }
     }
-    
+
     return \@next;
 }