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 9     9   771 use strict;
  9         17  
  9         277  
3 9     9   44 use warnings qw(FATAL all NONFATAL misc);
  9         15  
  9         386  
4 9     9   41 use Carp;
  9         23  
  9         1234  
5              
6             my @PSGI_FIELDS;
7             BEGIN {
8             @PSGI_FIELDS
9 9     9   77 = 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             REQUEST_URI
21             DOCUMENT_URI
22              
23             QUERY_STRING
24             CONTENT_TYPE
25             CONTENT_LENGTH
26              
27             SERVER_NAME
28             SERVER_PORT
29             SERVER_PROTOCOL
30             HTTP_USER_AGENT
31             HTTP_REFERER
32             HTTP_COOKIE
33             HTTP_FORWARDED
34             HTTP_HOST
35             HTTP_PROXY_CONNECTION
36             HTTP_ACCEPT
37              
38             HTTP_ACCEPT_CHARSET
39             HTTP_ACCEPT_LANGUAGE
40             HTTP_ACCEPT_ENCODING
41              
42             REMOTE_ADDR
43             REMOTE_HOST
44             REMOTE_USER
45             HTTP_X_REAL_IP
46             HTTP_X_CLIENT_IP
47             HTTP_X_FORWARDED_FOR
48              
49             psgi.version
50             psgi.url_scheme
51             psgi.input
52             psgi.errors
53             psgi.multithread
54             psgi.multiprocess
55             psgi.run_once
56             psgi.nonblocking
57             psgi.streaming
58             psgix.session
59             psgix.session.options
60             psgix.logger
61             /;
62 9         23 our %FIELDS = map {$_ => ''} @PSGI_FIELDS;
  405         1191  
63             }
64              
65 9     9   46 use YATT::Lite::Util qw(ckeval globref define_const);
  9         19  
  9         5053  
66              
67             sub import {
68 33     33   105 my ($myPack, @more_fields) = @_;
69              
70 33         79 my $callpack = caller;
71 33         105 my $envpack = $callpack . "::Env";
72             {
73 33         118 my $sym = globref($callpack, 'Env');
74 33 50       65 if (my $val = *{$sym}{CODE}) {
  33         125  
75 0         0 my $old = $val->();
76 0 0       0 croak "Conflicting definition of Env" unless $old eq $envpack;
77             } else {
78 33         137 define_const($sym, $envpack);
79             }
80             }
81             {
82 33         55 my $sym = globref($envpack, 'ISA');
  33         115  
83 33         65 my $val;
84 33 50 33     54 if ($val = *{$sym}{ARRAY} and @$val) {
  33         237  
85 0 0       0 croak "Conflicting definition of ISA: @$val" unless grep {$_ eq $myPack} @$val;
  0         0  
86             } else {
87 33         290 *$sym = [$myPack];
88             }
89             }
90             {
91 33         60 my $sym = globref($envpack, 'FIELDS');
  33         80  
  33         107  
92 33         104 my $fields = +{map {$_ => 1} @PSGI_FIELDS, @more_fields};
  1485         2855  
93 33 50       160 if (my $val = *{$sym}{HASH}) {
  33         109  
94 0         0 foreach my $f (keys %$fields) {
95 0 0       0 unless ($val->{$f} == $fields->{$f}) {
96 0         0 croak "Conflicting definition of field $f";
97             }
98             }
99             } else {
100 33         66810 *$sym = $fields;
101             }
102             }
103             }
104              
105             sub psgi_fields {
106 0 0   0 0 0 wantarray ? @PSGI_FIELDS : {map {$_ => 1} @PSGI_FIELDS};
  0         0  
107             }
108              
109             sub psgi_simple_env {
110 22     22 0 27644 my ($pack) = shift;
111 22         51 my Env $given = {@_};
112 22         39 my Env $env = {};
113 22         73 $env->{'psgi.version'} = [1, 1];
114 22         48 $env->{'psgi.url_scheme'} = 'http';
115 22         51 $env->{'psgi.input'} = \*STDIN;
116 22         52 $env->{'psgi.errors'} = \*STDERR;
117 22         43 $env->{'psgi.multithread'} = 0;
118 22         46 $env->{'psgi.multiprocess'} = 0;
119 22         36 $env->{'psgi.run_once'} = 0;
120 22         57 $env->{'psgi.nonblocking'} = 0;
121 22         41 $env->{'psgi.streaming'} = 0;
122              
123 22   50     124 $env->{PATH_INFO} = $given->{PATH_INFO} || '/';
124              
125 22         67 $env;
126             }
127              
128             1;