From: Guillermo Roditi Date: Mon, 23 Jun 2008 20:58:04 +0000 (+0000) Subject: Initial commit of Moosified Catalyst parts. X-Git-Tag: 5.8000_03~133 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=059c085bfcead450e70ace9ef193aa99ac2ab37d Initial commit of Moosified Catalyst parts. r16884@martha (orig r7477): konobi | 2008-03-11 01:25:42 -0400 --- diff --git a/Changes b/Changes index 4154227..ffb920e 100644 --- a/Changes +++ b/Changes @@ -1,8 +1,11 @@ # This file documents the revision history for Perl extension Catalyst. 5.7013 + - Fix subdirs for scripts that run in subdirs more than one level deep. - Added test and updated docs for handling the Authorization header under mod_fastcgi/mod_cgi. + - Fixed bug in HTTP engine where the connection was not closed properly if the + client disconnected before sending any headers. (Ton Voon) 5.7012 2007-12-16 23:44:00 - Fix uri_for()'s and uri_with()'s handling of multibyte chars diff --git a/TODO b/TODO new file mode 100644 index 0000000..68132aa --- /dev/null +++ b/TODO @@ -0,0 +1,12 @@ + + - Add Class::Accessor compats + * Catalyst::Request + * Catalyst::Response + * Catalyst::Dispatcher + * Catalyst::Request::Upload + * Catalyst::Action + * Catalyst::ActionChain + * Catalyst::ActionContainer + + - Make classes immutable at setup() time + diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index b27f090..9183864 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -1572,10 +1572,8 @@ sub prepare { } # For on-demand data - $c->request->{_context} = $c; - $c->response->{_context} = $c; - weaken( $c->request->{_context} ); - weaken( $c->response->{_context} ); + $c->request->_context($c); + $c->response->_context($c); # Allow engine to direct the prepare flow (for POE) if ( $c->engine->can('prepare') ) { diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm index 9ff1dca..174fb4b 100644 --- a/lib/Catalyst/Action.pm +++ b/lib/Catalyst/Action.pm @@ -1,9 +1,5 @@ package Catalyst::Action; -use strict; -use base qw/Class::Accessor::Fast/; - - =head1 NAME Catalyst::Action - Catalyst Action @@ -21,12 +17,25 @@ L subclasses. =cut -__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/); +use Moose; + +has class => (is => 'rw'); +has namespace => (is => 'rw'); +has 'reverse' => (is => 'rw'); +has attributes => (is => 'rw'); +has name => (is => 'rw'); +has code => (is => 'rw'); + +no Moose; + +no warnings 'recursion'; + +#__PACKAGE__->mk_accessors(qw/class namespace reverse attributes name code/); use overload ( # Stringify to reverse for debug output etc. - q{""} => sub { shift->{reverse} }, + q{""} => sub { shift->reverse() }, # Codulate to execute to invoke the encapsulated action coderef '&{}' => sub { my $self = shift; sub { $self->execute(@_); }; }, @@ -44,7 +53,7 @@ sub dispatch { # Execute ourselves against a context sub execute { my $self = shift; - $self->{code}->(@_); + $self->code->(@_); } sub match { @@ -100,6 +109,10 @@ Returns the private path for this action. returns the sub name of this action. +=head2 meta + +Provided by Moose + =head1 AUTHOR Matt S. Trout diff --git a/lib/Catalyst/ActionChain.pm b/lib/Catalyst/ActionChain.pm index 2fd63d9..60fd6db 100644 --- a/lib/Catalyst/ActionChain.pm +++ b/lib/Catalyst/ActionChain.pm @@ -1,8 +1,9 @@ package Catalyst::ActionChain; -use strict; -use base qw/Catalyst::Action/; +use Moose; +extends qw(Catalyst::Action); +has chain => (is => 'rw'); =head1 NAME @@ -20,8 +21,6 @@ the actions in the chain in order. =cut -__PACKAGE__->mk_accessors(qw/chain/); - use overload ( # Stringify to reverse for debug output etc. @@ -79,7 +78,9 @@ actions in order. Takes a list of Catalyst::Action objects and constructs and returns a Catalyst::ActionChain object representing a chain of these actions -=cut +=head2 meta + +Provided by Moose =head1 AUTHOR diff --git a/lib/Catalyst/ActionContainer.pm b/lib/Catalyst/ActionContainer.pm index 63b8fc9..ee7cfa7 100644 --- a/lib/Catalyst/ActionContainer.pm +++ b/lib/Catalyst/ActionContainer.pm @@ -1,8 +1,5 @@ package Catalyst::ActionContainer; -use strict; -use base qw/Class::Accessor::Fast/; - =head1 NAME Catalyst::ActionContainer - Catalyst Action Container @@ -18,24 +15,19 @@ to represent the various dispatch points in your application. =cut -__PACKAGE__->mk_accessors(qw/part actions/); - -use overload ( - - # Stringify to path part for tree search - q{""} => sub { shift->{part} }, +use Moose; -); - -sub new { - my ( $class, $fields ) = @_; - - $fields = { part => $fields, actions => {} } unless ref $fields; - - $class->SUPER::new($fields); -} +has part => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); +has actions => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); +around 'new' => sub { + my $next = shift; + my ($self, $params) = @_; + $params = { part => $params } unless ref $params; + $next->($self, $params); +}; +no Moose; sub get_action { my ( $self, $name ) = @_; @@ -78,6 +70,10 @@ Accessor to the actions hashref, containing all actions in this container. Accessor to the path part this container resolves to. Also what the container stringifies to. +=head2 meta + +Provided by Moose + =head1 AUTHOR Matt S. Trout diff --git a/lib/Catalyst/Dispatcher.pm b/lib/Catalyst/Dispatcher.pm index ca5bc25..78bb5a3 100644 --- a/lib/Catalyst/Dispatcher.pm +++ b/lib/Catalyst/Dispatcher.pm @@ -1,7 +1,7 @@ package Catalyst::Dispatcher; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; + use Catalyst::Exception; use Catalyst::Utils; use Catalyst::Action; @@ -16,13 +16,6 @@ use Scalar::Util (); # Stringify to class use overload '""' => sub { return ref shift }, fallback => 1; -__PACKAGE__->mk_accessors( - qw/tree dispatch_types registered_dispatch_types - method_action_class action_container_class - preload_dispatch_types postload_dispatch_types - action_hash container_hash - / -); # Preload these action types our @PRELOAD = qw/Index Path Regex/; @@ -30,6 +23,18 @@ our @PRELOAD = qw/Index Path Regex/; # Postload these action types our @POSTLOAD = qw/Default/; +has _tree => (is => 'rw'); +has _dispatch_types => (is => 'rw'); +has _registered_dispatch_types => (is => 'rw'); +has _method_action_class => (is => 'rw'); +has _action_container_class => (is => 'rw'); +has preload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@PRELOAD] }); +has postload_dispatch_types => (is => 'rw', required => 1, lazy => 1, default => sub { [@POSTLOAD] }); +has _action_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); +has _container_hash => (is => 'rw', required => 1, lazy => 1, default => sub { {} }); + +no Moose; + =head1 NAME Catalyst::Dispatcher - The Catalyst Dispatcher @@ -51,24 +56,13 @@ Construct a new dispatcher. =cut -sub new { - my $self = shift; - my $class = ref($self) || $self; - - my $obj = $class->SUPER::new(@_); +sub BUILD { + my ($self, $params) = @_; - # set the default pre- and and postloads - $obj->preload_dispatch_types( \@PRELOAD ); - $obj->postload_dispatch_types( \@POSTLOAD ); - $obj->action_hash( {} ); - $obj->container_hash( {} ); + my $container = + Catalyst::ActionContainer->new( { part => '/', actions => {} } ); - # Create the root node of the tree - my $container = - Catalyst::ActionContainer->new( { part => '/', actions => {} } ); - $obj->tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) ); - - return $obj; + $self->_tree( Tree::Simple->new( $container, Tree::Simple->ROOT ) ); } =head2 $self->preload_dispatch_types @@ -173,6 +167,8 @@ sub forward { #push @$args, @_; + no warnings 'recursion'; + local $c->request->{arguments} = \@args; $action->dispatch( $c ); @@ -227,7 +223,7 @@ sub _invoke_as_component { my $class = $self->_find_component_class( $c, $component ) || return 0; if ( my $code = $class->can($method) ) { - return $self->method_action_class->new( + return $self->_method_action_class->new( { name => $method, code => $code, @@ -272,7 +268,7 @@ sub prepare_action { # Check out dispatch types to see if any will handle the path at # this level - foreach my $type ( @{ $self->dispatch_types } ) { + foreach my $type ( @{ $self->_dispatch_types } ) { last DESCEND if $type->match( $c, $path ); } @@ -303,7 +299,7 @@ sub get_action { $namespace = join( "/", grep { length } split '/', $namespace || "" ); - return $self->action_hash->{"$namespace/$name"}; + return $self->_action_hash->{"$namespace/$name"}; } =head2 $self->get_action_by_path( $path ); @@ -316,7 +312,7 @@ sub get_action_by_path { my ( $self, $path ) = @_; $path =~ s/^\///; $path = "/$path" unless $path =~ /\//; - $self->action_hash->{$path}; + $self->_action_hash->{$path}; } =head2 $self->get_actions( $c, $action, $namespace ) @@ -349,11 +345,11 @@ sub get_containers { if ( length $namespace ) { do { - push @containers, $self->container_hash->{$namespace}; + push @containers, $self->_container_hash->{$namespace}; } while ( $namespace =~ s#/[^/]+$## ); } - return reverse grep { defined } @containers, $self->container_hash->{''}; + return reverse grep { defined } @containers, $self->_container_hash->{''}; my @parts = split '/', $namespace; } @@ -372,7 +368,7 @@ cannot determine an appropriate URI, this method will return undef. sub uri_for_action { my ( $self, $action, $captures) = @_; $captures ||= []; - foreach my $dispatch_type ( @{ $self->dispatch_types } ) { + foreach my $dispatch_type ( @{ $self->_dispatch_types } ) { my $uri = $dispatch_type->uri_for_action( $action, $captures ); return( $uri eq '' ? '/' : $uri ) if defined($uri); @@ -391,7 +387,7 @@ Also, set up the tree with the action containers. sub register { my ( $self, $c, $action ) = @_; - my $registered = $self->registered_dispatch_types; + my $registered = $self->_registered_dispatch_types; my $priv = 0; foreach my $key ( keys %{ $action->attributes } ) { @@ -399,13 +395,13 @@ sub register { my $class = "Catalyst::DispatchType::$key"; unless ( $registered->{$class} ) { eval "require $class"; - push( @{ $self->dispatch_types }, $class->new ) unless $@; + push( @{ $self->_dispatch_types }, $class->new ) unless $@; $registered->{$class} = 1; } } # Pass the action to our dispatch types so they can register it if reqd. - foreach my $type ( @{ $self->dispatch_types } ) { + foreach my $type ( @{ $self->_dispatch_types } ) { $type->register( $c, $action ); } @@ -417,14 +413,14 @@ sub register { # Set the method value $container->add_action($action); - $self->action_hash->{"$namespace/$name"} = $action; - $self->container_hash->{$namespace} = $container; + $self->_action_hash->{"$namespace/$name"} = $action; + $self->_container_hash->{$namespace} = $container; } sub _find_or_create_action_container { my ( $self, $namespace ) = @_; - my $tree ||= $self->tree; + my $tree ||= $self->_tree; return $tree->getNodeValue unless $namespace; @@ -457,14 +453,14 @@ sub _find_or_create_namespace_node { sub setup_actions { my ( $self, $c ) = @_; - $self->dispatch_types( [] ); - $self->registered_dispatch_types( {} ); - $self->method_action_class('Catalyst::Action'); - $self->action_container_class('Catalyst::ActionContainer'); + $self->_dispatch_types( [] ); + $self->_registered_dispatch_types( {} ); + $self->_method_action_class('Catalyst::Action'); + $self->_action_container_class('Catalyst::ActionContainer'); my @classes = $self->_load_dispatch_types( @{ $self->preload_dispatch_types } ); - @{ $self->registered_dispatch_types }{@classes} = (1) x @classes; + @{ $self->_registered_dispatch_types }{@classes} = (1) x @classes; foreach my $comp ( values %{ $c->components } ) { $comp->register_actions($c) if $comp->can('register_actions'); @@ -499,12 +495,12 @@ sub setup_actions { $walker->( $walker, $_, $prefix ) for $parent->getAllChildren; }; - $walker->( $walker, $self->tree, '' ); + $walker->( $walker, $self->_tree, '' ); $c->log->debug( "Loaded Private actions:\n" . $privates->draw . "\n" ) if $has_private; # List all public actions - $_->list($c) for @{ $self->dispatch_types }; + $_->list($c) for @{ $self->_dispatch_types }; } sub _load_dispatch_types { @@ -519,7 +515,7 @@ sub _load_dispatch_types { eval "require $class"; Catalyst::Exception->throw( message => qq/Couldn't load "$class"/ ) if $@; - push @{ $self->dispatch_types }, $class->new; + push @{ $self->_dispatch_types }, $class->new; push @loaded, $class; } @@ -527,6 +523,10 @@ sub _load_dispatch_types { return @loaded; } +=head2 meta + +Provided by Moose + =head1 AUTHOR Sebastian Riedel, C diff --git a/lib/Catalyst/Engine/HTTP.pm b/lib/Catalyst/Engine/HTTP.pm index fcb36b4..85ab25f 100644 --- a/lib/Catalyst/Engine/HTTP.pm +++ b/lib/Catalyst/Engine/HTTP.pm @@ -263,14 +263,15 @@ sub run { if ( !$self->_read_headers ) { # Error reading, give up + close Remote; next LISTEN; } my ( $method, $uri, $protocol ) = $self->_parse_request_line; + + next unless $method; DEBUG && warn "Parsed request: $method $uri $protocol\n"; - - next unless $method; unless ( uc($method) eq 'RESTART' ) { @@ -419,9 +420,14 @@ sub _read_headers { while (1) { my $read = sysread Remote, my $buf, CHUNKSIZE; - - if ( !$read ) { - DEBUG && warn "EOF or error: $!\n"; + + if ( !defined $read ) { + next if $! == EWOULDBLOCK; + DEBUG && warn "Error reading headers: $!\n"; + return; + } + elsif ( $read == 0 ) { + DEBUG && warn "EOF\n"; return; } diff --git a/lib/Catalyst/Request.pm b/lib/Catalyst/Request.pm index 50886c0..e134fbe 100644 --- a/lib/Catalyst/Request.pm +++ b/lib/Catalyst/Request.pm @@ -1,8 +1,5 @@ package Catalyst::Request; -use strict; -use base 'Class::Accessor::Fast'; - use IO::Socket qw[AF_INET inet_aton]; use Carp; use utf8; @@ -10,25 +7,115 @@ use URI::http; use URI::https; use URI::QueryParam; -__PACKAGE__->mk_accessors( - qw/action address arguments cookies headers query_keywords match method - protocol query_parameters secure captures uri user/ +use Moose; + +has action => (is => 'rw'); +has address => (is => 'rw'); +has arguments => (is => 'rw', default => sub { [] }); +has cookies => (is => 'rw', default => sub { {} }); +has query_keywords => (is => 'rw'); +has match => (is => 'rw'); +has method => (is => 'rw'); +has protocol => (is => 'rw'); +has query_parameters => (is => 'rw', default => sub { {} }); +has secure => (is => 'rw', default => 0); +has captures => (is => 'rw', default => sub { [] }); +has uri => (is => 'rw'); +has user => (is => 'rw'); +has headers => ( + is => 'rw', + isa => 'HTTP::Headers', + handles => [qw(content_encoding content_length content_type header referer user_agent)], +); + +has _context => ( + is => 'rw', + weak_ref => 1, +); + +has body_parameters => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, ); -*args = \&arguments; -*body_params = \&body_parameters; -*input = \&body; -*params = \¶meters; -*query_params = \&query_parameters; -*path_info = \&path; -*snippets = \&captures; - -sub content_encoding { shift->headers->content_encoding(@_) } -sub content_length { shift->headers->content_length(@_) } -sub content_type { shift->headers->content_type(@_) } -sub header { shift->headers->header(@_) } -sub referer { shift->headers->referer(@_) } -sub user_agent { shift->headers->user_agent(@_) } +before body_parameters => sub { + my ($self) = @_; + $self->_context->prepare_body(); +}; + +has uploads => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, +); + +before uploads => sub { + my ($self) = @_; + $self->_context->prepare_body; +}; + +has parameters => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { {} }, +); + +before parameters => sub { + my ($self, $params) = @_; + $self->_context->prepare_body(); + if ( $params && !ref $params ) { + $self->_context->log->warn( + "Attempt to retrieve '$params' with req->params(), " . + "you probably meant to call req->param('$params')" ); + $params = undef; + } + +}; + +has base => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my $self = shift; + if( $self->uri ){ + return $self->path; + } + }, +); + +has body => ( + is => 'rw' +); + +before body => sub { + my ($self) = @_; + $self->_context->prepare_body(); +}; + +has hostname => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my ($self) = @_; + gethostbyaddr( inet_aton( $self->address ), AF_INET ) + }, +); + +no Moose; + +sub args { shift->arguments(@_) } +sub body_params { shift->body_parameters(@_) } +sub input { shift->body(@_) } +sub params { shift->parameters(@_) } +sub query_params { shift->query_parameters(@_) } +sub path_info { shift->path(@_) } +sub snippets { shift->captures(@_) } =head1 NAME @@ -122,39 +209,11 @@ Contains the URI base. This will always have a trailing slash. If your application was queried with the URI C then C is C. -=cut - -sub base { - my ( $self, $base ) = @_; - - return $self->{base} unless $base; - - $self->{base} = $base; - - # set the value in path for backwards-compat - if ( $self->uri ) { - $self->path; - } - - return $self->{base}; -} - =head2 $req->body Returns the message body of the request, unless Content-Type is C or C. -=cut - -sub body { - my $self = shift; - $self->{_context}->prepare_body; - - return unless $self->{_body}; - - return $self->{_body}->body; -} - =head2 $req->body_parameters Returns a reference to a hash containing body (POST) parameters. Values can @@ -169,15 +228,6 @@ These are the parameters from the POST part of the request, if any. Shortcut for body_parameters. -=cut - -sub body_parameters { - my ( $self, $params ) = @_; - $self->{_context}->prepare_body; - $self->{body_parameters} = $params if $params; - return $self->{body_parameters}; -} - =head2 $req->content_encoding Shortcut for $req->headers->content_encoding. @@ -241,23 +291,6 @@ Returns an L object containing the headers for the current reques Returns the hostname of the client. -=cut - -sub hostname { - my $self = shift; - - if ( @_ == 0 && not $self->{hostname} ) { - $self->{hostname} = - gethostbyaddr( inet_aton( $self->address ), AF_INET ); - } - - if ( @_ == 1 ) { - $self->{hostname} = shift; - } - - return $self->{hostname}; -} - =head2 $req->input Alias for $req->body. @@ -348,24 +381,6 @@ This is the combination of C and C. Shortcut for $req->parameters. -=cut - -sub parameters { - my ( $self, $params ) = @_; - $self->{_context}->prepare_body; - if ( $params ) { - if ( ref $params ) { - $self->{parameters} = $params; - } - else { - $self->{_context}->log->warn( - "Attempt to retrieve '$params' with req->params(), " . - "you probably meant to call req->param('$params')" ); - } - } - return $self->{parameters}; -} - =head2 $req->path Returns the path, i.e. the part of the URI after $req->base, for the current request. @@ -421,7 +436,7 @@ You have to set MyApp->config->{parse_on_demand} to use this directly. =cut -sub read { shift->{_context}->read(@_); } +sub read { shift->_context->read(@_); } =head2 $req->referer @@ -509,15 +524,6 @@ L objects. my $upload = $c->request->uploads->{field}; my $upload = $c->request->uploads->{field}->[0]; -=cut - -sub uploads { - my ( $self, $uploads ) = @_; - $self->{_context}->prepare_body; - $self->{uploads} = $uploads if $uploads; - return $self->{uploads}; -} - =head2 $req->uri Returns a URI object for the current request. Stringifies to the URI text. @@ -562,6 +568,10 @@ newer plugins is $c->user. Shortcut to $req->headers->user_agent. Returns the user agent (browser) version string. +=head2 meta + +Provided by Moose + =head1 AUTHORS Sebastian Riedel, C diff --git a/lib/Catalyst/Request/Upload.pm b/lib/Catalyst/Request/Upload.pm index e5922c2..d496aa1 100644 --- a/lib/Catalyst/Request/Upload.pm +++ b/lib/Catalyst/Request/Upload.pm @@ -1,16 +1,40 @@ package Catalyst::Request::Upload; use strict; -use base 'Class::Accessor::Fast'; use Catalyst::Exception; use File::Copy (); use IO::File (); use File::Spec::Unix; -__PACKAGE__->mk_accessors(qw/filename headers size tempname type basename/); +use Moose; -sub new { shift->SUPER::new( ref( $_[0] ) ? $_[0] : {@_} ) } +has filename => (is => 'rw'); +has headers => (is => 'rw'); +has size => (is => 'rw'); +has tempname => (is => 'rw'); +has type => (is => 'rw'); +has basename => (is => 'rw'); + +has fh => ( + is => 'rw', + required => 1, + lazy => 1, + default => sub { + my $self = shift; + + my $fh = IO::File->new($self->tempname, IO::File::O_RDONLY); + unless ( defined $fh ) { + my $filename = $self->tempname; + Catalyst::Exception->throw( + message => qq/Can't open '$filename': '$!'/ ); + } + + return $fh; + }, +); + +no Moose; =head1 NAME @@ -69,24 +93,6 @@ sub copy_to { Opens a temporary file (see tempname below) and returns an L handle. -=cut - -sub fh { - my $self = shift; - - my $fh = IO::File->new( $self->tempname, IO::File::O_RDONLY ); - - unless ( defined $fh ) { - - my $filename = $self->tempname; - - Catalyst::Exception->throw( - message => qq/Can't open '$filename': '$!'/ ); - } - - return $fh; -} - =head2 $upload->filename Returns the client-supplied filename. @@ -163,6 +169,10 @@ Returns the path to the temporary file. Returns the client-supplied Content-Type. +=head2 meta + +Provided by Moose + =head1 AUTHORS Sebastian Riedel, C diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm index 877f8c9..1a723dc 100644 --- a/lib/Catalyst/Response.pm +++ b/lib/Catalyst/Response.pm @@ -1,16 +1,24 @@ package Catalyst::Response; -use strict; -use base 'Class::Accessor::Fast'; +use Moose; -__PACKAGE__->mk_accessors(qw/cookies body headers location status/); +has cookies => (is => 'rw'); +has body => (is => 'rw'); +has location => (is => 'rw'); +has status => (is => 'rw'); +has headers => ( + is => 'rw', + handles => [qw(content_encoding content_length content_type header)], +); -*output = \&body; +has _context => ( + is => 'rw', + weak_ref => 1, +); -sub content_encoding { shift->headers->content_encoding(@_) } -sub content_length { shift->headers->content_length(@_) } -sub content_type { shift->headers->content_type(@_) } -sub header { shift->headers->header(@_) } +sub output { shift->body(@_) } + +no Moose; =head1 NAME @@ -127,6 +135,10 @@ sub redirect { return $self->location; } +=head2 $res->location + +Sets or returns the HTTP 'Location'. + =head2 $res->status Sets or returns the HTTP status. @@ -139,7 +151,11 @@ Writes $data to the output stream. =cut -sub write { shift->{_context}->write(@_); } +sub write { shift->_context->write(@_); } + +=head2 meta + +Provided by Moose =head1 AUTHORS diff --git a/lib/Catalyst/Utils.pm b/lib/Catalyst/Utils.pm index 670353f..4e5571e 100644 --- a/lib/Catalyst/Utils.pm +++ b/lib/Catalyst/Utils.pm @@ -171,8 +171,9 @@ sub home { # clean up relative path: # MyApp/script/.. -> MyApp - my ($lastdir) = $home->dir_list( -1, 1 ); - if ( $lastdir eq '..' ) { + my $dir; + my @dir_list = $home->dir_list(); + while (($dir = pop(@dir_list)) && $dir eq '..') { $home = dir($home)->parent->parent; } diff --git a/t/03podcoverage.t b/t/03podcoverage.t index 955f071..68d113e 100644 --- a/t/03podcoverage.t +++ b/t/03podcoverage.t @@ -4,4 +4,8 @@ eval "use Test::Pod::Coverage 1.04"; plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD} || -e 'inc/.author'; -all_pod_coverage_ok(); +all_pod_coverage_ok( + { + also_private => ['BUILD'] + } +); diff --git a/t/something/Makefile.PL b/t/something/Makefile.PL new file mode 100644 index 0000000..e69de29 diff --git a/t/unit_utils_subdir.t b/t/unit_utils_subdir.t new file mode 100644 index 0000000..83f9f72 --- /dev/null +++ b/t/unit_utils_subdir.t @@ -0,0 +1,26 @@ +use Test::More tests=>7; + +use strict; +use warnings; + +# simulates an entire testapp rooted at t/something +# except without bothering creating it since its +# only the -e check on the Makefile.PL that matters + +BEGIN { use_ok 'Catalyst::Utils' } +use FindBin; + +$INC{'TestApp.pm'} = "$FindBin::Bin/something/script/foo/../../lib/TestApp.pm"; +my $home = Catalyst::Utils::home('TestApp'); +like($home, qr/t\/something/, "has path TestApp/t/something"); +unlike($home, qr/\/script\/foo/, "doesn't have path /script/foo"); + +$INC{'TestApp.pm'} = "$FindBin::Bin/something/script/foo/bar/../../../lib/TestApp.pm"; +$home = Catalyst::Utils::home('TestApp'); +like($home, qr/t\/something/, "has path TestApp/t/something"); +unlike($home, qr/\/script\/foo\/bar/, "doesn't have path /script/foo"); + +$INC{'TestApp.pm'} = "$FindBin::Bin/something/script/../lib/TestApp.pm"; +$home = Catalyst::Utils::home('TestApp'); +like($home, qr/t\/something/, "has path TestApp/t/something"); +unlike($home, qr/\/script\/foo/, "doesn't have path /script/foo");