package JavaScript::XRay;
use warnings;
use strict;
use Carp qw(croak);
use LWP::Simple qw(get);
use URI;
use constant IFRAME_DEFAULT_HEIGHT => 200;
our $VERSION = '1.22';
our $PACKAGE = __PACKAGE__;
our %SWITCHES = (
all => {
type => 'bool',
desc => 'filter all functions (default)',
},
none => {
type => 'bool',
desc => 'don\'t filter any functions',
},
anon => {
type => 'bool',
desc => 'filter anon functions (noisy)',
},
no_exec_count => {
type => 'bool',
desc => 'don\'t count function executions',
},
only => {
type => 'function1,function2,...',
desc => 'only filter listed functions (exact)',
ref_type => 'ARRAY',
},
skip => {
type => 'function1,function2,...',
desc => 'skip listed functions (exact)',
ref_type => 'ARRAY'
},
uncomment => {
type => 'string1,string2,...',
desc => 'uncomment lines prefixed with string (DEBUG1,DEBUG2)',
ref_type => 'ARRAY'
},
match => {
type => 'string',
desc => 'only filter functions that match string (/^string/)',
ref_type => 'Regexp'
},
);
our @SWITCH_KEYS = keys %SWITCHES;
sub new {
my ( $class, %args ) = @_;
my $alias = $args{alias} || 'jsxray';
my $obj = {
alias => $alias,
iframe_height => $args{iframe_height} || IFRAME_DEFAULT_HEIGHT,
css_inline => $args{css_inline},
css_external => $args{css_external},
verbose => $args{verbose},
inline_methods => ['HTTP_GET'],
js_log => '',
js_log_init => '',
js_switches => '',
js_function_names => '',
};
bless $obj, $class;
$obj->_init_uri( $args{abs_uri} );
$obj->switches( %{$args{switches}} ) if $args{switches};
return $obj;
}
sub _init_uri {
my ( $self, $abs_uri ) = @_;
return unless $abs_uri;
$self->{abs_uri} = ref $abs_uri eq 'URI' ? $abs_uri : URI->new($abs_uri);
return;
}
sub switches {
my ( $self, %switches ) = @_;
return $self->{switches} unless keys %switches;
# allow 'jsxray_uncomment' or just 'uncomment'
my $alias = $self->{alias};
%switches = map {
my $new_key = $_;
$new_key =~ s/^$alias\_//;
( $new_key => $switches{$_} );
} keys %switches;
for my $switch ( keys %switches ) {
unless ( $SWITCHES{$switch} ) {
warn "invalid switch: $switch";
next;
}
my $ref_type = ref $switches{$switch};
$self->{switches}{$switch} =
$ref_type eq 'ARRAY' && $SWITCHES{$switch}{ref_type} eq 'ARRAY'
? join(',', @{ $switches{$switch} })
: $switches{$switch};
$self->{js_switches} .= qq|${alias}_switches.push("${alias}_${switch}");\n|;
}
# init other switches so we don't get warnings
for my $switch (@SWITCH_KEYS) {
$self->{switches}{$switch} = ''
unless $self->{switches}{$switch};
}
return %{ $self->{switches} };
}
sub inline_methods {
my ( $self, @methods ) = @_;
if ( @methods ) {
my @valid_methods = ();
for my $method (@methods) {
unless ( -d $method
|| $method eq 'HTTP_GET'
|| ref $method eq 'CODE' )
{
warn 'inline methods may only be local server '
. 'directories, code references, or the special string '
. "HTTP_GET - invalid method: $method";
}
else {
push @valid_methods, $method;
}
}
unless (@valid_methods) {
warn 'inline_methods called without valid methods';
exit;
}
$self->{inline_methods} = \@valid_methods;
}
return wantarray ? @{ $self->{inline_methods} } : $self->{inline_methods};
}
sub filter {
my ( $self, $html ) = @_;
my ( $alias, $switch ) = ( $self->{alias}, $self->{switches} );
$self->_warn( 'Tracing anonymous functions' )
if $switch->{anon} && !$switch->{only};
$self->_warn( "Only tracing functions exactly matching: $switch->{only}" )
if $switch->{only};
$self->_warn( "Skipping functions: $switch->{skip}" ) if $switch->{skip};
$self->_warn( "Tracing matching functions: /^$switch->{match}/" )
if $switch->{match};
$html = $self->_filter($html);
$html = $self->_inline_javascript($html);
$self->_uncomment( \$html ) if $switch->{uncomment};
$self->_inject_console( \$html );
$self->_inject_js_css( \$html );
return $html;
}
sub _filter {
my ( $self, $work_html ) = @_;
my ( $alias, $switch ) = ( $self->{alias}, $self->{switches} );
my $new_html = '';
while (
$work_html =~ m{
\G
(.+?)
(
function?
\s*
(?:\w|_)+?
\s*?
[(]
.+?
[)]?
\s*
\{
)
}cgimosx
)
{
# build output page from input page
$new_html .= $1;
# find the function name
my $function .= $2;
my ($name) = $function =~ m/function\s*(\w+?)?\s*?\(/gx;
$name = '' unless $name; # define it to supress warnings
# don't want any recursive JavaScript loops
croak( "found function '$name', functions may "
. "not match alias: '$alias'" )
if $name eq $alias;
# find the function arguments
my ($args) = $function =~ m/function\s*$name?\s*?[(](.+?)[)]/gx;
$name = 'ANON' unless $name;
unless ( $switch->{no_exec_count}
|| ( $name eq 'ANON' && !$switch->{anon} ) )
{
$self->{js_log_init} .= "${alias}_exec_count['$name'] = 0;\n";
$function .= "${alias}_exec_count['$name']++;";
}
# functions for use in form to select query parameters
$self->_switch_function_options($name) if ($name ne 'ANON');
my %only_function = $switch->{only}
? map { $_ => 1 } split( /\,/, $switch->{only} )
: ();
my %skip_function = $switch->{skip}
? map { $_ => 1 } split( /\,/, $switch->{skip} )
: ();
my $function_filter = '';
if (ref $switch->{match} eq 'Regexp') {
$function_filter = $switch->{match};
}
elsif ( $switch->{match} ) {
my $safe_filter = quotemeta $switch->{match};
$function_filter = qr/^$safe_filter/;
}
# skip filter
# if none
# if anon and not filtering anon functions
# if switch 'only' used and function doesn't match
# if switch 'skip' used and function matches
# if switch 'filter' used and function doesn't match
if ( ( $switch->{none} )
|| ( $name eq 'ANON' && !$switch->{anon} )
|| ( $switch->{only} && !$only_function{$name} )
|| ( $switch->{skip} && $skip_function{$name} )
|| ( $switch->{match} && $name !~ m/$function_filter/x ) )
{
$new_html .= $function;
}
else {
$self->_warn("Found function '$name'");
# build out function arguments - this is the cool part
# you also get to see the value of arguments passed to the
# function, _extremely_ handy
my $filtered_args = '';
if ($args) {
my @arg_list = split( /\,/, $args );
$filtered_args = '\'+' . join( '+\', \'+', @arg_list ) . '+\'';
}
# insert the log call
$new_html
.= $function . "$alias('$name( $filtered_args )');";
}
}
if ( $work_html =~ /\G(.*)/cgs ) {
$new_html .= $1;
}
return $new_html;
}
sub _inline_javascript {
my ( $self, $work_html ) = @_;
my $new_html = '';
# look through the HTML for script blocks
while (
$work_html =~ m{
\G
(.*?)
(
";
$new_html .= "\n";
$new_html .= $inline_javascript;
}
else {
warn 'failed to inline (or referenced URI is empty): '
. $script_block;
$new_html .= $script_block;
}
}
else {
$new_html .= $script_block;
}
}
}
if ( $work_html =~ /\G(.*)/cgs ) {
$new_html .= $1;
}
return $new_html;
}
sub _get_external_javascript {
my ( $self, $src ) = @_;
my $js = '';
if ( $src !~ /^http/i && !$self->{abs_uri} ) {
warn 'unable to inline/filter external javascript files with an'
. 'absolute request uri: abs_uri not defined';
return $js;
}
# if true its an absolute uri so no need to call new_abs
my $abs_js_uri =
$src =~ /^http/ || ( $src =~ /^\// && $self->{abs_uri} =~ /^\// )
? URI->new($src)
: URI->new_abs( $src, $self->{abs_uri} );
for my $method ( @{$self->{inline_methods}} ) {
if ($method eq 'HTTP_GET') {
$self->_warn("attempting to fetch: $abs_js_uri")
if $self->{verbose};
$js = get( $abs_js_uri );
}
elsif ( -d $method ) {
my $possible_js_file = URI->new_abs( $src, $method );
if ( open( my $fh, '<', $possible_js_file ) ) {
$js = do { local $/ = undef; <$fh> };
close $fh;
}
else {
warn "failed to open: $possible_js_file: $!";
}
}
elsif ( ref $method eq 'CODE' ) {
$js = &$method( $src, $self->{abs_uri} );
}
last if $js;
}
if ($js) {
$self->_warn("Inlining and Filtering $src");
$js = $self->_filter($js);
}
return $js;
}
sub _uncomment {
my ( $self, $html_ref ) = @_;
my $switch = $self->{switches};
# uncomment nessesary tags
my @uncomment_strings
= map { quotemeta($_) } split( /\,/, $switch->{uncomment} );
for my $uncomment (@uncomment_strings) {
my $uncomment_count = $$html_ref =~ s/\/\/$uncomment//gs;
if ($uncomment_count) {
my $label = $uncomment_count > 1 ? 'instances' : 'instance';
$self->_warn( "$PACKAGE->filter uncommented $uncomment: "
. "Found $uncomment_count $label" );
}
}
return;
}
sub _inject_js_css {
my ( $self, $html_ref ) = @_;
my ( $alias, $switches ) = ( $self->{alias}, $self->{switches} );
my $js_css = qq|\n|;
$js_css .= $self->_css;
$$html_ref =~ s/(
)/$1$js_css/is;
return;
}
sub _inject_console {
my ( $self, $html_ref ) = @_;
my ( $alias, $switches ) = ( $self->{alias}, $self->{switches} );
my $iframe .= qq|
|;
$$html_ref =~ s/()/$1$iframe/is;
return;
}
sub _css {
my ($self, $escape_bool) = @_;
my ($alias) = ($self->{alias});
my $css = qq|\n";
# include external file
$css .= "\n"
if $self->{css_external};
if ($escape_bool) {
$css =~ s/\n/\\n/sg;
$css =~ s/\"/\\\"/g;
}
return $css;
}
sub _warn {
my ( $self, $msg ) = @_;
my $alias = $self->{alias};
warn "[$alias] $msg\n" if $self->{verbose};
$self->{js_log} .= qq| ${alias}_pre_iframe_queue.push(|
. qq|"${PACKAGE}->filter $msg");\n|;
return;
}
sub _switch_function_options {
my ( $self, $msg ) = @_;
my $alias = $self->{alias};
$self->{js_function_names} .= qq|