File Coverage

blib/lib/Data/Printer/Filter/Web.pm
Criterion Covered Total %
statement 12 23 52.1
branch 2 10 20.0
condition n/a
subroutine 4 6 66.6
pod n/a
total 18 39 46.1


line stmt bran cond sub pod time code
1             package Data::Printer::Filter::Web;
2 1     1   6 use strict;
  1         2  
  1         24  
3 1     1   5 use warnings;
  1         1  
  1         20  
4 1     1   4 use Data::Printer::Filter;
  1         1  
  1         6  
5              
6             ####################
7             ### JSON parsers
8             ### Heavily inspired by nuba++'s excellent Data::Printer::Filter::JSON
9             #############################################
10              
11             sub _parse_json_boolean {
12 24     24   38 my ($value, $ddp) = @_;
13 24 100       49 my @colors = ($value eq 'true'
14             ? ('filter_web_json_true', '#ccffcc')
15             : ('filter_web_json_false', '#ffcccc')
16             );
17 24         46 return $ddp->maybe_colorize($value, @colors);
18             }
19              
20             # JSON::NotString is from JSON::Parser (JSON 1.x)
21             filter 'JSON::NotString' => sub { _parse_json_boolean($_[0]->{value}, $_[1]) };
22              
23             # JSON::Typist
24             filter 'JSON::Typist::String' => sub {
25             my ($obj, $ddp) = @_;
26             require Data::Printer::Common;
27             my $ret = Data::Printer::Common::_process_string($ddp, "$obj", 'string');
28             my $quote = $ddp->maybe_colorize($ddp->scalar_quotes, 'quotes');
29             return $quote . $ret . $quote;
30             };
31              
32             filter 'JSON::Typist::Number' => sub {
33             return $_[1]->maybe_colorize($_[0], 'number');
34             };
35              
36             # NOTE: boolean is used by Pegex::JSON
37             foreach my $json (qw(
38             JSON::DWIW::Boolean JSON::PP::Boolean JSON::SL::Boolean
39             JSON::XS::Boolean boolean JSON::Tiny::_Bool
40             Mojo::JSON::_Bool Cpanel::JSON::XS::Boolean
41             )) {
42             filter "$json" => sub {
43             my ($obj, $ddp) = @_;
44             # because JSON boolean objects are just repeated all over
45             # the place, we must remove them from our "seen" table:
46             $ddp->unsee($obj);
47              
48             return _parse_json_boolean(($$obj == 1 ? 'true' : 'false'), $ddp);
49             };
50             }
51              
52             for my $json (qw( JSON::JOM::Value JSON::JOM::Array JSON::JOM::Object )) {
53             filter "$json" => sub {
54             my ($obj, $ddp) = @_;
55             return $ddp->parse($obj->TO_JSON);
56             };
57             }
58              
59             ####################
60             ### Cookie parsers
61             #############################################
62              
63             filter 'Mojo::Cookie' => sub {
64             my ($obj, $ddp) = @_;
65             return _format_cookie({
66             expires => scalar $obj->expires,
67             max_age => $obj->max_age,
68             domain => $obj->domain,
69             path => $obj->path,
70             secure => $obj->secure,
71             http_only => $obj->httponly,
72             host_only => ($obj->can('host_only') ? $obj->host_only : 0),
73             name => $obj->name,
74             value => $obj->value,
75             class => 'Mojo::Cookie',
76             }, $ddp);
77             };
78              
79             filter 'Dancer::Cookie' => sub {
80             my ($obj, $ddp) = @_;
81             return _format_cookie({
82             expires => scalar $obj->expires,
83             domain => $obj->domain,
84             path => $obj->path,
85             secure => $obj->secure,
86             http_only => $obj->http_only,
87             name => $obj->name,
88             value => $obj->value,
89             class => 'Dancer::Cookie',
90             }, $ddp);
91             };
92              
93             filter 'Dancer2::Core::Cookie' => sub {
94             my ($obj, $ddp) = @_;
95             return _format_cookie({
96             expires => scalar $obj->expires,
97             domain => $obj->domain,
98             path => $obj->path,
99             secure => $obj->secure,
100             http_only => $obj->http_only,
101             name => $obj->name,
102             value => $obj->value,
103             class => 'Dancer2::Core::Cookie',
104             }, $ddp);
105             };
106              
107             sub _format_cookie {
108 0     0     my ($data, $ddp) = @_;
109             return $ddp->maybe_colorize(
110             $data->{name} . '='
111             . Data::Printer::Common::_process_string($ddp, $data->{value})
112             . '; expires=' . $data->{expires}
113             . '; domain=' . $data->{domain}
114             . '; path=' . $data->{path}
115             . ('; secure'x!!$data->{secure})
116             . ('; http-only'x!!$data->{http_only})
117             . ('; host-only'x!!$data->{host_only})
118             . (defined $data->{max_age} ? '; max-age=' . $data->{max_age} : '')
119             , 'filter_web_cookie', '#0b3e21'
120 0 0         ) . ' (' . $ddp->maybe_colorize($data->{class}, 'class') . ')';
121             }
122              
123             ####################
124             ### HTTP parsers
125             #############################################
126              
127             filter 'HTTP::Request' => sub {
128             my ($obj, $ddp) = @_;
129             my $output = $ddp->maybe_colorize($obj->method, 'filter_web_method', '#fefe33')
130             . ' '
131             . $ddp->maybe_colorize($obj->uri, 'filter_web_uri', '#fefe88')
132             ;
133              
134             if ($ddp->extra_config->{filter_web}{show_class_name}) {
135             $output .= ' (' . $ddp->maybe_colorize(ref $obj, 'class') . ')';
136             }
137              
138             my $expand_headers = !exists $ddp->extra_config->{filter_web}{expand_headers}
139             || $ddp->extra_config->{filter_web}{expand_headers};
140              
141             my $content = $obj->decoded_content;
142             if ($expand_headers || $content) {
143             $output .= ' {';
144             $ddp->indent;
145             if ($expand_headers) {
146             if ($obj->headers->can('flatten')) {
147             my %headers = $obj->headers->flatten;
148             $output .= $ddp->newline . 'headers: ' . $ddp->parse(\%headers);
149             }
150             }
151             if ($content) {
152             $output .= $ddp->newline . 'content: '
153             . Data::Printer::Common::_process_string($ddp, $content, 'string');
154             }
155             $ddp->outdent;
156             $output .= $ddp->newline . '}';
157             }
158             return $output;
159             };
160              
161             filter 'HTTP::Response' => sub {
162             my ($obj, $ddp) = @_;
163             my $output = _maybe_show_request($obj, $ddp);
164              
165             if (!exists $ddp->extra_config->{filter_web}{show_redirect}
166             || $ddp->extra_config->{filter_web}{show_redirect}
167             ) {
168             foreach my $redir ($obj->redirects) {
169             $output .= "\x{e2}\x{a4}\x{bf} "
170             . $redir->code . ' ' . $redir->message
171             . ' (' . $redir->header('location') . ')'
172             . $ddp->newline;
173             }
174             }
175              
176             my %colors = (
177             1 => ['filter_web_response_info' , '#3333fe'],
178             2 => ['filter_web_response_success' , '#33fe33'],
179             3 => ['filter_web_response_redirect', '#fefe33'],
180             4 => ['filter_web_response_error' , '#fe3333'],
181             5 => ['filter_web_response_error' , '#fe3333'],
182             );
183             my $status_key = substr($obj->code, 0, 1);
184             $output .= $ddp->maybe_colorize(
185             $obj->status_line,
186             (exists $colors{$status_key} ? @{$colors{$status_key}} : @{$colors{1}})
187             );
188              
189             if ($ddp->extra_config->{filter_web}{show_class_name}) {
190             $output .= ' (' . $ddp->maybe_colorize(ref $obj, 'class') . ')';
191             }
192              
193             my $expand_headers = !exists $ddp->extra_config->{filter_web}{expand_headers}
194             || $ddp->extra_config->{filter_web}{expand_headers};
195              
196             my $content = $obj->decoded_content;
197             if ($expand_headers || $content) {
198             $output .= ' {';
199             $ddp->indent;
200             if ($expand_headers) {
201             if ($obj->headers->can('flatten')) {
202             my %headers = $obj->headers->flatten;
203             $output .= $ddp->newline . 'headers: ' . $ddp->parse(\%headers);
204             }
205             }
206             if ($content) {
207             $output .= $ddp->newline . 'content: '
208             . Data::Printer::Common::_process_string($ddp, $content, 'string');
209             }
210             $ddp->outdent;
211             $output .= $ddp->newline . '}';
212             }
213             return $output;
214             };
215              
216             sub _maybe_show_request {
217 0     0     my ($obj, $ddp) = @_;
218 0 0         return '' unless $ddp->extra_config->{filter_web}{show_request_in_response};
219              
220 0           my ($redir) = $obj->redirects;
221 0           my $output = 'Request: ';
222 0           my $request;
223 0 0         if ($redir) {
224 0           $request = $redir->request;
225             }
226             else {
227 0           $request = $obj->request;
228             }
229 0 0         return $output . ($request ? $ddp->parse($request) : '-');
230             }
231              
232              
233             1;
234             __END__