File Coverage

blib/lib/Interchange6/Plugin/Interchange5/Request.pm
Criterion Covered Total %
statement 22 40 55.0
branch 2 6 33.3
condition n/a
subroutine 7 22 31.8
pod 18 18 100.0
total 49 86 56.9


line stmt bran cond sub pod time code
1             package Interchange6::Plugin::Interchange5::Request;
2              
3 3     3   58870 use 5.006;
  3         12  
  3         129  
4 3     3   21 use strict;
  3         7  
  3         134  
5 3     3   13 use warnings FATAL => 'all';
  3         4  
  3         133  
6 3     3   1121 use Moo;
  3         25132  
  3         16  
7              
8             =head1 NAME
9              
10             Interchange6::Plugin::Interchange5::Request - Mimic Dancer::Request inside IC5
11              
12             =head1 VERSION
13              
14             Version 0.03
15              
16             =cut
17              
18             our $VERSION = '0.03';
19              
20              
21             =head1 SYNOPSIS
22              
23             Quick summary of what the module does.
24              
25             In a tag (shipped as dancer_request.tag)
26              
27             use Interchange6::Plugin::Interchange5::Request;
28             my %env = %{::http()->{env}};
29             return Interchange6::Plugin::Interchange5::Request->new(env => \%env);
30             ...
31              
32             Somewhere else
33              
34             my $req = $Tag->dancer_request;
35             $req->header('Accept-Language');
36             $req->accept_language;
37             ....
38              
39              
40             =head1 ACCESSORS
41              
42             =head2 env
43              
44             =cut
45              
46             has env => (is => 'ro',
47             required => 1,
48             isa => sub {
49             die unless ref($_[0]) eq 'HASH';
50             });
51              
52             =head1 METHODS
53              
54             =head2 environment($name)
55              
56             Look into the environment variables, with the following routine:
57             first, we uppercase the name and replace any non-alpha and non-digit
58             character with the underscore. Then we look into the environment. If
59             not found, we try to prepend HTTP_. Return undef in nothing is found.
60              
61             =head2 header($name)
62              
63             Alias for environment
64              
65             =cut
66              
67             sub header {
68 0     0 1 0 my ($self, $name) = @_;
69 0         0 return $self->environment($name);
70             }
71              
72             sub environment {
73 62     62 1 76 my ($self, $name) = @_;
74 62 50       123 return unless $name;
75 62         169 $name =~ s/[^a-zA-Z0-9_]/_/g;
76 62         92 $name = uc($name);
77 62         99 my $http_name = "HTTP_" . $name;
78 62         124 my $env = $self->env;
79 62 50       131 if (exists $env->{$name}) {
    0          
80 62         197 return $env->{$name};
81             }
82             elsif (exists $env->{$http_name}) {
83 0         0 return $env->{$http_name};
84             }
85             else {
86 0         0 return;
87             }
88             }
89              
90              
91             =head2 SHORTCUTS
92              
93             The following methods are just shortcuts for the C method.
94              
95             =over 4
96              
97             =item accept
98              
99             =item accept_charset
100              
101             =item accept_encoding
102              
103             =item accept_language
104              
105             =item accept_type
106              
107             =item agent (alias for "user_agent")
108              
109             =item connection
110              
111             =item forwarded_for_address
112              
113             =item forwarded_protocol
114              
115             =item forwarded_host
116              
117             =item host
118              
119             =item keep_alive
120              
121             =item path_info
122              
123             =item referer
124              
125             =item remote_address
126              
127             =item user_agent
128              
129             =back
130              
131             =cut
132              
133 0     0 1 0 sub accept { return shift->environment("accept") }
134              
135 0     0 1 0 sub accept_charset { return shift->environment("accept_charset") }
136              
137 0     0 1 0 sub accept_encoding { return shift->environment("accept_encoding") }
138              
139 60     60 1 111 sub accept_language { return shift->environment("accept_language") }
140              
141 0     0 1 0 sub accept_type { return shift->environment("accept_type") }
142              
143 0     0 1 0 sub agent { return shift->environment("user_agent") }
144              
145 0     0 1 0 sub connection { return shift->environment("connection") }
146              
147 0     0 1 0 sub forwarded_for_address { return shift->environment("forwarded_for_address") }
148              
149 0     0 1 0 sub forwarded_protocol { return shift->environment("forwarded_protocol") }
150              
151 0     0 1 0 sub forwarded_host { return shift->environment("forwarded_host") }
152              
153 0     0 1 0 sub host { return shift->environment("host") }
154              
155 0     0 1 0 sub keep_alive { return shift->environment("keep_alive") }
156              
157 0     0 1 0 sub path_info { return shift->environment("path_info") }
158              
159 0     0 1 0 sub referer { return shift->environment("referer") }
160              
161 2     2 1 4358 sub remote_address { return shift->environment("remote_addr") }
162              
163 0     0 1   sub user_agent { return shift->environment("user_agent") }
164              
165             =head1 AUTHOR
166              
167             Marco Pessotto, C<< >>
168              
169             =head1 BUGS
170              
171             Please report any bugs or feature requests to C, or through
172             the web interface at L. I will be notified, and then you'll
173             automatically be notified of progress on your bug as I make changes.
174              
175              
176              
177              
178             =head1 SUPPORT
179              
180             You can find documentation for this module with the perldoc command.
181              
182             perldoc Interchange6::Plugin::Interchange5::Request
183              
184              
185             You can also look for information at:
186              
187             =over 4
188              
189             =item * RT: CPAN's request tracker (report bugs here)
190              
191             L
192              
193             =item * AnnoCPAN: Annotated CPAN documentation
194              
195             L
196              
197             =item * CPAN Ratings
198              
199             L
200              
201             =item * Search CPAN
202              
203             L
204              
205             =back
206              
207              
208             =head1 ACKNOWLEDGEMENTS
209              
210              
211             =head1 LICENSE AND COPYRIGHT
212              
213             Copyright 2013 Marco Pessotto.
214              
215             This program is free software; you can redistribute it and/or modify it
216             under the terms of either: the GNU General Public License as published
217             by the Free Software Foundation; or the Artistic License.
218              
219             See L for more information.
220              
221              
222             =cut
223              
224             1; # End of Interchange6::Plugin::Interchange5::Request