File Coverage

blib/lib/YATT/Lite/PSGIEnv.pm
Criterion Covered Total %
statement 50 59 84.7
branch 3 14 21.4
condition 2 5 40.0
subroutine 7 8 87.5
pod 0 2 0.0
total 62 88 70.4


line stmt bran cond sub pod time code
1             package YATT::Lite::PSGIEnv; sub Env () {__PACKAGE__}
2 15     15   541 use strict;
  15         36  
  15         449  
3 15     15   74 use warnings qw(FATAL all NONFATAL misc);
  15         30  
  15         491  
4 15     15   118 use Carp;
  15         28  
  15         1593  
5              
6             my @PSGI_FIELDS;
7             BEGIN {
8             @PSGI_FIELDS
9 15     15   131 = qw/
10             HTTPS
11             GATEWAY_INTERFACE
12             REQUEST_METHOD
13             SCRIPT_NAME
14             SCRIPT_FILENAME
15             DOCUMENT_ROOT
16              
17             PATH_INFO
18             PATH_TRANSLATED
19             REDIRECT_STATUS
20             REDIRECT_HANDLER
21             REDIRECT_URL
22             REQUEST_URI
23             DOCUMENT_URI
24              
25             QUERY_STRING
26             CONTENT_TYPE
27             CONTENT_LENGTH
28              
29             SERVER_NAME
30             SERVER_PORT
31             SERVER_PROTOCOL
32             HTTP_USER_AGENT
33             HTTP_REFERER
34             HTTP_COOKIE
35             HTTP_FORWARDED
36             HTTP_HOST
37             HTTP_PROXY_CONNECTION
38             HTTP_ACCEPT
39              
40             HTTP_ACCEPT_CHARSET
41             HTTP_ACCEPT_LANGUAGE
42             HTTP_ACCEPT_ENCODING
43              
44             REMOTE_ADDR
45             REMOTE_HOST
46             REMOTE_USER
47             HTTP_X_REAL_IP
48             HTTP_X_CLIENT_IP
49             HTTP_X_FORWARDED_FOR
50              
51             psgi.version
52             psgi.url_scheme
53             psgi.input
54             psgi.errors
55             psgi.multithread
56             psgi.multiprocess
57             psgi.run_once
58             psgi.nonblocking
59             psgi.streaming
60             psgix.session
61             psgix.session.options
62             psgix.logger
63              
64             yatt.script_name
65             /;
66 15         39 our %FIELDS = map {$_ => ''} @PSGI_FIELDS;
  720         1916  
67             }
68              
69 15     15   96 use YATT::Lite::Util qw(ckeval globref define_const);
  15         38  
  15         5923  
70              
71             sub import {
72 56     56   514 my ($myPack, @more_fields) = @_;
73              
74 56         153 my $callpack = caller;
75 56         235 my $envpack = $callpack . "::Env";
76             {
77 56         213 my $sym = globref($callpack, 'Env');
78 56 50       125 if (my $val = *{$sym}{CODE}) {
  56         211  
79 0         0 my $old = $val->();
80 0 0       0 croak "Conflicting definition of Env" unless $old eq $envpack;
81             } else {
82 56         218 define_const($sym, $envpack);
83             }
84             }
85             {
86 56         118 my $sym = globref($envpack, 'ISA');
  56         177  
87 56         130 my $val;
88 56 50 33     103 if ($val = *{$sym}{ARRAY} and @$val) {
  56         353  
89 0 0       0 croak "Conflicting definition of ISA: @$val" unless grep {$_ eq $myPack} @$val;
  0         0  
90             } else {
91 56         502 *$sym = [$myPack];
92             }
93             }
94             {
95 56         115 my $sym = globref($envpack, 'FIELDS');
  56         176  
  56         186  
96 56         228 my $fields = +{map {$_ => 1} @PSGI_FIELDS, @more_fields};
  2688         5390  
97 56 50       224 if (my $val = *{$sym}{HASH}) {
  56         206  
98 0         0 foreach my $f (keys %$fields) {
99 0 0       0 unless ($val->{$f} == $fields->{$f}) {
100 0         0 croak "Conflicting definition of field $f";
101             }
102             }
103             } else {
104 56         380517 *$sym = $fields;
105             }
106             }
107             }
108              
109             sub psgi_fields {
110 0 0   0 0 0 wantarray ? @PSGI_FIELDS : {map {$_ => 1} @PSGI_FIELDS};
  0         0  
111             }
112              
113             sub psgi_simple_env {
114 61     61 0 23786 my ($pack) = shift;
115 61         122 my Env $given = {@_};
116 61         112 my Env $env = {};
117 61         179 $env->{'psgi.version'} = [1, 1];
118 61         137 $env->{'psgi.url_scheme'} = 'http';
119 61         138 $env->{'psgi.input'} = \*STDIN;
120 61         125 $env->{'psgi.errors'} = \*STDERR;
121 61         109 $env->{'psgi.multithread'} = 0;
122 61         160 $env->{'psgi.multiprocess'} = 0;
123 61         102 $env->{'psgi.run_once'} = 0;
124 61         159 $env->{'psgi.nonblocking'} = 0;
125 61         113 $env->{'psgi.streaming'} = 0;
126              
127 61   50     267 $env->{PATH_INFO} = $given->{PATH_INFO} || '/';
128              
129 61         180 $env;
130             }
131              
132             1;