File Coverage

blib/lib/Plack/Middleware/MethodOverride.pm
Criterion Covered Total %
statement 37 37 100.0
branch 11 12 91.6
condition 5 6 83.3
subroutine 10 10 100.0
pod 3 3 100.0
total 66 68 97.0


line stmt bran cond sub pod time code
1 1     1   78259 use 5.008001;
  1         19  
2 1     1   7 use strict;
  1         2  
  1         25  
3 1     1   7 use warnings;
  1         2  
  1         52  
4 1     1   557 use Plack::Request ();
  1         56507  
  1         39  
5              
6             package Plack::Middleware::MethodOverride;
7              
8             our $VERSION = '0.17';
9              
10 1     1   9 use parent 'Plack::Middleware';
  1         1  
  1         7  
11 1     1   4260 use Plack::Util::Accessor 'param';
  1         3  
  1         3  
12              
13             my %allowed_method = map { $_ => undef } qw(GET HEAD PUT DELETE OPTIONS TRACE CONNECT PATCH);
14              
15             sub new {
16 2     2 1 1184 my $class = shift;
17 2         22 my $self = $class->SUPER::new(@_);
18 2 100       75 $self->{param} = 'x-tunneled-method' unless exists $self->{param};
19 2 100       8 $self->{header} = 'X-HTTP-Method-Override' unless exists $self->{header};
20 2         11 $self->header($self->{header}); # munge it
21 2         5 return $self;
22             }
23              
24             sub call {
25 32     32 1 80435 my ($self, $env) = @_;
26 32         87 my $meth = $env->{'plack.original_request_method'} = $env->{REQUEST_METHOD};
27              
28 32 100 66     143 if ($meth and uc $meth eq 'POST') {
29 1     1   117 no warnings 'uninitialized';
  1         3  
  1         146  
30             my $override = uc (
31             $env->{$self->header}
32 28   100     57 or $env->{QUERY_STRING} && Plack::Request->new($env)->query_parameters->{$self->param}
33             );
34 28 100       591 $env->{REQUEST_METHOD} = $override if exists $allowed_method{$override};
35             }
36              
37 32         80 $self->app->($env);
38             }
39              
40             sub header {
41 30     30 1 49 my $self = shift;
42              
43 30 100       161 return $self->{header} if not @_;
44 2 50       8 return $self->{header} = '' if not $_[0];
45              
46 2         10 (my $key = 'HTTP_'.$_[0]) =~ tr/-a-z/_A-Z/;
47 2         7 return $self->{header} = $key;
48             }
49              
50             1;
51              
52             __END__