File Coverage

blib/lib/JavaScript/XRay.pm
Criterion Covered Total %
statement 164 221 74.2
branch 63 108 58.3
condition 37 59 62.7
subroutine 18 20 90.0
pod 4 4 100.0
total 286 412 69.4


line stmt bran cond sub pod time code
1             package JavaScript::XRay;
2 2     2   58261 use warnings;
  2         4  
  2         81  
3 2     2   12 use strict;
  2         4  
  2         80  
4 2     2   10 use Carp qw(croak);
  2         26  
  2         164  
5 2     2   2021 use LWP::Simple qw(get);
  2         279592  
  2         20  
6 2     2   488 use URI;
  2         5  
  2         55  
7 2     2   11 use constant IFRAME_DEFAULT_HEIGHT => 200;
  2         3  
  2         11467  
8              
9             our $VERSION = '1.22';
10             our $PACKAGE = __PACKAGE__;
11             our %SWITCHES = (
12             all => {
13             type => 'bool',
14             desc => 'filter all functions (default)',
15             },
16             none => {
17             type => 'bool',
18             desc => 'don\'t filter any functions',
19             },
20             anon => {
21             type => 'bool',
22             desc => 'filter anon functions (noisy)',
23             },
24             no_exec_count => {
25             type => 'bool',
26             desc => 'don\'t count function executions',
27             },
28             only => {
29             type => 'function1,function2,...',
30             desc => 'only filter listed functions (exact)',
31             ref_type => 'ARRAY',
32             },
33             skip => {
34             type => 'function1,function2,...',
35             desc => 'skip listed functions (exact)',
36             ref_type => 'ARRAY'
37             },
38             uncomment => {
39             type => 'string1,string2,...',
40             desc => 'uncomment lines prefixed with string (DEBUG1,DEBUG2)',
41             ref_type => 'ARRAY'
42             },
43             match => {
44             type => 'string',
45             desc => 'only filter functions that match string (/^string/)',
46             ref_type => 'Regexp'
47             },
48             );
49              
50             our @SWITCH_KEYS = keys %SWITCHES;
51              
52             sub new {
53 7     7 1 7247 my ( $class, %args ) = @_;
54              
55 7   100     39 my $alias = $args{alias} || 'jsxray';
56 7   100     96 my $obj = {
57             alias => $alias,
58             iframe_height => $args{iframe_height} || IFRAME_DEFAULT_HEIGHT,
59             css_inline => $args{css_inline},
60             css_external => $args{css_external},
61             verbose => $args{verbose},
62             inline_methods => ['HTTP_GET'],
63             js_log => '',
64             js_log_init => '',
65             js_switches => '',
66             js_function_names => '',
67             };
68              
69 7         22 bless $obj, $class;
70              
71 7         33 $obj->_init_uri( $args{abs_uri} );
72 7 100       26 $obj->switches( %{$args{switches}} ) if $args{switches};
  6         28  
73              
74 7         24 return $obj;
75             }
76              
77             sub _init_uri {
78 7     7   15 my ( $self, $abs_uri ) = @_;
79 7 50       23 return unless $abs_uri;
80 0 0       0 $self->{abs_uri} = ref $abs_uri eq 'URI' ? $abs_uri : URI->new($abs_uri);
81 0         0 return;
82             }
83              
84             sub switches {
85 6     6 1 16 my ( $self, %switches ) = @_;
86 6 50       17 return $self->{switches} unless keys %switches;
87              
88             # allow 'jsxray_uncomment' or just 'uncomment'
89 6         11 my $alias = $self->{alias};
90 14         18 %switches = map {
91 6         15 my $new_key = $_;
92 14         106 $new_key =~ s/^$alias\_//;
93 14         58 ( $new_key => $switches{$_} );
94             } keys %switches;
95              
96 6         22 for my $switch ( keys %switches ) {
97 14 50       35 unless ( $SWITCHES{$switch} ) {
98 0         0 warn "invalid switch: $switch";
99 0         0 next;
100             }
101 14         22 my $ref_type = ref $switches{$switch};
102 0         0 $self->{switches}{$switch} =
103             $ref_type eq 'ARRAY' && $SWITCHES{$switch}{ref_type} eq 'ARRAY'
104 14 50 33     52 ? join(',', @{ $switches{$switch} })
105             : $switches{$switch};
106              
107 14         47 $self->{js_switches} .= qq|${alias}_switches.push("${alias}_${switch}");\n|;
108             }
109              
110             # init other switches so we don't get warnings
111 6         102 for my $switch (@SWITCH_KEYS) {
112 48 100       135 $self->{switches}{$switch} = ''
113             unless $self->{switches}{$switch};
114             }
115              
116 6         9 return %{ $self->{switches} };
  6         20  
117             }
118              
119             sub inline_methods {
120 0     0 1 0 my ( $self, @methods ) = @_;
121              
122 0 0       0 if ( @methods ) {
123 0         0 my @valid_methods = ();
124 0         0 for my $method (@methods) {
125 0 0 0     0 unless ( -d $method
126             || $method eq 'HTTP_GET'
127             || ref $method eq 'CODE' )
128             {
129 0         0 warn 'inline methods may only be local server '
130             . 'directories, code references, or the special string '
131             . "HTTP_GET - invalid method: $method";
132             }
133             else {
134 0         0 push @valid_methods, $method;
135             }
136             }
137              
138 0 0       0 unless (@valid_methods) {
139 0         0 warn 'inline_methods called without valid methods';
140 0         0 exit;
141             }
142            
143 0         0 $self->{inline_methods} = \@valid_methods;
144             }
145              
146 0 0       0 return wantarray ? @{ $self->{inline_methods} } : $self->{inline_methods};
  0         0  
147             }
148              
149             sub filter {
150 7     7 1 657 my ( $self, $html ) = @_;
151              
152 7         21 my ( $alias, $switch ) = ( $self->{alias}, $self->{switches} );
153              
154 7 100 100     46 $self->_warn( 'Tracing anonymous functions' )
155             if $switch->{anon} && !$switch->{only};
156              
157 7 100       30 $self->_warn( "Only tracing functions exactly matching: $switch->{only}" )
158             if $switch->{only};
159              
160 7 100       27 $self->_warn( "Skipping functions: $switch->{skip}" ) if $switch->{skip};
161              
162 7 100       20 $self->_warn( "Tracing matching functions: /^$switch->{match}/" )
163             if $switch->{match};
164              
165 7         19 $html = $self->_filter($html);
166 6         18 $html = $self->_inline_javascript($html);
167              
168 6 100       23 $self->_uncomment( \$html ) if $switch->{uncomment};
169 6         21 $self->_inject_console( \$html );
170              
171 6         21 $self->_inject_js_css( \$html );
172              
173 6         25 return $html;
174             }
175              
176             sub _filter {
177 7     7   13 my ( $self, $work_html ) = @_;
178              
179 7         13 my ( $alias, $switch ) = ( $self->{alias}, $self->{switches} );
180              
181 7         11 my $new_html = '';
182 7         80 while (
183             $work_html =~ m{
184             \G
185             (.+?)
186             (
187             function?
188             \s*
189             (?:\w|_)+?
190             \s*?
191             [(]
192             .+?
193             [)]?
194             \s*
195             \{
196             )
197             }cgimosx
198             )
199             {
200              
201             # build output page from input page
202 35         88 $new_html .= $1;
203              
204             # find the function name
205 35         61 my $function .= $2;
206 35         205 my ($name) = $function =~ m/function\s*(\w+?)?\s*?\(/gx;
207 35 100       74 $name = '' unless $name; # define it to supress warnings
208              
209             # don't want any recursive JavaScript loops
210 35 100       287 croak( "found function '$name', functions may "
211             . "not match alias: '$alias'" )
212             if $name eq $alias;
213              
214             # find the function arguments
215 34         795 my ($args) = $function =~ m/function\s*$name?\s*?[(](.+?)[)]/gx;
216 34 100       137 $name = 'ANON' unless $name;
217              
218 34 100 100     140 unless ( $switch->{no_exec_count}
      66        
219             || ( $name eq 'ANON' && !$switch->{anon} ) )
220             {
221 26         78 $self->{js_log_init} .= "${alias}_exec_count['$name'] = 0;\n";
222 26         63 $function .= "${alias}_exec_count['$name']++;";
223             }
224              
225             # functions for use in form to select query parameters
226 34 100       116 $self->_switch_function_options($name) if ($name ne 'ANON');
227            
228 23         78 my %only_function = $switch->{only}
229 34 100       129 ? map { $_ => 1 } split( /\,/, $switch->{only} )
230             : ();
231 5         17 my %skip_function = $switch->{skip}
232 34 100       88 ? map { $_ => 1 } split( /\,/, $switch->{skip} )
233             : ();
234              
235 34         47 my $function_filter = '';
236 34 50       103 if (ref $switch->{match} eq 'Regexp') {
    100          
237 0         0 $function_filter = $switch->{match};
238             }
239             elsif ( $switch->{match} ) {
240 5         10 my $safe_filter = quotemeta $switch->{match};
241 5         36 $function_filter = qr/^$safe_filter/;
242             }
243              
244             # skip filter
245             # if none
246             # if anon and not filtering anon functions
247             # if switch 'only' used and function doesn't match
248             # if switch 'skip' used and function matches
249             # if switch 'filter' used and function doesn't match
250 34 100 100     345 if ( ( $switch->{none} )
      33        
      100        
      66        
      100        
      66        
      100        
      66        
251             || ( $name eq 'ANON' && !$switch->{anon} )
252             || ( $switch->{only} && !$only_function{$name} )
253             || ( $switch->{skip} && $skip_function{$name} )
254             || ( $switch->{match} && $name !~ m/$function_filter/x ) )
255             {
256 19         244 $new_html .= $function;
257             }
258             else {
259 15         54 $self->_warn("Found function '$name'");
260              
261             # build out function arguments - this is the cool part
262             # you also get to see the value of arguments passed to the
263             # function, _extremely_ handy
264 15         19 my $filtered_args = '';
265 15 100       28 if ($args) {
266 3         9 my @arg_list = split( /\,/, $args );
267 3         9 $filtered_args = '\'+' . join( '+\', \'+', @arg_list ) . '+\'';
268             }
269              
270             # insert the log call
271             $new_html
272 15         150 .= $function . "$alias('$name( $filtered_args )');";
273             }
274             }
275              
276 6 50       24 if ( $work_html =~ /\G(.*)/cgs ) {
277 6         13 $new_html .= $1;
278             }
279              
280 6         35 return $new_html;
281             }
282              
283             sub _inline_javascript {
284 6     6   10 my ( $self, $work_html ) = @_;
285              
286 6         8 my $new_html = '';
287              
288             # look through the HTML for script blocks
289 6         46 while (
290             $work_html =~ m{
291             \G
292             (.*?)
293             (
294             ";
358              
359 0         0 $new_html .= "\n";
360 0         0 $new_html .= $inline_javascript;
361             }
362             else {
363 0         0 warn 'failed to inline (or referenced URI is empty): '
364             . $script_block;
365 0         0 $new_html .= $script_block;
366             }
367             }
368             else {
369 6         54 $new_html .= $script_block;
370             }
371             }
372             }
373              
374 6 50       23 if ( $work_html =~ /\G(.*)/cgs ) {
375 6         16 $new_html .= $1;
376             }
377              
378 6         24 return $new_html;
379             }
380              
381             sub _get_external_javascript {
382 0     0   0 my ( $self, $src ) = @_;
383 0         0 my $js = '';
384              
385 0 0 0     0 if ( $src !~ /^http/i && !$self->{abs_uri} ) {
386 0         0 warn 'unable to inline/filter external javascript files with an'
387             . 'absolute request uri: abs_uri not defined';
388 0         0 return $js;
389             }
390              
391             # if true its an absolute uri so no need to call new_abs
392 0 0 0     0 my $abs_js_uri =
393             $src =~ /^http/ || ( $src =~ /^\// && $self->{abs_uri} =~ /^\// )
394             ? URI->new($src)
395             : URI->new_abs( $src, $self->{abs_uri} );
396              
397 0         0 for my $method ( @{$self->{inline_methods}} ) {
  0         0  
398 0 0       0 if ($method eq 'HTTP_GET') {
    0          
    0          
399 0 0       0 $self->_warn("attempting to fetch: $abs_js_uri")
400             if $self->{verbose};
401 0         0 $js = get( $abs_js_uri );
402             }
403             elsif ( -d $method ) {
404 0         0 my $possible_js_file = URI->new_abs( $src, $method );
405 0 0       0 if ( open( my $fh, '<', $possible_js_file ) ) {
406 0         0 $js = do { local $/ = undef; <$fh> };
  0         0  
  0         0  
407 0         0 close $fh;
408             }
409             else {
410 0         0 warn "failed to open: $possible_js_file: $!";
411             }
412             }
413             elsif ( ref $method eq 'CODE' ) {
414 0         0 $js = &$method( $src, $self->{abs_uri} );
415             }
416 0 0       0 last if $js;
417             }
418              
419 0 0       0 if ($js) {
420 0         0 $self->_warn("Inlining and Filtering $src");
421 0         0 $js = $self->_filter($js);
422             }
423              
424 0         0 return $js;
425             }
426              
427             sub _uncomment {
428 2     2   4 my ( $self, $html_ref ) = @_;
429 2         5 my $switch = $self->{switches};
430              
431             # uncomment nessesary tags
432             my @uncomment_strings
433 2         7 = map { quotemeta($_) } split( /\,/, $switch->{uncomment} );
  3         10  
434 2         5 for my $uncomment (@uncomment_strings) {
435 3         36 my $uncomment_count = $$html_ref =~ s/\/\/$uncomment//gs;
436 3 100       10 if ($uncomment_count) {
437 1 50       5 my $label = $uncomment_count > 1 ? 'instances' : 'instance';
438 1         8 $self->_warn( "$PACKAGE->filter uncommented $uncomment: "
439             . "Found $uncomment_count $label" );
440             }
441             }
442              
443 2         5 return;
444             }
445              
446             sub _inject_js_css {
447 6     6   10 my ( $self, $html_ref ) = @_;
448 6         14 my ( $alias, $switches ) = ( $self->{alias}, $self->{switches} );
449              
450 6         123 my $js_css = qq|\n|;
739 6         17 $js_css .= $self->_css;
740              
741 6         312 $$html_ref =~ s/()/$1$js_css/is;
742              
743 6         14 return;
744             }
745              
746             sub _inject_console {
747 6     6   10 my ( $self, $html_ref ) = @_;
748              
749 6         14 my ( $alias, $switches ) = ( $self->{alias}, $self->{switches} );
750              
751 6         48 my $iframe .= qq|
752            
753             $PACKAGE v$VERSION
754            
755             onClick="${alias}_toggle_logging()" class="${alias}_button">
756            
757             onClick="${alias}_toggle_info()" class="${alias}_button">
758            
759             class="${alias}_button">
760            
761             onClick="${alias}_toggle_switch()" class="${alias}_button">|;
762              
763 6 100       20 $iframe .= qq|
764             onClick="${alias}_alert_counts()" class="${alias}_button">|
765             unless $switches->{no_exec_count};
766              
767 6         12 $iframe .= qq|
768            
769            
770             |; |;
771              
772 6         14 for my $switch ( @SWITCH_KEYS ) {
773 48   100     143 my $value = $switches->{$switch} || '';
774 48         212 $iframe .= qq|
775             ${alias}_$switch
776               
777             $value
778             $SWITCHES{$switch}{type}
779               
780             $SWITCHES{$switch}{desc}
781            
782             }
783              
784 6         24 $iframe .= qq|
785            
786            
787            
788              
789            
790            
791            
792            
793            
X
794            
Use 'Ctrl' key to choose function names in multiple selection boxes. Click on "Reload Console" for new switches to take effect.
795            
796             |;
797            
|;
798            
799 6         10 for my $switch (@SWITCH_KEYS) {
800 48 100       92 next if ( $switch eq 'all' );
801 42   100     117 my $value = $switches->{$switch} || '';
802 42         36 my $form_element;
803 42 100       154 if ( $SWITCHES{$switch}{type} eq 'bool' ) {
    100          
    50          
804 18 100       28 my $checkbox_value = $value ? ' checked' : '';
805 18         36 $form_element = qq||;
806             }
807             elsif ( $SWITCHES{$switch}{type} =~ /string/ ) {
808 12         28 $form_element = qq||;
809             }
810             elsif ( $SWITCHES{$switch}{type} =~ /function/ ) {
811 12         27 $form_element = qq||;
812             }
813 42         129 $iframe .= qq|
${alias}_$switch: $form_element
814             }
815            
816 6         31 $iframe .= qq|
817            
 
818            
 
819            
820            
821            
822            
823            
824            
825            
826            
827            
828             |;
829              
830 6         183 $$html_ref =~ s/()/$1$iframe/is;
831              
832 6         13 return;
833             }
834              
835             sub _css {
836 12     12   18 my ($self, $escape_bool) = @_;
837              
838 12         17 my ($alias) = ($self->{alias});
839              
840 12         89 my $css = qq|\n";
908              
909             # include external file
910 12 100       30 $css .= "
911             . "type='text/css' />\n"
912             if $self->{css_external};
913              
914 12 100       22 if ($escape_bool) {
915 6         132 $css =~ s/\n/\\n/sg;
916 6         24 $css =~ s/\"/\\\"/g;
917             }
918              
919 12         50 return $css;
920             }
921              
922             sub _warn {
923 23     23   30 my ( $self, $msg ) = @_;
924 23         35 my $alias = $self->{alias};
925 23 50       42 warn "[$alias] $msg\n" if $self->{verbose};
926 23         82 $self->{js_log} .= qq| ${alias}_pre_iframe_queue.push(|
927             . qq|"${PACKAGE}->filter $msg");\n|;
928            
929 23         35 return;
930             }
931              
932             sub _switch_function_options {
933 27     27   41 my ( $self, $msg ) = @_;
934 27         36 my $alias = $self->{alias};
935 27         67 $self->{js_function_names} .= qq|
936 27         44 return;
937             }
938              
939              
940             1;
941              
942             __END__