File Coverage

blib/lib/Limper/Sugar.pm
Criterion Covered Total %
statement 21 40 52.5
branch 0 2 0.0
condition 0 7 0.0
subroutine 7 17 41.1
pod 0 10 0.0
total 28 76 36.8


line stmt bran cond sub pod time code
1             package Limper::Sugar;
2             $Limper::Sugar::VERSION = '0.002';
3 1     1   620 use base 'Limper';
  1         2  
  1         522  
4 1     1   20839 use 5.10.0;
  1         2  
  1         29  
5 1     1   13 use strict;
  1         1  
  1         22  
6 1     1   4 use warnings;
  1         0  
  1         27  
7              
8 1     1   4 use File::Spec;
  1         0  
  1         17  
9 1     1   4 use File::Basename();
  1         1  
  1         75  
10              
11             package # newline because Dist::Zilla::Plugin::PkgVersion and PAUSE indexer
12             Limper;
13              
14             push @Limper::EXPORT, qw/ limper_version load captures dirname halt send_error uri_for redirect content_type path /;
15              
16 0     0 0   sub limper_version { $Limper::VERSION }
17              
18 0     0 0   sub load { require $_ for @_ }
19              
20 1     1 0 509 sub captures { {%+} }
  1     0   383  
  1         325  
  0            
  0            
21              
22 0     0 0   sub dirname { File::Basename::dirname($_[0]) }
23              
24             # WARNING: this does not exit the current route
25 0     0 0   sub halt { @_ }
26              
27             # WARNING: this does not exit the current route
28             sub send_error {
29 0     0 0   my ($content, $status) = @_;
30 0   0       status $status // 500;
31 0           $content;
32             }
33              
34             my $scheme_rx = qr{^[a-z][a-z0-9+.-]*://}i; # RFC 2396
35              
36             sub uri_for {
37 0 0   0 0   return $_[0] unless $_[0] =~ $scheme_rx;
38 0   0       request->{hheaders}{'x-forwarded-host'} // request->{hheaders}{host}, $_[0];
39             }
40              
41             sub redirect {
42 0     0 0   my ($uri, $status) = @_;
43 0   0       status $status // 302;
44 0           headers Location => uri_for $uri;
45             }
46              
47             sub content_type {
48 0     0 0   headers 'Content-Type' => $_[0];
49             }
50              
51             sub path {
52 0     0 0   $_ = File::Spec->catfile(@_);
53 0           s|/\./|/|g;
54 0           1 while s|[^/]*/\.\./||g;
55 0           $_;
56             }
57              
58             1;
59              
60             =for Pod::Coverage
61              
62             =head1 NAME
63              
64             Limper::Sugar - sugary things like Dancer does
65              
66             =head1 VERSION
67              
68             version 0.002
69              
70             =head1 SYNOPSIS
71              
72             use Limper::Sugar;
73             use Limper; # this must come after all extensions
74              
75             # routes
76              
77             limp;
78              
79             =head1 DESCRIPTION
80              
81             B extends L to have sugary things like in L.
82              
83             B: this is all as yet untested.
84              
85             B
86             IN A PLUGIN.> It is meant to facilitate switching from Dancer. Consider
87             everything in here B. Some of these may end up in Limper proper
88             at some point, while others offer no significant benefit. If you really
89             feel it should be in L, make a request.
90              
91             =head1 EXPORTS
92              
93             The following are all additionally exported by default:
94              
95             limper_version load captures dirname halt send_error uri_for redirect content_type path
96              
97             =head1 FUNCTIONS
98              
99             =head2 limper_version
100              
101             Returns the version of Limper in use.
102              
103             =head2 load
104              
105             Sugar around Perl's B, but can take a list of expressions to require.
106              
107             =head2 captures
108              
109             Returns a copy of C<%+> (named capture groups) as a hashref.
110              
111             =head2 dirname
112              
113             Exactly the same as L.
114              
115             =head2 uri_for
116              
117             Prepends the request's B or B value to the path.
118              
119             =head2 redirect
120              
121             redirect $path, $status;
122              
123             Sugar for the following, plus it will turn a Limper path into a URI.
124              
125             status $status // 302;
126             headers Location => uri_for $path;
127              
128             =head2 content_type
129              
130             Sugar for C<< headers 'Content-Type' => $type >>.
131             Note that this does not support abbreviated content types.
132              
133             =head2 path
134              
135             Sugar around L.
136              
137             =head2 halt
138              
139             Merely returns B<@_>.
140              
141             B: In Dancer, this stops execution of the route. In Limper, there
142             is currently no such mechanism. This may change in the future.
143              
144             =head2 send_error
145              
146             send_error $content, $status;
147              
148             Sugar for the following:
149              
150             status $status // 500;
151             $content;
152              
153             B: In Dancer, this stops execution of the route. In Limper, there
154             is currently no such mechanism. This may change in the future.
155              
156             =head1 COPYRIGHT AND LICENSE
157              
158             Copyright (C) 2014 by Ashley Willis Eashley+perl@gitable.orgE
159              
160             This library is free software; you can redistribute it and/or modify
161             it under the same terms as Perl itself, either Perl version 5.12.4 or,
162             at your option, any later version of Perl 5 you may have available.
163              
164             =head1 SEE ALSO
165              
166             L
167              
168             =cut