From: John Napiorkowski Date: Sun, 17 Feb 2013 17:56:17 +0000 (-0500) Subject: tweaked the "list_extra_info" debugging method and converted old action info to use... X-Git-Tag: 5.90020~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=ffca3e960f527321fa30c5ffdfe6ffd2a984af59;hp=3c0da3ece98e535f1c168bb985980583498894ad tweaked the "list_extra_info" debugging method and converted old action info to use this, to serve as an example for new ones --- diff --git a/lib/Catalyst/Action.pm b/lib/Catalyst/Action.pm index 8c51d13..d360d68 100644 --- a/lib/Catalyst/Action.pm +++ b/lib/Catalyst/Action.pm @@ -103,7 +103,13 @@ sub number_of_captures { return $self->attributes->{CaptureArgs}[0] || 0; } -sub list_extra_info { } +sub list_extra_info { + my $self = shift; + return { + Args => $self->attributes->{Args}[0], + CaptureArgs => $self->number_of_captures, + } +} __PACKAGE__->meta->make_immutable; @@ -184,7 +190,7 @@ Returns the number of captures this action expects for L_normalize_expected_http_method($ctx->req); + return $self->_has_expected_http_method($expected) ? + $self->$orig($ctx, @args) : + 0; +}; + +sub _normalize_expected_http_method { + my ($self, $req) = @_; + return $req->header('X-HTTP-Method') || + $req->header('X-HTTP-Method-Override') || + $req->header('X-METHOD-OVERRIDE') || + $req->method; +} + +sub _has_expected_http_method { + my ($self, $expected) = @_; + return 1 unless scalar(my @allowed = $self->allowed_http_methods); + return scalar(grep { lc($_) eq lc($expected) } @allowed) ? + 1 : 0; +} + +sub allowed_http_methods { @{shift->attributes->{Method}||[]} } + +sub list_extra_info { sort shift->allowed_http_methods } + +1; + +=head1 NAME + +Catalyst::ActionRole::HTTPMethods - Match on HTTP Methods + +=head1 SYNOPSIS + + package MyApp::Web::Controller::MyController; + + use Moose; + use MooseX::MethodAttributes; + + extends 'Catalyst::Controller'; + + sub user_base : Chained('/') CaptureArg(0) { ... } + + sub get_user : Chained('user_base') Args(1) GET { ... } + sub post_user : Chained('user_base') Args(1) POST { ... } + sub put_user : Chained('user_base') Args(1) PUT { ... } + sub delete_user : Chained('user_base') Args(1) DELETE { ... } + sub head_user : Chained('user_base') Args(1) HEAD { ... } + sub option_user : Chained('user_base') Args(1) OPTION { ... } + sub option_user : Chained('user_base') Args(1) PATCH { ... } + + + sub post_and_put : Chained('user_base') POST PUT Args(1) { ... } + sub method_attr : Chained('user_base') Method('DELETE') Args(0) { ... } + + __PACKAGE__->meta->make_immutable; + +=head1 DESCRIPTION + +This is an action role that lets your L match on standard +HTTP methods, such as GET, POST, etc. + +Since most web browsers have limited support for rich HTTP Method vocabularies +we also support setting the expected match method via the follow non standard +but widely used http extensions. Our support for these should not be taken as +an endorsement of the technique. Rt is merely a reflection of our desire to +work well with existing systems and common client side tools. + +=over 4 + +=item X-HTTP-Method (Microsoft) + +=item X-HTTP-Method-Override (Google/GData) + +=item X-METHOD-OVERRIDE (IBM) + +=back + +Please note the insanity of overriding a GET request with a DELETE override... +Rational practices suggest that using POST with overrides to emulate PUT and +DELETE can be an acceptable way to deal with client limitations and security +rules on your proxy server. I recommend going no further. + +=head1 REQUIRES + +This role requires the following methods in the consuming class. + +=head2 match + +=head2 match_captures + +Returns 1 if the action matches the existing request and zero if not. + +=head1 METHODS + +This role defines the following methods + +=head2 match + +=head2 match_captures + +Around method modifier that return 1 if the request method matches one of the +allowed methods (see L) and zero otherwise. + +=head2 allowed_http_methods + +An array of strings that are the allowed http methods for matching this action +normalized as noted above (using X-Method* overrides). + +=head2 list_extra_info + +Returns an array of the allowed HTTP Methods, sorted. + +=head2 _has_expected_http_method ($expected) + +Private method which returns 1 if C<$expected> matches one of the allowed +in L and zero otherwise. + +=head1 AUTHORS + +Catalyst Contributors, see Catalyst.pm + +=head1 COPYRIGHT + +This library is free software. You can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/Catalyst/ActionRole/HTTPMethods.pm b/lib/Catalyst/ActionRole/HTTPMethods.pm index 4f2a0d5..a0ab7e2 100644 --- a/lib/Catalyst/ActionRole/HTTPMethods.pm +++ b/lib/Catalyst/ActionRole/HTTPMethods.pm @@ -29,7 +29,13 @@ sub _has_expected_http_method { sub allowed_http_methods { @{shift->attributes->{Method}||[]} } -sub list_extra_info { sort shift->allowed_http_methods } +around 'list_extra_info', sub { + my ($orig, $self, @args) = @_; + return { + %{ $self->$orig(@args) }, + +{ HTTP_METHODS => [sort $self->allowed_http_methods] } + }; +}; 1; @@ -116,7 +122,9 @@ normalized as noted above (using X-Method* overrides). =head2 list_extra_info -Returns an array of the allowed HTTP Methods, sorted. +Adds a key => [@values] "HTTP_METHODS" whose value is an ArrayRef of sorted +allowed methods to the ->list_extra_info HashRef. This is used primarily for +debugging output. =head2 _has_expected_http_method ($expected) diff --git a/lib/Catalyst/DispatchType/Chained.pm b/lib/Catalyst/DispatchType/Chained.pm index 5f72fba..5ae5152 100644 --- a/lib/Catalyst/DispatchType/Chained.pm +++ b/lib/Catalyst/DispatchType/Chained.pm @@ -96,14 +96,14 @@ sub list { sort { $a->reverse cmp $b->reverse } @{ $self->_endpoints } ) { - my $args = $endpoint->attributes->{Args}->[0]; + my $args = $endpoint->list_extra_info->{Args}; my @parts = (defined($args) ? (("*") x $args) : '...'); my @parents = (); my $parent = "DUMMY"; my $curr = $endpoint; while ($curr) { - if (my $cap = $curr->attributes->{CaptureArgs}) { - unshift(@parts, (("*") x $cap->[0])); + if (my $cap = $curr->list_extra_info->{CaptureArgs}) { + unshift(@parts, (("*") x $cap)); } if (my $pp = $curr->attributes->{PathPart}) { unshift(@parts, $pp->[0]) @@ -121,8 +121,8 @@ sub list { my @rows; foreach my $p (@parents) { my $name = "/${p}"; - if (my $cap = $p->attributes->{CaptureArgs}) { - $name .= ' ('.$cap->[0].')'; + if (defined(my $cap = $p->list_extra_info->{CaptureArgs})) { + $name .= ' ('.$cap.')'; } unless ($p eq $parents[0]) { $name = "-> ${name}";