File Coverage

blib/lib/CGI/Application/Plugin/DevPopup.pm
Criterion Covered Total %
statement 51 53 96.2
branch 7 10 70.0
condition 2 5 40.0
subroutine 10 10 100.0
pod 2 2 100.0
total 72 80 90.0


line stmt bran cond sub pod time code
1             package CGI::Application::Plugin::DevPopup;
2             {
3             $CGI::Application::Plugin::DevPopup::VERSION = '1.08';
4             }
5              
6 4     4   238921 use warnings;
  4         12  
  4         145  
7 4     4   22 use strict;
  4         8  
  4         141  
8              
9 4     4   23 use base 'Exporter';
  4         13  
  4         321  
10 4     4   7839 use HTML::Template;
  4         97607  
  4         218  
11 4     4   1446 use CGI::Application 4.01;
  4         8874  
  4         8532  
12              
13             our @EXPORT = qw/ devpopup /;
14              
15             my ( $head, $script, $template ); # html stuff for our screen
16              
17             sub import
18             {
19 3     3   40 my $caller = scalar(caller);
20 3 100       47 $caller->add_callback( 'postrun', \&_devpopup_output ) if $ENV{'CAP_DEVPOPUP_EXEC'};
21 3         64 $caller->new_hook('devpopup_report');
22 3         4698 goto &Exporter::import;
23             }
24              
25             sub devpopup
26             {
27 5     5 1 42 my $app = shift; # a cgiapp object
28 5         24 my $dp = $app->param('__CAP_DEVPOPUP');
29 5 100       98 unless ($dp)
30             {
31 2         13 $dp = bless [], __PACKAGE__;
32 2         7 $app->param( '__CAP_DEVPOPUP' => $dp );
33             }
34 5         93 return $dp;
35             }
36              
37             sub add_report
38             {
39 3     3 1 27 my $self = shift; # a devpopup object
40 3         15 my %params = @_;
41 3   50     20 $params{severity} ||= 'info';
42 3         14 push @$self, \%params;
43             }
44              
45             sub _devpopup_output
46             {
47 2     2   44330 my ( $self, $outputref ) = @_;
48              
49 2 50       14 return unless $self->header_type eq 'header'; # don't operate on redirects or 'none'
50 2         46 my %props = $self->header_props;
51 2         50 my ($type) = grep /type/i, keys %props;
52 2 50 33     18 return if defined $type and # no type defaults to html, so we have work to do.
53             $props{$type} !~ /html/i; # else skip any other types.
54              
55 2         11 my $devpopup = $self->devpopup;
56 2         17 $self->call_hook( 'devpopup_report', $outputref ); # process our callback hook
57              
58 2         61 my $tmpl = HTML::Template->new(
59             scalarref => \$template,
60             die_on_bad_params => 0,
61             loop_context_vars => 1,
62             );
63 2         9880 $tmpl->param(
64             reports => $devpopup,
65             app_class => ref($self),
66             runmode => $self->get_current_runmode,
67             );
68            
69 2         211 my $o = _escape_js($tmpl->output);
70 2         10 my $h = _escape_js($head);
71 2         20 my $j = _escape_js($script . join($/, map { $_->{script} } grep exists $_->{script}, @$devpopup) );
  0         0  
72              
73 2         71 my $js = qq{
74            
89             };
90              
91             # insert the js code before the body close,
92             # if one exists
93 2 50       19 if ( $$outputref =~ m!!i )
94             {
95 2         134 $$outputref =~ s!!$js\n!i;
96             }
97             else
98             {
99 0         0 $$outputref .= $js;
100             }
101             }
102              
103             sub _escape_js
104             {
105 6     6   2597 my $j = shift;
106 6         27 $j =~ s/\r//g;
107 6         28 $j =~ s/\\/\\\\/g;
108 6         104 $j =~ s/"/\\"/g;
109 6         92 $j =~ s/\n/\\n" + \n\t"/g;
110 6         19 $j =~ s/script>/s" + "cript>/g;
111 6         20 $j;
112             }
113              
114             $head = <
115            
116            
117             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
118              
119            
120            
121             Devpopup results
122            
136             HEAD
137              
138             $script = <
139             function swap(id1,id2)
140             {
141             var d1 = document.getElementById(id1);
142             var d2 = document.getElementById(id2);
143             var s = d1.style.display;
144             d1.style.display = d2.style.display;
145             d2.style.display = s;
146             }
147             JS
148              
149             $template = <
150            
151            
152            

Devpopup report for ->

153             Print
154            
155            
156            
157            
    • 158             -
    159            
    160            
    161            
    162            
    163              
    164            
    165            
    166            

    167             class="sev_"
    168             onclick="swap('#DPS','#DPR')">
    169            
    170            
    171            
    172            
    173            
    174            
    175            
    176            
    177              
    178            
    179            
    180             TMPL
    181              
    182             1; # End of CGI::Application::Plugin::DevPopup
    183              
    184             __END__