Created
December 3, 2008 00:31
-
-
Save beppu/31363 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
package Squatting::Controller; | |
sub new{bless{name=>$_[1],urls=>$_[2],@_[3..$#_]}=>$_[0]} | |
sub clone{bless{%{$_[0]},@_[1..$#_]}=> ref($_[0])} | |
for my$m qw(name urls cr env input cookies state v status headers log view app){ | |
*{$m}=sub:lvalue{$_[0]->{$m}}} | |
for my$m qw(get post head put delete options trace connect){ | |
*{$m}=sub{$_[0]->{$m}->(@_)}}sub param{my($self,$k,@v)=@_; | |
if(defined $k){if(@v){$self->input->{$k}=((@v>1)?\@v:$v[0]); | |
}else{$self->input->{$k}} | |
}else{keys%{$self->input}}} | |
sub render{my($self,$template,$vn)=@_;my$view;$vn||=$self->view; | |
my $app=$self->app;if(defined($vn)){$view=${$app."::Views::V"}{$vn}; | |
}else{$view=${$app."::Views::V"}[0]} | |
$view->headers=$self->headers;$view->$template($self->v)} | |
sub redirect{my($self,$l,$s)=@_;$self->headers->{Location}=$l||'/'; | |
$self->status=$s||302}my $not_found=sub{$_[0]->status=404; | |
$_[0]->env->{REQUEST_PATH}." not found."}; | |
our $r404=Squatting::Controller->new(R404=>[], | |
get=>$not_found,post=>$not_found,app=>'Squatting'); | |
package Squatting; | |
use base"Class::C3::Componentised";use List::Util"first";use URI::Escape; | |
use Carp;our$VERSION='0.60';sub import{my $m=shift;my $p=(caller)[0];my $app=$p; | |
$app=~s/::Controllers$//;$app=~s/::Views$//;if(UNIVERSAL::isa($app,'Squatting') | |
){*{$p."::R"}=sub{my($controller,@args)=@_;my$input;if(@args && ref($args[-1]) | |
eq'HASH'){$input=pop(@args)}my$c=${$app."::Controllers::C"}{$controller}; | |
croak"$controller controller not found"unless$c;my$arity=@args; | |
my$path=first{my @m=/\(.*?\)/g;$arity == @m}@{$c->urls}; | |
croak"couldn't find a matching URL path" unless $path; | |
while($path=~/\(.*?\)/){ | |
$path=~s{\(.*?\)}{uri_escape(+shift(@args),"^A-Za-z0-9\-_.!~*’()/")}e} | |
if($input){$path.="?".join('&'=>map{my$k=$_;ref($input->{$_})eq'ARRAY' | |
?map{"$k=".uri_escape($_)}@{$input->{$_}}:"$_=".uri_escape($input->{$_}) | |
}keys %$input)}$path}; | |
*{$app."::D"}=sub{;my$url=uri_unescape($_[0]); | |
my$C=\@{$app.'::Controllers::C'};my($c,@regex_captures);for$c(@$C){ | |
for(@{$c->urls}){if(@regex_captures=($url=~qr{^$_$})){ | |
pop @regex_captures if($#+==0);return($c,\@regex_captures)}}} | |
($Squatting::Controller::r404,[])}unless exists ${$app."::"}{D}} | |
my@c;for(@_){if($_ eq':controllers'){*{$p."::C"}=sub{ | |
Squatting::Controller->new(@_,app=>$app)}; | |
}elsif($_ eq':views'){*{$p."::V"}=sub{Squatting::View->new(@_)}; | |
}elsif(/::/){push @c,$_}}$m->load_components(@c)if@c} | |
sub component_base_class{__PACKAGE__}sub mount{my($app,$other,$prefix)=@_; | |
push @{$app."::O"},$other;push @{$app."::Controllers::C"},map{ | |
my $urls=$_->urls;$_->urls=[ map{$prefix.$_}@$urls ];$_; | |
}@{$other."::Controllers::C"}} | |
sub relocate{my($app,$prefix)=@_;for(@{$app."::Controllers::C"}){ | |
my$urls=$_->urls;$_->urls=[ map{$prefix.$_}@$urls ]}} | |
sub init{$_->init for(@{$_[0]."::O"});%{$_[0]."::Controllers::C"}= | |
map{$_->name=>$_}@{$_[0]."::Controllers::C"}; | |
%{$_[0]."::Views::V"}=map{$_->name=>$_}@{$_[0]."::Views::V"}} | |
sub service{my($app,$c,@args)=grep{defined}@_;my$method=lc | |
$c->env->{REQUEST_METHOD};my$content;eval{$content=$c->$method(@args)}; | |
warn"EXCEPTION: $@"if($@);my$cookies=$c->cookies;$c->headers->{'Set-Cookie'}= | |
join("; ",map{CGI::Cookie->new(-name=>$_,%{$cookies->{$_}})} | |
grep{ref$cookies->{$_}eq'HASH'}keys %$cookies)if(%$cookies);$content} | |
package Squatting::View;sub new{ | |
my$class=shift;my$name=shift;bless{name=>$name,@_}=>$class} | |
sub name:lvalue{$_[0]->{name}};sub headers:lvalue{$_[0]->{headers}} | |
sub _render{my($self,$template,$vars,$alt)=@_;$self->{template}=$template; | |
if(exists $self->{layout}&&($template!~/^_/)){$template=$alt if defined $alt; | |
$self->{layout}($self,$vars,$self->{$template}($self,$vars)); | |
}else{$template=$alt if defined $alt;$self->{$template}($self,$vars)}} | |
sub AUTOLOAD{my($self,$vars)=@_;my$template=$AUTOLOAD; | |
$template=~s/.*://;if(exists $self->{$template}&&ref($self->{$template})eq | |
'CODE'){$self->_render($template,$vars)}elsif(exists$self->{_}){ | |
$self->_render($template,$vars,'_')}else{die( | |
"$template cannot be rendered.")}};sub DESTROY{};1; |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment