blib/lib/Plack/Middleware/Debug/HTML/Mason.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 24 | 77 | 31.1 |
branch | 0 | 12 | 0.0 |
condition | 0 | 5 | 0.0 |
subroutine | 8 | 13 | 61.5 |
pod | 1 | 1 | 100.0 |
total | 33 | 108 | 30.5 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Plack::Middleware::Debug::HTML::Mason; | ||||||
2 | $Plack::Middleware::Debug::HTML::Mason::VERSION = '0.2'; | ||||||
3 | 1 | 1 | 16188 | use strict; | |||
1 | 2 | ||||||
1 | 44 | ||||||
4 | 1 | 1 | 5 | use warnings; | |||
1 | 2 | ||||||
1 | 41 | ||||||
5 | |||||||
6 | 1 | 1 | 521 | use parent qw(Plack::Middleware::Debug::Base); | |||
1 | 274 | ||||||
1 | 5 | ||||||
7 | |||||||
8 | =head1 NAME | ||||||
9 | |||||||
10 | Plack::Middleware::Debug::HTML::Mason - Debug info for old HTML::Mason apps. | ||||||
11 | |||||||
12 | =head1 VERSION | ||||||
13 | |||||||
14 | version 0.2 | ||||||
15 | |||||||
16 | =head1 SYNOPSIS | ||||||
17 | |||||||
18 | # add this to your mason configuration | ||||||
19 | plugins => ['Plack::Middleware::Debug::HTML::Mason::Plugin'] | ||||||
20 | |||||||
21 | # and then enable the middleware | ||||||
22 | enable 'Debug::HTML::Mason'; | ||||||
23 | |||||||
24 | =head1 DESCRIPTION | ||||||
25 | |||||||
26 | Provides a call tree and some basic configuration information for a request | ||||||
27 | processed by HTML::Mason. | ||||||
28 | |||||||
29 | =cut | ||||||
30 | |||||||
31 | my $root; | ||||||
32 | my @stack; | ||||||
33 | my %env; | ||||||
34 | my $ran; | ||||||
35 | |||||||
36 | package Plack::Middleware::Debug::HTML::Mason::Plugin { | ||||||
37 | 1 | 1 | 33160 | use strict; | |||
1 | 3 | ||||||
1 | 51 | ||||||
38 | 1 | 1 | 7 | use warnings; | |||
1 | 1 | ||||||
1 | 50 | ||||||
39 | 1 | 1 | 5 | use parent qw(HTML::Mason::Plugin); | |||
1 | 3 | ||||||
1 | 14 | ||||||
40 | 1 | 1 | 2061 | use Time::HiRes qw(time); | |||
1 | 1946 | ||||||
1 | 5 | ||||||
41 | 1 | 1 | 1077 | use JSON; | |||
1 | 10229 | ||||||
1 | 5 | ||||||
42 | |||||||
43 | my $json = JSON->new->convert_blessed(1)->allow_blessed(1)->allow_unknown(1)->utf8(1); | ||||||
44 | |||||||
45 | sub start_component_hook { | ||||||
46 | 0 | 0 | my ($self, $context) = @_; | ||||
47 | |||||||
48 | 0 | my $frame = { | |||||
49 | start => time(), | ||||||
50 | kids => [], | ||||||
51 | }; | ||||||
52 | 0 | 0 | $root ||= [$frame]; | ||||
53 | 0 | 0 | if (@stack) { | ||||
54 | 0 | my $parent= $stack[-1]; | |||||
55 | 0 | push @{$parent->{kids}}, $frame; | |||||
0 | |||||||
56 | } | ||||||
57 | 0 | push @stack, $frame; | |||||
58 | } | ||||||
59 | |||||||
60 | sub end_component_hook { | ||||||
61 | 0 | 0 | my ($self, $context) = @_; | ||||
62 | |||||||
63 | 0 | my $frame = pop @stack; | |||||
64 | 0 | my $name = $context->comp->title; | |||||
65 | |||||||
66 | 0 | my ($path, $root, $method) = $name =~ m/(.*) (\[.+?\])(:.+)?/; | |||||
67 | |||||||
68 | 0 | 0 | $frame->{name} = $method ? "$root $path$method" : "$root $path"; | ||||
69 | 0 | $frame->{end} = time(); | |||||
70 | 0 | $frame->{duration} = $frame->{end} - $frame->{start}; | |||||
71 | 0 | $frame->{args} = $json->encode($context->args); | |||||
72 | } | ||||||
73 | |||||||
74 | sub end_request_hook { | ||||||
75 | 0 | 0 | my ($self, $context) = @_; | ||||
76 | |||||||
77 | 0 | $env{main_comp} = $context->request->request_comp; | |||||
78 | 0 | $env{args} = $context->args; | |||||
79 | 0 | $env{comp_root} = $context->request->interp->comp_root; | |||||
80 | 0 | $ran = 1; | |||||
81 | } | ||||||
82 | |||||||
83 | } | ||||||
84 | |||||||
85 | |||||||
86 | sub run { | ||||||
87 | 0 | 0 | 1 | my ($self, $env, $panel) = @_; | |||
88 | |||||||
89 | 0 | $root = undef; | |||||
90 | 0 | @stack = (); | |||||
91 | 0 | %env = (); | |||||
92 | 0 | $ran = 0; | |||||
93 | |||||||
94 | return sub { | ||||||
95 | 0 | 0 | my $res = shift; | ||||
96 | |||||||
97 | 0 | $panel->nav_title("HTML::Mason"); | |||||
98 | 0 | $panel->title("HTML::Mason Summary"); | |||||
99 | |||||||
100 | 0 | 0 | unless ($ran) { | ||||
101 | 0 | $panel->content('No DataNo data was recorded by the mason plugin. Make sure mason is configured to use the |
|||||
102 | 0 | return; | |||||
103 | } | ||||||
104 | |||||||
105 | |||||||
106 | 0 | my $depth = 0; | |||||
107 | 0 | my $frame; | |||||
108 | my $walker; | ||||||
109 | 0 | my $html = ''; | |||||
110 | 0 | my $i = 0; | |||||
111 | $walker = sub { | ||||||
112 | 0 | my ($context, $depth) = @_; | |||||
113 | 0 | 0 | 0 | return unless $context && @$context; | |||
114 | |||||||
115 | |||||||
116 | 0 | foreach my $frame (@$context) { | |||||
117 | 0 | my $margin = sprintf("%dpx", $depth * 16); | |||||
118 | 0 | my $background; | |||||
119 | 0 | $i++; | |||||
120 | 0 | 0 | if ($i % 2) { | ||||
0 | |||||||
121 | 0 | $background = '#f5f5f5'; | |||||
122 | } | ||||||
123 | elsif ($frame->{name} eq $env{main_comp}->title) { | ||||||
124 | 0 | $background = '#f0f0f0'; | |||||
125 | } | ||||||
126 | else { | ||||||
127 | 0 | $background = 'white'; | |||||
128 | } | ||||||
129 | |||||||
130 | 0 | $html .= sprintf(' %s(%s) - %.5fs ', |
|||||
131 | $background, | ||||||
132 | $margin, | ||||||
133 | $frame->{name}, | ||||||
134 | $frame->{args}, | ||||||
135 | $frame->{duration}, | ||||||
136 | ); | ||||||
137 | |||||||
138 | 0 | $walker->($frame->{kids}, $depth + 1); | |||||
139 | } | ||||||
140 | 0 | }; | |||||
141 | |||||||
142 | 0 | $walker->($root, 1); | |||||
143 | |||||||
144 | 0 | my $css = < | |||||
145 | |||||||
157 | END | ||||||
158 | |||||||
159 | 0 | $panel->content( | |||||
160 | $self->render_list_pairs([ | ||||||
161 | 'Main Comp' => $env{main_comp}->source_file, | ||||||
162 | 'Args' => $env{args}, | ||||||
163 | 'Comp Root' => $env{comp_root}, | ||||||
164 | |||||||
165 | ]) . | ||||||
166 | qq|$css $html | |
||||||
167 | ); | ||||||
168 | 0 | }; | |||||
169 | } | ||||||
170 | |||||||
171 | |||||||
172 | |||||||
173 | =head1 TODO | ||||||
174 | |||||||
175 | =over 2 | ||||||
176 | |||||||
177 | =item * | ||||||
178 | |||||||
179 | The docs are pretty middling at the moment. | ||||||
180 | |||||||
181 | =back | ||||||
182 | |||||||
183 | =head1 AUTHORS | ||||||
184 | |||||||
185 | Chris Reinhardt | ||||||
186 | crein@cpan.org | ||||||
187 | |||||||
188 | David Hand | ||||||
189 | cogent@cpan.org | ||||||
190 | |||||||
191 | =head1 COPYRIGHT | ||||||
192 | |||||||
193 | This program is free software; you can redistribute | ||||||
194 | it and/or modify it under the same terms as Perl itself. | ||||||
195 | |||||||
196 | The full text of the license can be found in the | ||||||
197 | LICENSE file included with this module. | ||||||
198 | |||||||
199 | =head1 SEE ALSO | ||||||
200 | |||||||
201 | L |
||||||
202 | |||||||
203 | =cut | ||||||
204 | |||||||
205 | 1; | ||||||
206 | $Plack::Middleware::Debug::HTML::Mason::Plugin::VERSION = '0.2'; | ||||||
207 | __END__ |