File Coverage

blib/lib/Wurm.pm
Criterion Covered Total %
statement 74 83 89.1
branch 32 52 61.5
condition 4 13 30.7
subroutine 18 24 75.0
pod 3 3 100.0
total 131 175 74.8


line stmt bran cond sub pod time code
1             package Wurm;
2              
3 2     2   13351 use strict;
  2         2  
  2         43  
4 2     2   6 use warnings;
  2         2  
  2         36  
5 2     2   21 use v5.20;
  2         4  
6              
7 2     2   6 use Scalar::Util qw();
  2         8  
  2         1368  
8              
9             our $VERSION = '0.0.7';
10              
11             sub import {
12 2     2   9 my ($class, @symbols) = @_;
13              
14 2         3 my %symbols = map {$_ => 1} @symbols;
  1         3  
15              
16 2 50       7 require $class. '/mob.pm' if $symbols{mob};
17 2 100       943 require $class. '/let.pm' if $symbols{let};
18             }
19              
20             sub wrapp {
21 1     1 1 18 my ($wurm, $mind) = @_;
22              
23 1   50     4 $wurm //= { };
24 1   33     8 $wurm->{mob} //= exists $INC{'Wurm/mob.pm'};
25              
26 1         3 my $case = _ncase($wurm->{case}, $wurm->{mob});
27 1         3 my $pore = _upore($wurm->{pore});
28             my $app = sub {
29 15     15   10372 my $env = shift;
30             my $log = defined $env->{'psgix.logger'}
31             ? $env->{'psgix.logger'}
32             : sub { }
33 15 50       58 ;
34             my $meal = $case->({
35             env => $env,
36             log => $log,
37             tube => $env->{PATH_INFO},
38 15         69 mind => $mind,
39             seen => '',
40             grit => { },
41             vent => { },
42             view => undef,
43             });
44 15         55 return $pore->(fold($meal, $wurm), $meal);
45 1         3 };
46              
47 1 50       3 return wantarray ? ($app, $wurm) : $app;
48             }
49              
50             sub _ncase {
51 1     1   1 my $wrap = shift;
52 1         1 my $mob = shift;
53              
54             return defined $wrap
55             ? sub {
56 15     15   14 my $meal = shift;
57 15         36 $meal->{tube} =~ s#\A/##;
58 15 50       27 return $wrap->($mob ? Wurm::mob->new($meal) : $meal);
59             }
60             : sub {
61 0     0   0 my $meal = shift;
62 0         0 $meal->{tube} =~ s#\A/##;
63 0 0       0 return $mob ? Wurm::mob->new($meal) : $meal;
64             }
65 1 50       5 ;
66             }
67              
68             sub _upore {
69 1     1   2 my $wrap = shift;
70              
71             return defined $wrap
72             ? sub {
73 15   33 15   23 my $cast = $wrap->(@_) // _404();
74 15 50       99 return Scalar::Util::blessed($cast) ? $cast->finalize : $cast;
75             }
76             : sub {
77 0   0 0   0 my $cast = shift // _404();
78 0 0       0 return Scalar::Util::blessed($cast) ? $cast->finalize : $cast;
79             }
80 1 50       5 ;
81             }
82              
83             # Guild and its navigators, who the spice has mutated over 4,000 years,
84             # use the orange spice gas, which gives them the ability to fold space.
85             # We, however, are just folding tubes.
86             sub fold {
87 27     27 1 19 my ($meal, $wurm) = @_;
88              
89 27 50       38 die "unable to fold (imaginary wurm)\n" unless defined $wurm;
90 27 50       44 die "unable to fold (mangled wurm)\n" unless 'HASH' eq ref $wurm;
91              
92 27 50       37 if(defined $wurm->{gate}) {
93 27         34 my $res = $wurm->{gate}->($meal);
94 27 50       77 return $res
95             if defined $res;
96             }
97              
98 27 100 50     52 if(($meal->{tube} // '') ne '') {
99 18         20 my $atom = bend($meal);
100 18 50       32 return _404()
101             unless defined $atom;
102              
103 18         15 my $tube = $wurm->{tube}{$atom};
104 18 100       29 return _404()
105             unless defined $tube;
106              
107             # malkovich?
108 12         20 my $res = fold($meal, $tube);
109 12 50       31 return $res
110             if defined $res;
111             }
112              
113 9 50       13 if(defined $wurm->{neck}) {
114 9         12 my $res = $wurm->{neck}->($meal);
115 9 100       28 return $res
116             if defined $res;
117             }
118              
119 6 100       8 if(defined $wurm->{body}) {
120 3         14 my $method = lc $meal->{env}{REQUEST_METHOD};
121 3         3 my $body = $wurm->{body}{$method};
122 3 100       6 if(defined $body) {
123 1         2 my $res = $body->($meal);
124 1 50       4 return $res
125             if defined $res;
126             }
127             }
128              
129 6 100       8 if(defined $wurm->{tail}) {
130 3         4 my $res = $wurm->{tail}->($meal);
131 3 100       10 return $res
132             if defined $res;
133             }
134              
135 4         5 return _404();
136             }
137              
138             # There is no spoon. There are a series of tubes. Bendy ones.
139             sub bend {
140 18     18 1 15 my ($meal) = @_;
141              
142 18 50       64 $meal->{tube} =~ s#\A(?[^/]+)(?:/|\z)##
143             or return;
144 2     2   772 $meal->{seen} .= "$+{atom}/";
  2         692  
  2         293  
  18         76  
145 18         53 return $+{atom};
146             }
147              
148             # Happy, happy. Joy, joy.
149 5     5   35 sub _200 {[200, ['Content-Type' => $_[0]], [$_[1]]]}
150              
151             #
152 0     0   0 sub _201 {[201, ['Location' => $_[0]], []]}
153              
154             # There can be only none!
155 0     0   0 sub _204 {[204, [], []]}
156              
157             # One pluseth two verily to thus be thine six hundreds and three, sir.
158 0     0   0 sub _301 {[301, ['Location' => $_[0]], []]}
159 1     1   6 sub _302 {[302, ['Location' => $_[0]], []]}
160              
161             # Down in a hole. Losing my soul.
162 1     1   5 sub _400 {[400, ['Content-Type', 'text/plain'], ['.oOo.']]}
163              
164             # Istanbul is Constantinople.
165 18     18   57 sub _404 {[404, ['Content-Type' => 'text/plain'], ['Not Found']]}
166              
167             # My eyes. The goggles do nothing.
168 0     0     sub _500 {[500, ['Content-Type' => 'text/plain'], ['Internal Server Error']]}
169              
170             '.oOo.' # in wurm i trust
171             __END__