#################### main pod documentation begin ###################
=head1 NAME
ZymonicMP - Zymonic mod_perl Handler module
=head1 SYNOPSIS
TODO
=head1 DESCRIPTION
TODO
=head1 INSTALLATION
1. When using ZymonicMP it's extremely important to make sure
MaxClients is less than max number of connections allowed by
Apache.
=head1 USAGE
=head1 BUGS
None we're aware of...
=head1 SUPPORT
As in the license, Zymonic is provided without warranty or support
unless purchased separately, however... If you email
zymonic-support@zednax.com your issue will be noted and may
receive a response.
For security issues, please contact zymonic-security@zednax.com and
someone will respond within 8 working hours.
=head1 AUTHOR
Alex Masidlover et al.
CPAN ID: MODAUTHOR
Zednax Limited
alex.masidlover@zednax.com
http://www.zednax.com
=head1 COPYRIGHT
This program is free software licensed under the...
Zymonic Public License 1.0
The full text of the license can be found in the
LICENSE file included with this module.
Other licenses may be acceptable if including
parts of Zymonic in larger projects, please
contact Zednax for details.
=head1 SEE ALSO
perl(1).
=cut
#################### main pod documentation end ###################
package Zymonic::Debugs;
use strict;
use warnings;
use XML::LibXML;
use File::Basename;
use JSON;
use URI::Encode qw(uri_encode uri_decode);
use URI::Escape qw(uri_unescape);
use LWP::UserAgent::Cached;
use Data::Dumper;
use Encode;
use HTML::Seamstress;
use POSIX::strptime;
use POSIX qw(strftime);
use Zymonic::DB::SQLite;
use Zymonic::Utils qw(clean death_handler rethrow_exception random_string init_debugs);
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::Connection ();
use Apache2::Response ();
use Apache2::Cookie;
use Apache2::Const;
use CGI::Apache2::Wrapper;
use CGI::Apache2::Wrapper::Cookie;
use Apache2::Const -compile => qw(OK :http);
BEGIN
{
use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = '0.01';
@ISA = qw(Exporter);
#Give a hoot don't pollute, do not export more than needed by default
@EXPORT = qw(die);
@EXPORT_OK = qw();
%EXPORT_TAGS = ();
# Try and catch global die
# http://perl.apache.org/docs/general/perl_reference/perl_reference.html#Alternative_Exception_Handling_Techniques
sub die (@);
sub import
{
my $pkg = shift;
$pkg->export( 'CORE::GLOBAL', 'die' );
Exporter::import( $pkg, @_ );
}
sub die (@) { death_handler( $_[0] ); }
}
our $json;
our %module_paths;
our $fake_id = 0;
my $DEBUG_FILE = '/tmp/zymonicdebugs_debug.log';
my $DEBUG_FH;
my $DEBUG_METADATA_DB = 'zymonicdebugs_metadata.sqlite';
#################### subroutine header begin ####################
=head2 inner_handler
Usage : ZymonicMP::inner_handler
Purpose : Is a mod_perl response handler for Zymonic. The
'inner' version does the work and can be wrapped in an eval
for exception handling purposes.
Returns : a suitable response for mod_perl.
Argument : a mod_perl reference
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub inner_handler : method
{
my ( $self, $r ) = @_;
%Zymonic::ENV = %ENV;
# something within the decryptor clears down the ENV which causes error on loading CGI::Apache2::Wrapper
# see SR 11222 for more details on this
# for now explicitly set the variables
$r->subprocess_env;
$Zymonic::ENV{MOD_PERL} = 2;
$Zymonic::ENV{MOD_PERL_API_VERSION} = 2;
# Clean path
$ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/sbin:/bin:/usr/bin:/sbin:/usr/sbin";
$self->{cgi} = CGI::Apache2::Wrapper->new($r);
$self->{dir_config} = $r->dir_config();
my $content = '';
$self->{param_errors} = [];
$self->{debug} = ( ( $self->clean_param('debug') || '' ) eq 'true' ? 'true' : '' );
# params to control functionality
my $basefile = $self->clean_param( 'file', '-_', 255 ) || '';
my $module = $self->clean_param( 'module', '_:', 1024 ) || '';
$self->{rev}->{zymonic} = $self->clean_param( 'zymonic_rev', '', 10, 'Numeric' ) || '';
$self->{rev}->{zcps} = $self->clean_param( 'zcps_rev', '', 10, 'Numeric' ) || '';
my $branch = $self->clean_param( 'branch', '-', 10, 'Alphabetic' ) || '';
if ( $branch eq 'trunk' )
{
$self->{svn_path_base} = "/trunk/";
$self->{branch} = 'trunk';
}
elsif ( $branch eq 'qa' )
{
$self->{svn_path_base} = "/branches/qa/";
$self->{branch} = 'qa';
}
elsif ( $branch eq 'live' )
{
$self->{svn_path_base} = "/branches/live/";
$self->{branch} = 'live';
}
elsif ( $branch eq 'mgt-live' )
{
$self->{svn_path_base} = "/branches/mgt-live/";
$self->{branch} = 'mgt-live';
}
elsif ($branch)
{
$branch = undef;
push(
@{ $self->{param_errors} },
{
param => 'branch',
error => "Unknown branch: $branch"
}
);
}
# call correct handler to get the response
# assume html, the function itself will change type as needed
$self->{type} = 'text/html';
if ($module)
{
$content = $self->get_blame($module);
}
elsif ($basefile)
{
if ( ( $self->clean_param('search') || '' ) eq 'true' )
{
$content = $self->debug_search_response($basefile);
}
elsif ( ( $self->clean_param('get_performance_details') || '' ) eq 'true' )
{
$content = $self->debug_performance_details_response($basefile);
}
else
{
$content = $self->debug_response($basefile);
}
}
else
{
if ( ( $self->clean_param('search') || '' ) eq 'true' )
{
$content = $self->files_search_response();
}
else
{
$content = $self->files_response();
}
}
$r->print(
$self->{cgi}->header(
{
'Content-Type' => ( $self->{type} ),
}
)
);
$r->print($content);
return Apache2::Const::OK;
}
#################### subroutine header begin ####################
=head2 handler
Usage : ZymonicMP::handler
Purpose : Is a mod_perl response handler for Zymonic.
Returns : a suitable response for mod_perl.
Argument : a mod_perl reference
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub handler : method
{
my ( $class, $r ) = @_;
# apache children will all share the same random seed
# which means rand calls will repeat across children
# See: http://blogs.perl.org/users/brian_phillips/2010/06/when-rand-isnt-random.html
# we workaround this my seeding the random generator
srand();
my $resp = {};
my $error;
my $self = {};
bless $self, $class;
eval {
local $SIG{__DIE__} = sub { death_handler( $_[0] ); };
$resp = $self->inner_handler($r);
1;
}
or do
{
if ( ref($@) and ref($@) =~ /Zymonic::Exception::Session::URI_ERROR/ )
{
$resp = Apache2::Const::NOT_FOUND;
}
else
{
$error = Zymonic::Utils::death_handler( $@, 'from mod_perl', 'return_error' );
$r->custom_response( Apache2::Const::SERVER_ERROR, $error->{message}->{content} );
$resp = Apache2::Const::SERVER_ERROR;
}
};
return $resp;
}
#################### subroutine header begin ####################
=head2 new
Usage : Zymonic::Debugs->new
Purpose : Simple Constructor method for Debugs.
Returns : a Zymonic::Debugs object.
Argument : class options.
Throws : nothing
Comment : Only needed when being pulled in by Toolkit
See Also :
=cut
#################### subroutine header end ####################
sub new : method
{
my $class = shift;
my $self = {@_};
bless $self, $class;
return $self;
}
#################### subroutine header begin ####################
=head2 get_blame
Usage : $self->get_blame()
Purpose : Handles the get blame
Returns : APACHE STATUS
Argument : module (scalar), line (scalar)
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub get_blame
{
my $self = shift;
my $module = shift;
$self->{websvn_base} = $self->{dir_config}->get('websvn');
my $module_details = $self->module_location($module);
my $url =
$self->{websvn_base}
. "/wsvn/"
. $module_details->{repname} . '/'
. uri_encode( $self->{svn_path_base} . $module_details->{path} )
. '?op=blame&rev='
. $self->{rev}->{ $module_details->{repname} };
my $user_agent = LWP::UserAgent::Cached->new( cache_dir => $self->{dir_config}->get('cache_dir') );
my $response = $user_agent->get($url);
unless ( $response->is_success && $response->code eq '200' )
{
return $response->decoded_content() || 'Response Error: ' . $response->code;
}
my $html = $response->decoded_content;
$html =~ s/href="\//href="$self->{websvn_base}\//mg;
$html =~ s/src="\//src="$self->{websvn_base}\//mg;
$html =~ s/href="(.*)\.php/href="$self->{websvn_base}$1.php/mg;
return $html;
}
#################### subroutine header begin ####################
=head2 debug_response
Usage : $self->debug_response()
Purpose : Handles the debug response
Returns : APACHE STATUS
Argument : base file
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub debug_response
{
my $self = shift;
my $basefile = shift;
my $basefile_full_path = ( $self->{dir_config}->get('debugs_dir') || '/tmp/' ) . '/' . $basefile if $basefile;
unless ( $basefile_full_path && -f $basefile_full_path )
{
# quickly return an error if file not found, doesn't need anything fancy
return "
Unable to find debug file: $basefile
";
}
my $content = '';
# important to load metadata before the main db file so it can
# be opnd as editable if necessary
my $metadata = $self->get_debug_metadata($basefile);
$self->{debugs_db} = $self->sqlite($basefile_full_path);
$json = JSON->new->allow_nonref;
# if id present find that node and pass it through for output
my $id = $self->clean_param( 'key', 'F_', 20, 'Numeric' ) || '';
if ($id)
{
$self->{type} = "application/json";
$content = encode_json( $self->nodes_out($id) );
}
else
{
# use template
return $self->output_template(
'debug_file.html',
{
%{$metadata},
file => $basefile,
branch => $self->{branch},
zymonic_rev => $self->{rev}->{zymonic},
zcps_rev => $self->{rev}->{zcps},
nodes => encode_json( $self->nodes_out() ),
param_errors => $self->{param_errors},
}
);
}
return $content;
}
#################### subroutine header begin ####################
=head2 nodes_out
Usage : $self->nodes_out($node)
Purpose : Node output for dynatree
Returns : arrayref of nodes to be converts to JSON
Argument : optional id of the node to output
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub nodes_out
{
my $self = shift;
my $id_in = shift;
my $nodes = [];
if ($id_in)
{
$self->debug("Getting nodes for: $id_in");
my $key_node_rec = $self->{debugs_db}->run_query(
{
string =>
"SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line FROM nodes LEFT JOIN fn_ends USING(id) WHERE id = ? ORDER BY id",
params => [$id_in]
}
);
return [] unless ref($key_node_rec) and scalar( @{$key_node_rec} ) > 0;
$nodes = $self->{debugs_db}->run_query(
{
string =>
'SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line FROM nodes LEFT JOIN fn_ends USING(id) WHERE parent_id = ? and depth = ?',
params => [ $key_node_rec->[0]->{id}, $key_node_rec->[0]->{depth} + 1 ],
}
);
}
else
{
# can get weird cases where depth starts from a non-zero value
# that issue is somewhere in the writing of the debugs, to be sorted there
# but here we just grab the smallest depth to start from so can still use the debugs
my $min_depth = $self->{debugs_db}->run_query(
{
string => 'SELECT MIN(depth) AS min_depth FROM nodes',
params => [],
}
);
# when debug function mismatches occur, depth can go negative
# ensure we don't start from a negative depth
if ( $min_depth->[0]->{min_depth} < 0 )
{
$min_depth->[0]->{min_depth} = 0;
}
# all top level
$self->debug("Getting all nodes for min depth $min_depth->[0]->{min_depth}");
$nodes = $self->{debugs_db}->run_query(
{
string =>
'SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line FROM nodes LEFT JOIN fn_ends USING(id) WHERE depth = ?',
params => [ $min_depth->[0]->{min_depth} ],
}
);
$self->debug( "Nodes found: " . ( scalar @{$nodes} ) );
}
return [ map { $self->node_format($_) } @{$nodes} ];
}
#################### subroutine header begin ####################
=head2 node_format
Usage : $self->nodes_out($node)
Purpose : Switching function for different types of element
in debug file.
Returns : a JSON string for dynatree
Argument : a LibXML Node object
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub node_format
{
my $self = shift;
my $node = shift;
if ( $node->{nodeName} eq 'debug' )
{
return $self->format_debug($node)
}
elsif ( $node->{nodeName} eq 'function' )
{
return $self->format_function($node)
}
else
{
return ();
}
}
#################### subroutine header begin ####################
=head2 format_debugs
Usage : $self->format_debug($node)
Purpose : debug output for dynatree
Returns : a hashref to be converted to JSON
Argument : a LibXML Node object
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub format_debug
{
my $self = shift;
my $node = shift;
# trim content to first line for showing in the GUI
my $text = $node->{content};
$text =~ s/^\s+//g;
$text =~ s/\s+$//g;
my @lines = split( /\n/, $text );
$text = $lines[0] . ' ... ' if scalar(@lines) > 1;
$text =~ s/"/\\"/g;
my $details = {
title => $text,
tooltip => $node->{time},
time => $node->{time},
fulltext => $node->{content},
key => $node->{id},
callers => $self->callers( $node->{caller_string} ),
( $node->{matched} ? ( matched => 'true' ) : () ),
};
return $details;
}
#################### subroutine header begin ####################
=head2 format_function
Usage : $self->format_function($node)
Purpose : function output for dynatree
Returns : a hashref to be converted to JSON
Argument : a LibXML Node object
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub format_function
{
my $self = shift;
my $node = shift;
my $module = $node->{function};
$module =~ s/::[^:]*$//;
my $details = {
title => $node->{function} . ' - ' . $node->{zname} . ' - ' . ( $node->{elapsed} || '' ) . 'ms',
tooltip => $node->{time},
time => $node->{time},
fulltext => $node->{function} . ' - ' . $node->{zname},
exit_line => $self->callers( $module . '{' . $node->{exit_line} . '}' )->[0],
isFolder => 'true',
isLazy => 'true',
key => $node->{id},
callers => $self->callers( $node->{caller_string} ),
( $node->{matched} ? ( matched => 'true' ) : () ),
};
return $details;
}
#################### subroutine header begin ####################
=head2 callers
Usage : $self->callers($caller_string)
Purpose : returns a hashref of callers and URLs
Returns : a hashref to be convered to be JSON
Argument : a debug caller string.
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub callers
{
my $self = shift;
my $caller_string = shift || '';
my @callers = ();
foreach my $line ( split( /\s/, $caller_string ) )
{
# move this into own method that caches
my ( $module, $line_no ) = ( $line =~ /(.*)\{(.*)\}/ );
my $url = '/zymonicdebugs?'
. join(
"&",
(
"branch=$self->{branch}", "zymonic_rev=$self->{rev}->{zymonic}",
"zcps_rev=$self->{rev}->{zcps}", "module=$module"
)
);
push(
@callers,
{
module => $module,
line => $line_no,
URL => $url,
}
);
}
return \@callers;
}
#################### subroutine header begin ####################
=head2 module_location
Usage : $self->module_location($module_perl_name)
Purpose : returns a repository location
Returns : as per purpose
Argument : perl module name
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub module_location
{
my $self = shift;
my $module = shift;
$module =~ s/::/\//g;
unless ( $module_paths{$module} )
{
$self->{zymonic_wc} = $self->{dir_config}->get('zymonic_wc') unless $self->{zymonic_wc};
$self->{zcps_wc} = $self->{dir_config}->get('zcps_wc') unless $self->{zcps_wc};
my $core_exp = "^" . $self->{zymonic_wc} . ".*" . $module . ".pm";
my $zcps_exp = "^" . $self->{zcps_wc} . ".*" . $module . ".pm";
my $core_file = `locate -r "$core_exp" | grep -v blib`;
chomp($core_file);
my $repname = '';
my $file_path = '';
if ($core_file)
{
# set repo location
$core_file =~ s/$self->{zymonic_wc}//;
$module_paths{$module}->{path} = $core_file;
$module_paths{$module}->{repname} = 'zymonic';
}
else
{
my $zcps_file = `locate -r "$zcps_exp" | grep -v blib`;
# set repo location
$zcps_file =~ s/$self->{zcps_wc}//;
chomp($zcps_file);
$module_paths{$module}->{path} = $zcps_file;
$module_paths{$module}->{repname} = 'zcps';
}
}
return $module_paths{$module};
}
#################### subroutine header begin ####################
=head2 convert_xml_to_sqlite
Usage : $self->convert_xml_to_sqlite($debugfile,
$zymonic_version,
$system,
$config_version,
$sqlitefile)
Purpose : Converts and XML debug file to an XML database for
better performance when handling large volumes of debugs.
Returns : nothing
Argument : a debug filename, zymonic verison number,
system, config verision
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub convert_xml_to_sqlite
{
my $self = shift;
my $debugfile = shift;
my $file_name = shift || 'ZZDEBUG_' . time() . '_' . random_string( 10, ( 'a' .. 'z' ) );
my $metadata = shift || {};
my $debugs_dir = shift || $self->{dir_config}->get('debugs_dir') || '/tmp';
# zymonic xml debugs are not valid debugs by default, so need to wrap a root element
my $xmlfile = $debugfile . '.tmp.xml';
unless ( -f $xmlfile )
{
`echo "" > $xmlfile`;
`cat $debugfile >> $xmlfile`;
`echo "" >> $xmlfile`;
}
# Open the XML file
my $fh;
open $fh, '<', $xmlfile;
binmode $fh;
my $doc = XML::LibXML->load_xml( IO => $fh, no_blanks => 1 );
my $root = $doc->documentElement();
# put into debug dir
my $sqlitefile_with_path = $debugs_dir . '/' . $file_name . '.sqlite';
my $db = $self->sqlite($sqlitefile_with_path);
# Add the metatadata
my $parsed_metadata = $self->parse_metadata_from_xml_debugs( $debugfile, $metadata );
use Scalar::Util qw(tainted);
open my $tainted_fh, '>>', '/tmp/debugger_debug_tainted_data.log';
map { print $tainted_fh "> $_: " . $parsed_metadata->{$_} . "\n\n"; }
grep { tainted $parsed_metadata->{$_} }
keys %{$parsed_metadata};
close $tainted_fh;
$db->run_statement(
{
string => 'INSERT INTO metadata ('
. join( ',', keys %{$parsed_metadata} )
. ') VALUES('
. join( ',', map { '?' } keys %{$parsed_metadata} ) . ')',
params => [ values %{$parsed_metadata} ],
}
);
# Work through the nodes adding each one to the DB (will need
# to be partially recursive to handle function methods.)
my $count = $self->add_node_to_db( $db, $root );
# close the db to release all locks
$db->close_db_connection();
# clean up
undef $doc;
close $fh;
unlink $xmlfile;
return { count => $count, sqlite_file => $sqlitefile_with_path };
}
#################### subroutine header begin ####################
=head2 parse_metadata_from_xml_debugs
Usage : $self->parse_metadata_from_xml_debugs($debugfile, $metadata)
Purpose : Attempts to fill in any missing metadata by searching
the debug file
Returns : updated metadata
Argument : xml debug file path, hashref of existing metadata
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub parse_metadata_from_xml_debugs
{
my $self = shift;
my $debugfile = shift;
my $metadata = shift || {};
# see if we can extract metadata details from the debugs if not incoming
unless ( $metadata->{branch} || $metadata->{zymonicversion} || $metadata->{zcpsversion} )
{
# look for version being set in either transition history, filter history or api logging
my $version =
`grep "Field zz_th_version other value set to" $debugfile`
|| `grep "Field zz_fh_version other value set to" $debugfile`
|| `grep "Field zz_api_log_version other value set to" $debugfile`;
if ( $version && $version =~ /Z([DQLU]?)(\d+)\/C([DQLU]?)(\d+)/ )
{
my %branch_lookup = ( D => 'trunk', Q => 'qa', L => 'live', U => '' );
$metadata->{branch} = ( $1 ? $branch_lookup{$1} : ( $3 ? $branch_lookup{$3} : '' ) ) || '';
$metadata->{zymonicversion} = $2;
$metadata->{zcpsversion} = $4;
}
}
# same for system, no debug info of host
unless ( $metadata->{system} )
{
# grab system from debug
my $system = `grep "Zymonic starting... system:" $debugfile`;
if ( $system && $system =~ /Zymonic starting... system: (.*)?/ )
{
$metadata->{system} = $1;
}
}
unless ( $metadata->{system} )
{
$metadata->{host} = 'unknown';
}
# grab a timestamp from first line of debugs
unless ( $metadata->{time} )
{
my $time = `head -20 $debugfile | grep " time=" | head -1`;
if ( $time && $time =~ /time=["'](\d\d)-(\d\d)-(\d\d\d\d) (\d\d:\d\d:\d\d)["']/ )
{
# pull out the parts so we can assemble in the correct format
$metadata->{time} = $3 . '-' . $2 . '-' . $1 . ' ' . $4;
}
}
# see if can find type, zname and displayname
unless ( $metadata->{type} || $metadata->{zname} || $metadata->{displayname} )
{
# check for webservicemode loaded for type
my $webservicemode = `grep "Loaded Zymonic::WebService::" $debugfile | head -1`;
if ( $webservicemode && $webservicemode =~ /Loaded Zymonic::WebService::(.*)/ )
{
$metadata->{type} = $1;
}
# check for first filter/process loaded as a good guess of the main object
my $filter_or_process = `grep "Loaded Zymonic::Process" $debugfile | head -1`
|| `grep "Loaded Zymonic::Filter" $debugfile | head -1`;
if ( $filter_or_process && $filter_or_process =~ /Loaded Zymonic::(.*)(?:::.*)? \((.*)\)/ )
{
$metadata->{type} = lc($1) unless $metadata->{type};
$metadata->{zname} = $2;
$metadata->{displayname} = ''; # no obvious debug with the object display name
}
# page load is an expection, check for that explicitly
my $current_page = `grep "CURRENT PAGE" $debugfile | head -1`;
if ( $current_page && $current_page =~ /"CURRENT PAGE: (\d+) - (.*)'/ )
{
$metadata->{type} = 'page';
$metadata->{displayname} = $2;
$metadata->{zname} = ''; # no obvious debug with the page zname
}
}
return $metadata;
}
#################### subroutine header begin ####################
=head2 add_node_to_db
Usage : $self->add_node_to_sqlite($db, $node)
Purpose : Adds the node (and any children) to the SQLite DB
Returns : nothing
Argument : sqlitefile, XML::LibXML node
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub add_node_to_db
{
my $self = shift;
my $db = shift;
my $node = shift;
my $depth = shift || 0;
my $parent_id = shift || '';
my $count = 1;
my $nodename = $node->nodeName();
my $id = $node->getAttribute('id');
$id = "F" . ( $fake_id += 1 ) unless ($id);
my $recurse = 0;
my $rec = {
nodeName => $nodename,
id => $id,
caller_string => $node->getAttribute('caller_string') || '',
zname => $node->getAttribute('zname') || '',
function => $node->getAttribute('function') || '',
depth => $depth,
( $parent_id ? ( parent_id => $parent_id ) : () ),
};
if ( $rec->{nodeName} eq 'function' )
{
my $timing_node = ( $node->findnodes('timing') )[0];
my $exit_line_node = ( $node->findnodes('exit_line') )[0];
$rec->{elapsed} = $timing_node->getAttribute('elapsed') if $timing_node;
$rec->{exit_line} = $exit_line_node->textContent() if $exit_line_node;
# add the node to the DB
$db->run_statement(
{
string => 'INSERT INTO fn_ends (id, elapsed, exit_line) VALUES (?, ?, ?)',
params => [ $rec->{id}, $rec->{elapsed}, $rec->{exit_line} ],
}
);
delete $rec->{elapsed};
delete $rec->{exit_line};
$recurse = 1;
}
elsif ( $rec->{nodeName} eq 'debug' )
{
$rec->{content} = $node->textContent();
}
elsif ( $rec->{nodeName} eq 'ZymonicDebug' )
{
$recurse = 1;
# ignore the fake root, and decrement the depth so it starts at 0
$rec = undef;
$depth -= 1;
}
use Scalar::Util qw(tainted);
open my $fh, '>>', '/tmp/debugger_debug_tainted_data.log';
map { print $fh "> $_: " . $rec->{$_} . "\n\n"; }
grep { tainted $rec->{$_} }
keys %{$rec};
close $fh;
# add the node to the DB
$db->run_statement(
{
string => 'INSERT INTO nodes ('
. join( ",", keys( %{$rec} ) )
. ') VALUES ('
. join( ",", map { '?' } keys( %{$rec} ) ) . ')',
params => [ map { $rec->{$_} } keys( %{$rec} ) ]
}
) if $rec;
# Try and minimise memory usage...
$rec = undef;
if ($recurse)
{
# recurse
foreach my $child ( $node->findnodes('*') )
{
$count += $self->add_node_to_db( $db, $child, $depth + 1, $id );
}
}
return $count;
}
#################### subroutine header begin ####################
=head2 sqlite
Usage : $self->sqlite($sqlitefile)
Purpose : Returns an Zymonic::DB::SQLite object for the
requested file.
Returns : see purpose
Argument : sqlitefile
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub sqlite
{
my $self = shift;
my $sqlitefile = shift;
my $editable = shift || '';
# if non-editable version is open, open again to switch to editable one
if ( !ref( $self->{sqlite_handles}->{$sqlitefile} )
|| ( $editable && !$self->{sqlite_handles}->{$sqlitefile}->{editable} ) )
{
# create a new sqlite handle
$self->{sqlite_handles}->{$sqlitefile} =
Zymonic::DB::SQLite::create_new_db( $sqlitefile, ( $editable ? '' : 'readonly' ) );
$self->{sqlite_handles}->{$sqlitefile}->{editable} = $editable;
$self->debug("Opening debug file ($editable): $sqlitefile");
}
return $self->{sqlite_handles}->{$sqlitefile};
}
#################### subroutine header begin ####################
=head2 get_debug_metadata
Usage : $self->get_debug_metadata($basefile)
Purpose : Fetches metadata for a debug file
Returns : hashref of metadata
Argument : debugfile
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub get_debug_metadata
{
my $self = shift;
my $debug_file = shift;
if ( !ref( $self->{debug_metadata}->{$debug_file} ) )
{
my $basefile_full_path = ( $self->{dir_config}->get('debugs_dir') || '/tmp/' ) . '/' . $debug_file;
my $metadata_db = $self->debug_metadata_db();
# if flag is set then remove any metadata for this file so it is recalculated
if ( ( $self->clean_param('refresh_debug_metadata') || '' ) eq 'true' )
{
$self->debug("Refreshing by deleting debug metadata from debug db");
$metadata_db->run_statement( { string => 'DELETE FROM metadata WHERE file = ?', params => [$debug_file] } );
}
my $metadata_db_metadata =
$metadata_db->run_query( { string => 'SELECT * FROM metadata WHERE file = ?', params => [$debug_file] } );
if ( $metadata_db_metadata && $metadata_db_metadata->[0] )
{
$self->debug("Got debug metadata from cache db");
$self->{debug_metadata}->{$debug_file} = $metadata_db_metadata->[0];
}
else
{
$self->debug("Getting debug metadata from debug db");
eval {
local $SIG{__DIE__} = sub { death_handler( $_[0] ); };
# editable as we set some extra metadat later on
my $debug_db = $self->sqlite( $basefile_full_path, 'editable' );
my $metadata = $debug_db->run_query( { string => 'SELECT * FROM metadata', params => [] } );
$self->{debug_metadata}->{$debug_file} = $metadata->[0] || {};
# also pull out the debugger command for convenience
my $debugger_command = $debug_db->run_query(
{
string => 'SELECT content FROM nodes WHERE content LIKE ?',
params => ["PERL DEBUGGER COMMAND: %"]
}
);
if ( $debugger_command && $debugger_command->[0] )
{
$self->{debug_metadata}->{$debug_file}->{debugger_command} = $debugger_command->[0]->{content};
$self->{debug_metadata}->{$debug_file}->{debugger_command} =~ s/^PERL DEBUGGER COMMAND: //;
}
use Scalar::Util qw(tainted);
open my $fh, '>>', '/tmp/debugger_debug_tainted_data.log';
map { print $fh "> $_: " . $self->{debug_metadata}->{$debug_file}->{$_} . "\n\n"; }
grep { tainted $self->{debug_metadata}->{$debug_file}->{$_} }
keys %{ $self->{debug_metadata}->{$debug_file} };
close $fh;
# add to cache db
$metadata_db->run_statement(
{
string => 'INSERT INTO metadata (file, '
. join( ',', keys %{ $self->{debug_metadata}->{$debug_file} } )
. ') VALUES(?,'
. join( ',', map { '?' } keys %{ $self->{debug_metadata}->{$debug_file} } ) . ')',
params => [ $debug_file, values %{ $self->{debug_metadata}->{$debug_file} } ],
}
) if keys %{ $self->{debug_metadata}->{$debug_file} };
# finally, process all timings to calculated more accurate times by removing time from parents
$self->calculate_local_elapsed_times($debug_db);
1;
} or do
{
$self->{debug_metadata}->{$debug_file} = { error => "$@" };
};
}
# convert time to a timestamp for convenience
if ( $self->{debug_metadata}->{$debug_file}->{time} )
{
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday ) =
POSIX::strptime( $self->{debug_metadata}->{$debug_file}->{time}, "%Y-%m-%d %H:%M:%S" );
$self->{debug_metadata}->{$debug_file}->{timestamp} =
strftime( "%s", $sec, $min, $hour, $mday, $mon, $year );
}
# add file details
$self->{debug_metadata}->{$debug_file}->{file_last_modified_timestamp} = ( stat($basefile_full_path) )[9];
my @time = POSIX::strptime( $self->{debug_metadata}->{$debug_file}->{file_last_modified_timestamp}, "%s" );
$self->{debug_metadata}->{$debug_file}->{file_last_modified} = strftime( "%Y-%m-%d %H:%M:%S", @time );
$self->{debug_metadata}->{$debug_file}->{file_size} =
sprintf( "%.2f", ( stat($basefile_full_path) )[7] / ( 1024 * 1024 ) ); # convert to MB
}
return $self->{debug_metadata}->{$debug_file};
}
#################### subroutine header begin ####################
=head2 calculate_local_elapsed_times
Usage : $self->calculate_local_elapsed_times()
Purpose : Updates data to calculate real elapsed times of function
Returns : nothing
Argument : debug db
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub calculate_local_elapsed_times
{
my $self = shift;
my $debug_db = shift;
# DISABLED FOR NOW, IS SLOW AND CHANGES AREN'T RETAINED IN TH DB FILE
return;
# add column as won't exist for older debugs, in eval so we don't stop if it alraedy exists
eval {
$debug_db->run_statement(
{
string => 'ALTER TABLE fn_ends ADD COLUMN local_elapsed DOUBLE',
params => [],
}
);
};
# set all local_elapsed times to th current elapsed time ready for calculations
$self->debug("Reset all local_elapsed times");
$debug_db->run_statement(
{
string => 'UPDATE fn_ends SET local_elapsed = elapsed',
params => [],
}
);
# need to start from the most nested functions and loop up, deducting childs
# real elapsed time from the parent, this should then give real time elapsed
# within the parent outside of the child
my $depth = $debug_db->run_query(
{
string => 'SELECT MAX(depth) max_depth FROM nodes',
params => [],
}
)->[0]->{max_depth};
while ( $depth > 0 )
{
$self->debug("Calculating local elapsed times for depth: $depth");
# sqlite doesn't have updates with joins, so create a temp table to update from
$debug_db->run_statement(
{
string => 'CREATE TEMP TABLE local_elapsed_changes AS '
. 'SELECT p.id AS fn_id, pe.local_elapsed - ce.local_elapsed AS new_local_elapsed '
. 'FROM nodes c JOIN fn_ends ce ON c.id = ce.id '
. 'JOIN nodes p ON c.parent_id = p.id JOIN fn_ends pe ON p.id = pe.id '
. 'WHERE c.depth = ?',
params => [$depth],
}
);
my $count = $debug_db->run_query(
{
string => 'SELECT COUNT(*) count FROM local_elapsed_changes',
params => [],
}
)->[0]->{count};
$self->debug("Updating local elapsed times for $count records");
$debug_db->run_statement(
{
string => 'UPDATE fn_ends '
. 'SET local_elapsed = ( SELECT new_local_elapsed FROM local_elapsed_changes WHERE fn_id = id )',
params => [],
}
);
$debug_db->run_statement(
{
string => 'DROP TABLE local_elapsed_changes',
params => [],
}
);
--$depth;
}
$self->debug("All local_elapsed times calculated");
}
#################### subroutine header begin ####################
=head2 files_response
Usage : $self->files_response()
Purpose : Handles response to show available debug files
Returns : response
Argument : nothing
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub files_response
{
my $self = shift;
# check for a limit
my $file_limit = $self->clean_param( 'file_limit', '', 11, 'Numeric' ) || 100;
# get all debug files in dir, pulling out metadata
my $debug_dir = $self->{dir_config}->get('debugs_dir') || '/tmp/';
my @debug_files = ();
my @errors = ();
my $files_command = "ls -t1 $debug_dir/*.sqlite | head -$file_limit";
$self->debug("Checking for files using: $files_command");
foreach my $debug_file ( split( /\n/, `$files_command` ) )
{
$debug_file = clean( $debug_file, '\\/.-_', 4096 );
my ( $name, $path, $suffix ) = fileparse($debug_file);
next if $name eq $DEBUG_METADATA_DB;
$self->debug("Processing file: $debug_file");
eval {
local $SIG{__DIE__} = sub { death_handler( $_[0] ); };
my $metadata = $self->get_debug_metadata($name);
if ( $metadata->{error} )
{
push(
@errors,
{
file => $name,
error => $metadata->{error},
}
);
}
else
{
push(
@debug_files,
{
%{$metadata},
file => $name,
file_link => "zymonicdebugs?file=$name&branch=$metadata->{branch}"
. "&zymonic_rev=$metadata->{zymonicversion}&zcps_rev=$metadata->{zcpsversion}",
}
);
}
1;
} or do
{
# skip any invalid files for now
$self->debug("Error processing file: $debug_file\n$@");
push(
@errors,
{
file => $name,
error => "$@",
}
);
};
}
# load up html template
return $self->output_template(
'debug_files_list.html',
{
errors => \@errors,
debug_files => [ sort { ( $b->{timestamp} || 0 ) <=> ( $a->{timestamp} || 0 ) } @debug_files ],
param_errors => $self->{param_errors},
file_limit => $file_limit,
}
);
}
#################### subroutine header begin ####################
=head2 files_search_response
Usage : $self->files_search_response()
Purpose : Handles response to search across debug files
Returns : response
Argument : nothing
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub files_search_response
{
my $self = shift;
$self->{type} = "application/json";
$json = JSON->new->allow_nonref;
# if nothing to search return nothing
my $search = $self->clean_param( 'search_value', '', 99999, 'AllPrintableAscii' ) || '';
unless ($search)
{
return encode_json(
{
results => [],
param_errors => $self->{param_errors}
}
);
}
# check for a limit
my $search_limit = $self->clean_param( 'search_limit', '', 11, 'Numeric' ) || 20;
# do a really basic grep on the debugs dir
my $debug_dir = $self->{dir_config}->get('debugs_dir') || '/tmp/';
my $grep_command = "ls -t $debug_dir/*.sqlite | head -$search_limit | xargs grep -l '$search'";
$self->debug("Grep command for searching files: $grep_command");
# run the grep and parse out just the file name
my @matched_files = map { my ( $name, $path, $suffix ) = fileparse($_); $name; } split( /\n/, `$grep_command` );
return encode_json(
{
results => \@matched_files,
param_errors => $self->{param_errors}
}
);
}
#################### subroutine header begin ####################
=head2 debug_search_response
Usage : $self->debug_search_response($basefile)
Purpose : Handles response to return search results
Returns : response
Argument : base file
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub debug_search_response
{
my $self = shift;
my $basefile = shift;
$self->{type} = "application/json";
$json = JSON->new->allow_nonref;
# if nothing to search return nothing
my $search = $self->clean_param( 'search_value', '', 99999, 'AllPrintableAscii' ) || '';
unless ($search)
{
return encode_json(
{
results => [],
param_errors => $self->{param_errors}
}
);
}
my $basefile_full_path = ( $self->{dir_config}->get('debugs_dir') || '/tmp/' ) . '/' . $basefile if $basefile;
my $debugs_db = $self->sqlite($basefile_full_path);
# check for a limit
my $search_limit = $self->clean_param( 'search_limit', '', 11, 'Numeric' ) || '';
# get all nodes where content matches
my $nodes = [];
if ( ( $self->clean_param('search_as_regex') || '' ) eq 'true' )
{
$self->debug("Searching nodes as regex for: $search");
$nodes = $debugs_db->run_query(
{
string => 'SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line, "true" AS matched FROM nodes '
. 'LEFT JOIN fn_ends USING(id) '
. 'WHERE content REGEXP ? OR zname REGEXP ? OR function REGEXP ? OR nodes.id REGEXP ? '
# add search for the format that functions take in the GUI (|| is string concat in sqlite)
. 'OR ( function || " - " || zname ) REGEXP ? '
. 'ORDER BY CAST( SUBSTR( id, INSTR( id, "_" ) + 1 ) AS INTEGER )'
. ( $search_limit ? ' LIMIT ?' : '' ),
params => [ $search, $search, $search, $search, $search, $search_limit || () ],
}
);
}
else
{
$self->debug("Searching nodes for: $search");
$nodes = $debugs_db->run_query(
{
string => 'SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line, "true" AS matched FROM nodes '
. 'LEFT JOIN fn_ends USING(id) '
. 'WHERE content LIKE ? OR zname LIKE ? OR function LIKE ? OR nodes.id LIKE ? '
# add search for the format that functions take in the GUI (|| is string concat in sqlite)
. 'OR ( function || " - " || zname ) LIKE ? '
. 'ORDER BY CAST( SUBSTR( id, INSTR( id, "_" ) + 1 ) AS INTEGER )'
. ( $search_limit ? ' LIMIT ?' : '' ),
params => [
'%' . $search . '%',
'%' . $search . '%',
'%' . $search . '%',
'%' . $search . '%',
'%' . $search . '%',
$search_limit || ()
],
}
);
}
# assemble all root nodes to return, for expansions
my @root_nodes = $self->get_node_expansions( $debugs_db, $nodes );
return encode_json(
{
results => \@root_nodes,
param_errors => $self->{param_errors}
}
);
}
#################### subroutine header begin ####################
=head2 get_node_expansions
Usage : $self->get_node_expansions($nodes)
Purpose : For a given list of nodes (debug contents), assemsble
the list of parents needed to expand to each in the GUI
Returns : list of root nodes to start expanding from
Argument : list of nodes
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub get_node_expansions
{
my $self = shift;
my $debugs_db = shift;
my $nodes = shift || [];
my %all_nodes_needed = ();
my %root_nodes = ();
foreach my $node ( @{$nodes} )
{
$self->debug( "Found node: " . Dumper($node) );
# add it as a needed node
$all_nodes_needed{ $node->{id} } = $node;
# get all parent nodes to depth 0
my $node_to_check = $node;
while ( $node_to_check->{parent_id} )
{
my $parent_nodes = $debugs_db->run_query(
{
string => 'SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line '
. 'FROM nodes LEFT JOIN fn_ends USING(id) WHERE id = ?',
params => [ $node_to_check->{parent_id} ],
}
);
if ( $parent_nodes->[0] )
{
# add parent node to list and connect its children
my $parent_node = $parent_nodes->[0];
if ( $all_nodes_needed{ $parent_node->{id} } )
{
$parent_node = $all_nodes_needed{ $parent_node->{id} };
}
else
{
$all_nodes_needed{ $parent_node->{id} } = $parent_node;
}
$parent_node->{children_seen} = {} unless $parent_node->{children_seen};
unless ( $parent_node->{children_seen}->{ $node_to_check->{id} } )
{
$parent_node->{children_to_expand} = [] unless $parent_node->{children_to_expand};
push( @{ $parent_node->{children_to_expand} }, $node_to_check );
$parent_node->{children_seen}->{ $node_to_check->{id} } = 1;
}
# keep checking
$node_to_check = $parent_node;
}
else
{
last;
}
}
# this will be the root node
$root_nodes{ $node_to_check->{id} } = $node_to_check;
}
# return the root nodes
return values %root_nodes;
}
#################### subroutine header begin ####################
=head2 debug_performance_details_response
Usage : $self->debug_performance_details_response($basefile)
Purpose : Handles response to show performance details
Returns : response
Argument : base file
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub debug_performance_details_response
{
my $self = shift;
my $basefile = shift;
$self->{type} = "application/json";
$json = JSON->new->allow_nonref;
my $basefile_full_path = ( $self->{dir_config}->get('debugs_dir') || '/tmp/' ) . '/' . $basefile if $basefile;
my $debugs_db = $self->sqlite($basefile_full_path);
# check for a limit
my $limit = $self->clean_param( 'limit', '', 11, 'Numeric' ) || 20;
# check for the type
my $type = $self->clean_param( 'performance_breakdown_type', ) || '';
unless ($type)
{
return encode_json(
{
results => [],
param_errors => $self->{param_errors}
}
);
}
my $nodes = [];
my %unique_nodes = ();
my @headers = ();
$self->debug("Fetching performance details, limit $limit");
if ( $type eq 'functions' || $type eq 'functions_local_time' )
{
# calculate a total time for the request
my $total_time = $debugs_db->run_query(
{
string => 'SELECT STRFTIME("%s",MAX(time))-STRFTIME("%s",MIN(time)) total_time FROM nodes',
params => [],
}
)->[0]->{total_time} * 1000;
# switch which field we use to track tim
my $elapsed_field = 'elapsed';
if ( $type eq 'functions_local_time' )
{
$elapsed_field = 'local_elapsed';
}
# count and sum of all functions per zname
$nodes = $debugs_db->run_query(
{
string => "SELECT function, zname, COUNT(*) count, SUM($elapsed_field) total_time, "
. "ROUND(SUM($elapsed_field)/?,4)*100 total_time_percent, AVG($elapsed_field) average_time, MIN($elapsed_field) min_time, MAX($elapsed_field) max_time, GROUP_CONCAT(id) keys "
. "FROM nodes LEFT JOIN fn_ends USING(id) WHERE $elapsed_field IS NOT NULL "
. "GROUP BY function, zname ORDER BY SUM($elapsed_field) DESC LIMIT ?",
params => [ $total_time, $limit ],
}
);
@headers = (
{ key => 'function', header => 'Function' },
{ key => 'zname', header => 'ZName' },
{ key => 'count', header => 'Count' },
{ key => 'total_time', header => 'Total Time (ms)' },
{ key => 'total_time_percent', header => 'Percentage of Request Time (%)' },
{ key => 'average_time', header => 'Average Time (ms)' },
# TODO: need to link to min and max keys
{ key => 'min_time', header => 'Min Time (ms)' },
{ key => 'max_time', header => 'Max Time (ms)' },
{ key => 'keys', header => 'Links to debugs (if currently expanded)', id_list => 'true' }
);
# grab all the ids from the results into unique list so can force expansion to them in the gui
# this is so user can focus and specific one of the results found above
%unique_nodes = map { $_ => 1 } map { split( ',', ( $_->{keys} || '' ) ) } @{$nodes};
}
elsif ( $type eq 'objects' || $type eq 'objects_no_zname' )
{
my $object_type = 'content';
my $from_cache = 'IIF( INSTR(content, "from cache") = 0, "N", "Y" )';
if ( $type eq 'objects_no_zname' )
{
# if no zname the strip the zname part out of the content
$object_type = 'IIF( INSTR(content, "(") = 0, content, SUBSTR( content, 1, INSTR(content, "(")-2 ) )';
}
# count of all objects loaded
$nodes = $debugs_db->run_query(
{
string =>
"SELECT $object_type AS object, $from_cache AS cached, COUNT(*) count, GROUP_CONCAT(id) keys "
. 'FROM nodes WHERE content LIKE "Loaded Zymonic::%" '
. "GROUP BY $object_type, $from_cache ORDER BY COUNT(*) DESC LIMIT ?",
params => [$limit],
}
);
@headers = (
{ key => 'object', header => 'Object Loaded' },
{ key => 'cached', header => 'From Cache' },
{ key => 'count', header => 'Count' },
{ key => 'keys', header => 'Links to debugs (if currently expanded)', id_list => 'true' }
);
# grab all the ids from the results into unique list so can force expansion to them in the gui
# this is so user can focus and specific one of the results found above
%unique_nodes = map { $_ => 1 } map { split( ',', ( $_->{keys} || '' ) ) } @{$nodes};
}
elsif ( $type eq 'sql' )
{
# full sql queries by time taken
# sql for this is complex as sqlite has no regex functions to parse out the time from the sql query
# full sql format is: FULL SQL QUERY:[tab]QUERY[tab]TIME[tab]ms
# tab char in sqlite is CAST(X'09' AS TEXT)
# have to do a nasty nested substr/instr to identify tab locations and extract the query and timetime
# here's a fuller query which was useful when building the actual query:
#
# SELECT content,INSTR( content, CAST(X'09' AS TEXT) ) tab_pos_1,
# SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) query,
# INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) ) tab_pos_2,
# SUBSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) , INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) )+1 ) time,
# INSTR( SUBSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) , INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) ) tab_pos_3,
# SUBSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) , INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) )+1, INSTR( SUBSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) , INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) ) ) time_only,
# id FROM nodes WHERE content LIKE "FULL SQL QUERY:%" ORDER BY SUBSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) , INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) )+1, INSTR( SUBSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ) , INSTR( SUBSTR( content, INSTR( content, CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) )+1 ), CAST(X'09' AS TEXT) ) ) DESC LIMIT 20;
# splitting the query into vars to hopefully make it more readable
my $tab = "CAST(X'09' AS TEXT)";
my $tab_1 = "INSTR( content, $tab )";
my $after_tab_1 = "SUBSTR( content, $tab_1 + 1 )"; # query onwards
my $tab_2 = "INSTR( $after_tab_1, $tab )";
my $after_tab_2 = "SUBSTR( $after_tab_1, $tab_2 + 1 )"; # time onwards
my $tab_3 = "INSTR( $after_tab_2, $tab )";
# can now extract the data between the tab positions
my $query = "SUBSTR( $after_tab_1, 1, $tab_2 - 1 )";
my $time = "CAST( SUBSTR( $after_tab_1, $tab_2 + 1, $tab_3 - 1 ) AS INT )";
# then query looks simple
$nodes = $debugs_db->run_query(
{
string => "SELECT $query || ';' query, $time time, id "
. 'FROM nodes WHERE content LIKE "FULL SQL QUERY:%" '
. "ORDER BY $time DESC LIMIT ?",
params => [$limit],
}
);
@headers = (
{ key => 'query', header => 'Full Query (click to copy to clipboard)', allow_copy => 'true' },
{ key => 'time', header => 'Time Taken (ms)' },
{ key => 'id', header => 'Link to debugs (if currently expanded)', id_list => 'true' }
);
# grab all the ids from the results into unique list so can force expansion to them in the gui
# this is so user can focus and specific one of the results found above
%unique_nodes = map { $_->{id} => 1 } @{$nodes};
}
else
{
push(
@{ $self->{param_errors} },
{
param => 'performance_breakdown_type',
error => "Unknown performance type: $type"
}
);
}
# get all the nodes to expand
my $nodes_to_expand = [];
$nodes_to_expand = $debugs_db->run_query(
{
string => 'SELECT nodes.*, fn_ends.elapsed, fn_ends.exit_line, "true" AS matched FROM nodes '
. 'LEFT JOIN fn_ends USING(id) '
. 'WHERE id IN ('
. join( ',', map { '?' } keys %unique_nodes )
. ') ORDER BY id',
params => [ keys %unique_nodes ],
}
) if keys %unique_nodes;
my @root_nodes = $self->get_node_expansions( $debugs_db, $nodes_to_expand );
return encode_json(
{
headers => \@headers,
results => $nodes,
results_to_expand => \@root_nodes,
param_errors => $self->{param_errors}
}
);
}
#################### subroutine header begin ####################
=head2 debug
Usage : $self->debug($messages)
Purpose : Debugs out a message to log
Returns : nothing
Argument : message to debug
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub debug
{
my $self = shift;
my $message = shift;
return unless $self->{debug};
# always debug to same file
unless ( $DEBUG_FH && $DEBUG_FH->opened() )
{
open $DEBUG_FH, '>>', $DEBUG_FILE or rethrow_exception("Unable to open debug file: $!");
$DEBUG_FH->autoflush(1);
}
print $DEBUG_FH strftime( "[%d-%m-%Y %H:%M:%S] ", localtime ) . $message . "\n";
}
#################### subroutine header begin ####################
=head2 output_template
Usage : $self->output_template($file, $data)
Purpose : Generates output via templates
Returns : html to output
Argument : template file name, data to populate
Throws : nothing
Comment :
See Also :
=cut
#################### subroutine header end ####################
sub output_template
{
my $self = shift;
my $file = shift;
my $data = shift;
# load up seamstress
$self->debug("Processing template: $file");
my $template_dir = '/var/www/localhost/htdocs/';
my $seamstress = HTML::Seamstress->new_from_file( $template_dir . $file );
# process data to add has_* params to any lists
$self->update_template_data($data);
$self->debug( "Updated template data: " . length( Dumper($data) ) );
$self->populate_template_data( $seamstress->find('body'), $data );
return $seamstress->as_HTML();
}
#################### subroutine header begin ####################
=head2 update_template_data
Usage : $self->update_template_data($data)
Purpose : Adds useful params to incoming data
Returns : hashref of data
Argument : hashref of data
Throws : nothing
Comment : e.g.
* adds has_[list] params where [list] is an arrayref
and has at least one item
See Also :
=cut
#################### subroutine header end ####################
sub update_template_data
{
my $self = shift;
my $data = shift;
foreach my $key ( keys %{$data} )
{
if ( ref( $data->{$key} ) eq 'ARRAY' )
{
# add a has_* param for any list with content
$data->{"has_$key"} = 'true' if @{ $data->{$key} } && !exists $data->{"has_$key"};
# recurse!
map { $self->update_template_data($_) } @{ $data->{$key} };
}
elsif ( ref( $data->{$key} ) eq 'HASH' )
{
# recurse!
map { $self->update_template_data( $data->{$_} ) } keys %{ $data->{$key} };
}
}
}
#################### subroutine header begin ####################
=head2 populate_template_data
Usage : $self->populate_template_data($element, $data)
Purpose : Populates template element with incoming data
Returns : nothing
Argument : current element of the template and data
Throws : nothing
Comment : e.g.
* adds has_[list] params where [list] is an arrayref
and has at least one item
See Also :
=cut
#################### subroutine header end ####################
sub populate_template_data
{
my $self = shift;
my $element = shift;
my $data = shift;
my $children = shift || [ $element->content_list() ];
foreach my $child ( @{$children} )
{
# skip any plain text content
next unless ref($child);
my $ztype = $child->attr('ztype') || '';
my $zdata = $child->attr('zdata') || '';
if ( $ztype eq 'if' )
{
if ( $data->{$zdata} )
{
$self->debug("Template if with condition $zdata passed");
# populate everything within
$self->populate_template_data( $child, $data );
}
else
{
$self->debug("Template if with condition $zdata failed");
# trim it
$child->detach();
}
}
elsif ( $ztype eq 'loop' )
{
if ( ref( $data->{$zdata} ) eq 'ARRAY' )
{
my @new_content = ();
foreach my $data_item ( @{ $data->{$zdata} } )
{
$self->debug( "Template loop building for data: " . Dumper($data_item) );
# clone and remove the looping stuff
my $clone = $child->clone();
$clone->attr( 'ztype', undef );
$clone->attr( 'zdata', undef );
# process as an orphan child
$self->populate_template_data( undef, $data_item, [$clone] );
# add to list to put in place
push( @new_content, $clone );
}
# replace the loop element with all the clones
$child->replace_with(@new_content);
}
else
{
$self->debug("Template loop for $zdata failed, data is not an arrayref");
}
}
elsif ( $ztype eq 'value' )
{
# set the value
$child->replace_content( $data->{$zdata} );
}
else
{
# step into the child to process further
$self->populate_template_data( $child, $data );
}
# check if any attributes need replacing or appending
# format is zattribute_replace="id=name,type=type" and will pull values from data
my @zattribute_replaces = split( ',', $child->attr('zattribute_replace') || '' );
foreach my $zattribute_replace (@zattribute_replaces)
{
my ( $attr, $key ) = split( '=', $zattribute_replace, 2 );
$child->attr( $attr, $data->{$key} );
}
my @zattribute_appends = split( ',', $child->attr('zattribute_append') || '' );
foreach my $zattribute_append (@zattribute_appends)
{
my ( $attr, $key ) = split( '=', $zattribute_append, 2 );
$child->attr( $attr, ( $child->attr($attr) || '' ) . ' ' . $data->{$key} );
}
# clean any template params
$child->attr( 'ztype', undef );
$child->attr( 'zdata', undef );
$child->attr( 'zattribute_replace', undef );
$child->attr( 'zattribute_append', undef );
}
}
#################### subroutine header begin ####################
=head2 clean_param
Usage : my $param = $self->clean_param('param',"\/:!",50); }
Purpose : fetchs and cleans incoming CGI params
Returns : a scalar or array of scalars containing the value of
the CGI parameter(s) desired.
Argument : parameter name (scalar), extra characters (scalar -
escaped for use in a regex), length (scalar - numeric),
clean_base (to use when cleaning), truncate (whether to truncate values
greater than the length)
Throws : nothing
Comment : copied from Zymonic::Session::clean_param/get_params
See Also : Zymonic::Session::clean_param
Zymonic::Session::get_params
Zymonic::Session::get_parameter_contents
=cut
#################### subroutine header end ####################
sub clean_param
{
my $self = shift;
my $parameter_name = shift;
my $extra_chars = shift;
my $max_length = shift;
my $clean_base = shift;
my $truncate_value = shift || '';
# decode and unescape any params
my @contents = ();
my @params =
map { uri_unescape($_) }
map { Encode::is_utf8($_) ? $_ : Encode::decode_utf8($_) } $self->{cgi}->param($parameter_name);
foreach my $param (@params)
{
# clean the value
my $content;
eval {
local $SIG{__DIE__} = sub { death_handler( $_[0] ); };
$content = clean( $param, $extra_chars, $max_length, $parameter_name, $clean_base, $truncate_value );
1;
} or do
{
my $exception = $@;
if ( ref($exception) && $exception->isa('Zymonic::Exception::Utils::Clean::MaxLength') )
{
$content = undef;
push(
@{ $self->{param_errors} },
{
param => $parameter_name,
error => "Too long: $exception->{actual_length} > $exception->{maximum_length}"
}
);
}
elsif ( ref($exception) && $exception->isa('Zymonic::Exception::Utils::Clean::IllegalChars') )
{
$content = undef;
push(
@{ $self->{param_errors} },
{
param => $parameter_name,
error => "Disallowed chars: " . join( ", ", @{ $exception->{character_list} } )
}
);
}
else
{
rethrow_exception($exception);
}
};
if ( defined $content )
{
# remove leading/trailing whitespace
$content =~ s/^\s+//;
$content =~ s/\s+$//;
push( @contents, $content );
}
}
if ( $#contents == -1 ) { return wantarray ? () : undef; }
return wantarray ? @contents : $contents[0];
}
#################### subroutine header begin ####################
=head2 debug_metadata_db
Usage : $self->debug_metadata_db()
Purpose : Returns an Zymonic::DB::SQLite object with all the debug metadata
Returns : see purpose
Argument : nothing
Throws : nothing
Comment : cache db so we don't have to load and query each individual debug file
See Also :
=cut
#################### subroutine header end ####################
sub debug_metadata_db
{
my $self = shift;
return $self->{debug_metadata_db} if $self->{debug_metadata_db};
$self->{debug_metadata_db} = Zymonic::DB::SQLite::create_new_db(
( $self->{dir_config}->get('debugs_dir') || '/tmp/' ) . '/' . $DEBUG_METADATA_DB );
$self->{debug_metadata_db}->run_statement(
{
string => 'CREATE TABLE IF NOT EXISTS metadata ( '
. 'file VARCHAR(1024), '
. 'branch VARCHAR(256), '
. 'zymonicversion INT, '
. 'zcpsversion INT, '
. 'system VARCHAR(256), '
. 'host VARCHAR(256), '
. 'time DATETIME, '
. 'type VARCHAR(256), '
. 'zname VARCHAR(256), '
. 'displayname VARCHAR(256), '
. 'debugger_command MEDIUMTEXT )',
params => [],
}
);
return $self->{debug_metadata_db};
}
1;