File Coverage

blib/lib/JavaScript/XRay.pm
Criterion Covered Total %
statement 144 201 71.6
branch 52 94 55.3
condition 34 57 59.6
subroutine 16 18 88.8
pod 4 4 100.0
total 250 374 66.8


line stmt bran cond sub pod time code
1             package JavaScript::XRay;
2 2     2   27659 use warnings;
  2         3  
  2         59  
3 2     2   7 use strict;
  2         2  
  2         42  
4 2     2   6 use Carp qw(croak);
  2         5  
  2         108  
5 2     2   762 use LWP::Simple qw(get);
  2         99190  
  2         12  
6 2     2   297 use URI;
  2         2  
  2         4974  
7              
8             our $VERSION = '0.99_5';
9             our $PACKAGE = __PACKAGE__;
10             our %SWITCHES = (
11             all => {
12             type => 'bool',
13             desc => 'filter all functions (default)',
14             },
15             none => {
16             type => 'bool',
17             desc => 'don\'t filter any functions',
18             },
19             anon => {
20             type => 'bool',
21             desc => 'filter anon functions (noisy)',
22             },
23             no_exec_count => {
24             type => 'bool',
25             desc => 'don\'t count function executions',
26             },
27             only => {
28             type => 'function1,function2,...',
29             desc => 'only filter listed functions (exact)',
30             ref_type => 'ARRAY'
31             },
32             skip => {
33             type => 'function1,function2,...',
34             desc => 'skip listed functions (exact)',
35             ref_type => 'ARRAY'
36             },
37             uncomment => {
38             type => 'string1,string2,...',
39             desc => 'uncomment lines prefixed with string (DEBUG1,DEBUG2)',
40             ref_type => 'ARRAY'
41             },
42             match => {
43             type => 'string',
44             desc => 'only filter functions that match string (/^string/)',
45             ref_type => 'Regexp'
46             },
47             );
48              
49             our @SWITCH_KEYS = keys %SWITCHES;
50              
51             sub new {
52 7     7 1 3624 my ( $class, %args ) = @_;
53              
54 7   100     24 my $alias = $args{alias} || 'jsxray';
55             my $obj = {
56             alias => $alias,
57             abs_uri => $args{abs_uri},
58             iframe_height => $args{iframe_height} || 200,
59             css_inline => $args{css_inline},
60             css_external => $args{css_external},
61             verbose => $args{verbose},
62 7   100     50 js_log => '',
63             js_log_init => '',
64             };
65              
66 7         8 bless $obj, $class;
67              
68 7         18 $obj->_init_uri( $args{abs_uri} );
69             #$obj->auto_switches if $obj->can('auto_swtiches');
70 7 100       16 $obj->switches( %{$args{switches}} ) if $args{switches};
  6         23  
71              
72 7         20 return $obj;
73             }
74              
75             sub _init_uri {
76 7     7   13 my ( $self, $abs_uri ) = @_;
77 7 50       16 return unless $abs_uri;
78 0 0       0 $self->{abs_uri} = ref $abs_uri eq 'URI' ? $abs_uri : URI->new($abs_uri);
79 0         0 return;
80             }
81              
82             sub switches {
83 6     6 1 10 my ( $self, %switches ) = @_;
84 6 50       11 return $self->{switches} unless keys %switches;
85            
86             # allow 'jsxray_uncomment' or just 'uncomment'
87 6         6 my $alias = $self->{alias};
88             %switches = map {
89 6         12 my $new_key = $_;
  14         10  
90 14         70 $new_key =~ s/^$alias\_//;
91 14         34 ( $new_key => $switches{$_} );
92             } keys %switches;
93              
94 6         14 for my $switch ( keys %switches ) {
95 14 50       22 unless ( $SWITCHES{$switch} ) {
96 0         0 warn "invalid switch: $switch";
97 0         0 next;
98             }
99 14         15 my $ref_type = ref $switches{$switch};
100             $self->{switches}{$switch} =
101             $ref_type eq 'ARRAY' && $SWITCHES{$switch}{ref_type} eq 'ARRAY'
102 0         0 ? join(',', @{ $switches{$switch} })
103 14 50 33     43 : $switches{$switch};
104             }
105            
106             # init other switches so we don't get warnings
107 6         11 for my $switch (@SWITCH_KEYS) {
108             $self->{switches}{$switch} = ''
109 48 100       86 unless $self->{switches}{$switch};
110             }
111              
112 6         3 return %{ $self->{switches} };
  6         11  
113             }
114              
115             sub inline_methods {
116 0     0 1 0 my ( $self, @methods ) = @_;
117              
118 0 0       0 if ( @methods ) {
119 0         0 my @valid_methods = ();
120 0         0 for my $method (@methods) {
121 0 0 0     0 unless ( -d $method
      0        
122             || $method eq 'HTTP_GET'
123             || ref $method eq 'CODE' )
124             {
125 0         0 warn 'inline methods may only be local server '
126             . 'directories, code references, or the special string '
127             . "HTTP_GET - invalid method: $method";
128             }
129             else {
130 0         0 push @valid_methods, $method;
131             }
132             }
133              
134 0 0       0 unless (@valid_methods) {
135 0         0 warn 'inline_methods called without valid methods';
136 0         0 exit;
137             }
138            
139 0         0 $self->{inline_methods} = \@valid_methods;
140             }
141              
142 0 0       0 return wantarray ? @{ $self->{inline_methods} } : $self->{inline_methods};
  0         0  
143             }
144              
145             sub filter {
146 7     7 1 296 my ( $self, $html ) = @_;
147              
148 7         12 my ( $alias, $switch ) = ( $self->{alias}, $self->{switches} );
149              
150             $self->_warn( 'Tracing anonymous functions' )
151 7 100 100     27 if $switch->{anon} && !$switch->{only};
152              
153             $self->_warn( "Only tracing functions exactly matching: $switch->{only}" )
154 7 100       14 if $switch->{only};
155              
156 7 100       16 $self->_warn( "Skipping functions: $switch->{skip}" ) if $switch->{skip};
157              
158             $self->_warn( "Tracing matching functions: /^$switch->{match}/" )
159 7 100       14 if $switch->{match};
160              
161 7         10 $html = $self->_filter($html);
162 6         13 $html = $self->_inline_javascript($html);
163              
164 6 100       18 $self->_uncomment( \$html ) if $switch->{uncomment};
165 6         15 $self->_inject_console( \$html );
166 6         10 $self->_inject_js_css( \$html );
167              
168 6         17 return $html;
169             }
170              
171             sub _filter {
172 7     7   7 my ( $self, $work_html ) = @_;
173              
174 7         8 my ( $alias, $switch ) = ( $self->{alias}, $self->{switches} );
175              
176 7         8 my $new_html = '';
177 7         52 while (
178             $work_html =~ m/
179             \G
180             (.+?)
181             (
182             function?
183             \s*
184             (?:\w|_)+?
185             \s*?
186             \(
187             .+?
188             \)?
189             \s*
190             \{
191             )
192             /cgimosx
193             )
194             {
195              
196             # build output page from input page
197 35         53 $new_html .= $1;
198              
199             # find the function name
200 35         39 my $function .= $2;
201 35         122 my ($name) = $function =~ m/function\s*(\w+?)?\s*?\(/gx;
202 35 100       59 $name = '' unless $name; # define it to supress warnings
203              
204             # don't want any recursive JavaScript loops
205 35 100       205 croak( "found function '$name', functions may "
206             . "not match alias: '$alias'" )
207             if $name eq $alias;
208              
209             # find the function arguments
210 34         469 my ($args) = $function =~ m/function\s*$name?\s*?\((.+?)\)/gx;
211 34 100       53 $name = 'ANON' unless $name;
212              
213 34 100 100     115 unless ( $switch->{no_exec_count}
      66        
214             || ( $name eq 'ANON' && !$switch->{anon} ) )
215             {
216 26         38 $self->{js_log_init} .= "${alias}_exec_count['$name'] = 0;\n";
217 26         45 $function .= "${alias}_exec_count['$name']++;";
218             }
219              
220             my %only_function = $switch->{only}
221 23         43 ? map { $_ => 1 } split( /\,/, $switch->{only} )
222 34 100       64 : ();
223             my %skip_function = $switch->{skip}
224 5         13 ? map { $_ => 1 } split( /\,/, $switch->{skip} )
225 34 100       55 : ();
226              
227 34         30 my $function_filter = '';
228 34 50       70 if (ref $switch->{match} eq 'Regexp') {
    100          
229 0         0 $function_filter = $switch->{match};
230             }
231             elsif ( $switch->{match} ) {
232 5         6 my $safe_filter = quotemeta $switch->{match};
233 5         20 $function_filter = qr/^$safe_filter/;
234             }
235              
236             # skip filter
237             # if none
238             # if anon and not filtering anon functions
239             # if switch 'only' used and function doesn't match
240             # if switch 'skip' used and function matches
241             # if switch 'filter' used and function doesn't match
242 34 100 100     257 if ( ( $switch->{none} )
      33        
      100        
      66        
      66        
      66        
      100        
      66        
243             || ( $name eq 'ANON' && !$switch->{anon} )
244             || ( $switch->{only} && !$only_function{$name} )
245             || ( $switch->{skip} && $skip_function{$name} )
246             || ( $switch->{match} && $name !~ m/$function_filter/x ) )
247             {
248 19         117 $new_html .= $function;
249             }
250             else {
251 15         32 $self->_warn("Found function '$name'");
252              
253             # build out function arguments - this is the cool part
254             # you also get to see the value of arguments passed to the
255             # function, _extremely_ handy
256 15         17 my $filtered_args = '';
257 15 100       21 if ($args) {
258 3         7 my @arg_list = split( /\,/, $args );
259 3         7 $filtered_args = '\'+' . join( '+\', \'+', @arg_list ) . '+\'';
260             }
261              
262             # insert the log call
263             $new_html
264 15         106 .= $function . "$alias('$name( $filtered_args )');";
265             }
266             }
267              
268 6 50       16 if ( $work_html =~ /\G(.*)/cgs ) {
269 6         12 $new_html .= $1;
270             }
271              
272 6         18 return $new_html;
273             }
274              
275             sub _inline_javascript {
276 6     6   7 my ( $self, $work_html ) = @_;
277              
278 6         5 my $new_html = '';
279              
280             # look through the HTML for script blocks
281 6         30 while (
282             $work_html =~ m/
283             \G
284             (.*?)
285             (
286             ";
350              
351 0         0 $new_html .= "\n";
352 0         0 $new_html .= $inline_javascript;
353             }
354             else {
355 0         0 warn 'failed to inline (or referenced URI is empty): '
356             . $script_block;
357 0         0 $new_html .= $script_block;
358             }
359             }
360             else {
361 6         36 $new_html .= $script_block;
362             }
363             }
364             }
365              
366 6 50       16 if ( $work_html =~ /\G(.*)/cgs ) {
367 6         8 $new_html .= $1;
368             }
369              
370 6         15 return $new_html;
371             }
372              
373             sub _get_external_javascript {
374 0     0   0 my ( $self, $src ) = @_;
375 0         0 my $js = '';
376              
377 0 0 0     0 if ( $src !~ /^http/i && !$self->{abs_uri} ) {
378 0         0 warn 'unable to inline/filter external javascript files with an'
379             . 'absolute request uri: abs_uri not defined';
380 0         0 return $js;
381             }
382              
383             # FIXME not sure how the none HTTP URI works to get the complete file
384             # path in the case (but it does somehow) Need to unit test this
385             # code and figur out what's happening.
386             my $abs_js_uri =
387             $src =~ /^http/
388             ? URI->new( $src, $self->{abs_uri} )
389 0 0       0 : URI->new($src);
390              
391 0         0 for my $method ( @{$self->{inline_methods}} ) {
  0         0  
392 0 0       0 if ($method eq 'HTTP_GET') {
    0          
    0          
393 0         0 $js = get( $abs_js_uri );
394             }
395             elsif ( -d $method ) {
396 0         0 my $possible_js_file = $method . $abs_js_uri->path;
397 0 0       0 if ( open( my $fh, 'r', $possible_js_file ) ) {
398 0         0 $js = do { local $/; $/ = undef; <$fh> };
  0         0  
  0         0  
  0         0  
399 0         0 close $fh;
400             }
401             else {
402 0         0 warn "failed to open: $possible_js_file: $!";
403             }
404             }
405             elsif ( ref $method eq 'CODE' ) {
406 0         0 $js = &$method( $src, $self->{abs_uri} );
407             }
408 0 0       0 last if $js;
409             }
410              
411 0 0       0 if ($js) {
412 0         0 $self->_warn("Inlining and Filtering $src");
413 0         0 $js = $self->_filter($js);
414             }
415              
416 0         0 return $js;
417             }
418              
419             sub _uncomment {
420 2     2   4 my ( $self, $html_ref ) = @_;
421 2         4 my $switch = $self->{switches};
422              
423             # uncomment nessesary tags
424             my @uncomment_strings
425 2         8 = map { quotemeta($_) } split( /\,/, $switch->{uncomment} );
  3         12  
426 2         5 for my $uncomment (@uncomment_strings) {
427 3         30 my $uncomment_count = $$html_ref =~ s/\/\/$uncomment//gs;
428 3 100       9 if ($uncomment_count) {
429 1 50       5 my $label = $uncomment_count > 1 ? 'instances' : 'instance';
430 1         5 $self->_warn( "$PACKAGE->filter uncommented $uncomment: "
431             . "Found $uncomment_count $label" );
432             }
433             }
434              
435 2         3 return;
436             }
437              
438             sub _inject_js_css {
439 6     6   6 my ( $self, $html_ref ) = @_;
440 6         9 my ( $alias, $switches ) = ( $self->{alias}, $self->{switches} );
441              
442 6         87 my $js_css = qq|\n|;
605 6         10 $js_css .= $self->_css;
606              
607 6         128 $$html_ref =~ s/()/$1$js_css/is;
608              
609 6         8 return;
610             }
611              
612             sub _inject_console {
613 6     6   7 my ( $self, $html_ref ) = @_;
614              
615 6         9 my ( $alias, $switches ) = ( $self->{alias}, $self->{switches} );
616              
617 6         24 my $iframe .= qq|
618            
619             $PACKAGE v$VERSION
620            
621             onClick="${alias}_toggle_logging()" class="${alias}_button">
622            
623             onClick="${alias}_toggle_info()" class="${alias}_button">
624            
625             class="${alias}_button">|;
626              
627             $iframe .= qq|
628             onClick="${alias}_alert_counts()" class="${alias}_button">|
629 6 100       16 unless $switches->{no_exec_count};
630              
631 6         8 $iframe .= qq|
632            
633            
634             |; |;
635              
636 6         12 for my $switch ( @SWITCH_KEYS ) {
637 48   100     98 my $value = $switches->{$switch} || '';
638 48         130 $iframe .= qq|
639             ${alias}_$switch
640               
641             $value
642             $SWITCHES{$switch}{type}
643               
644             $SWITCHES{$switch}{desc}
645            
646             }
647              
648 6         18 $iframe .= qq|
649            
650            
651            
652            
653            
654            
655            
656             |;
657              
658 6         83 $$html_ref =~ s/()/$1$iframe/is;
659              
660 6         14 return;
661             }
662              
663             sub _css {
664 12     12   6 my ($self, $escape_bool) = @_;
665              
666 12         13 my ($alias) = ($self->{alias});
667              
668 12         55 my $css = qq|\n";
721              
722             # include external file
723             $css .= "
724             . "type='text/css' />\n"
725 12 100       17 if $self->{css_external};
726              
727 12 100       19 if ($escape_bool) {
728 6         70 $css =~ s/\n/\\n/sg;
729 6         7 $css =~ s/\"/\\\"/g;
730             }
731              
732 12         25 return $css;
733             }
734              
735             sub _warn {
736 23     23   24 my ( $self, $msg ) = @_;
737 23         25 my $alias = $self->{alias};
738 23 50       56 warn "[$alias] $msg\n" if $self->{verbose};
739 23         55 $self->{js_log} .= qq| ${alias}_pre_iframe_queue.push(|
740             . qq|"${PACKAGE}->filter $msg");\n|;
741 23         23 return;
742             }
743              
744             1;
745              
746             __END__