PerlGuard-Agent
view release on metacpan or search on metacpan
Revision history for Perl extension PerlGuard::Agent.
0.01 Wed Jul 1 14:59:24 2015
- original version; created by h2xs 1.23 with options
-AX --skip-exporter PerlGuard::Agent -b 5.10.1
0.02 Mon Aug 17 2015
- Add Monitors for DBI and Net::HTTP
- Add output methods to communicate with the server using an alpha collector version
0.03 Mon Aug 17 2015
- Temporary change to HTTP::Async to make sure we process all outbound messages
0.04 Wed 19 Aug 2015
- Had a missing file from Manifest
0.05 Mon 12 Oct 2015
- Mojo apps can now submit profiles on the next tick and free up the client
0.08 Mon 2 Nov 2015
- Add some safety checks so the agent is less likely to break production
0.12 Tue 19 Jan 2016
- CGI::Application apps tend to have a single controller action that accepts get AND post and then
does different things depending on which it is, to help split these up lets append this to the controller action
0.13 Wed 20 Jan 2016
- Drop Moo requirement down to version 1
0.14 Mon 25 Jan 2016
- Silence some warnings
- Attempt to show some useful information for requests that fail routing (404s etc)
Changes
lib/PerlGuard/Agent.pm
lib/PerlGuard/Agent/LexWrap.pm
lib/PerlGuard/Agent/Frameworks.pm
lib/PerlGuard/Agent/Frameworks/Catalyst.pm
lib/PerlGuard/Agent/Frameworks/CGI.pm
lib/PerlGuard/Agent/Frameworks/CGIApplication.pm
lib/PerlGuard/Agent/Frameworks/Mojolicious.pm
lib/PerlGuard/Agent/Frameworks/Script.pm
lib/PerlGuard/Agent/Monitors.pm
lib/PerlGuard/Agent/Monitors/DBI.pm
lib/PerlGuard/Agent/Monitors/DBI/Tracer.pm
lib/PerlGuard/Agent/Monitors/NetHTTP.pm
lib/PerlGuard/Agent/Output.pm
lib/PerlGuard/Agent/Output/PerlGuardServer.pm
lib/PerlGuard/Agent/Output/StandardError.pm
lib/PerlGuard/Agent/Profile.pm
Makefile.PL
MANIFEST
README
t/PerlGuard-Agent.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
{
"abstract" : "Trace your application performance with PerlGuard",
"author" : [
"Jonathan Taylor <jon@stackhaus.com>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001",
"license" : [
"unknown"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "PerlGuard-Agent",
"no_index" : {
"directory" : [
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Data::UUID" : "0",
"HTTP::Async" : "0",
"JSON" : "0",
"Moo" : "1",
"Time::HiRes" : "0"
}
}
},
"release_status" : "stable",
"version" : "0.15"
}
---
abstract: 'Trace your application performance with PerlGuard'
author:
- 'Jonathan Taylor <jon@stackhaus.com>'
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001'
license: unknown
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: PerlGuard-Agent
no_index:
directory:
- t
- inc
requires:
Data::UUID: '0'
HTTP::Async: '0'
JSON: '0'
Moo: '1'
Time::HiRes: '0'
version: '0.15'
Makefile.PL view on Meta::CPAN
use 5.010001;
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
NAME => 'PerlGuard::Agent',
VERSION_FROM => 'lib/PerlGuard/Agent.pm', # finds $VERSION
PREREQ_PM => {
'Moo' => 1,
'JSON' => 0,
'HTTP::Async' => 0,
'Time::HiRes' => 0,
'Data::UUID' => 0
}, # e.g., Module::Name => 1.1
($] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => 'lib/PerlGuard/Agent.pm', # retrieve abstract from module
AUTHOR => 'Jonathan Taylor <jon@stackhaus.com>') : ()),
);
PerlGuard-Agent version 0.03
============================
PerlGuard::Agent - Trace your application performance with PerlGuard
This is the PerlGuard agent which will help you collect and store
metrics also known as application performance monitoring. You will usually use
on of the plugins to integrate assuming you are using a supported framework.
DBI is required for DBI monitoring
Net::HTTP is requires for HTTP monitoring
use PerlGuard::Agent;
my $agent = PerlGuard::Agent->new($config);
my $profile = $agent->create_new_profile();
$profile->start_recording;
$profile->url( $my_url );
$profile->http_method( $my_http_method );
$profile->controller( "My::Controller" );
$profile->controller_action( "index_pages" );
$profile->finish_recording;
# Let variables fall out of scope to perform cleanup
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
make install
COPYRIGHT AND LICENCE
Put the correct copyright and licence information here.
Copyright (C) 2015 by Jonathan Taylor
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.18.1 or,
at your option, any later version of Perl 5 you may have available.
lib/PerlGuard/Agent.pm view on Meta::CPAN
package PerlGuard::Agent;
use 5.010001;
use Moo;
use PerlGuard::Agent::Profile;
use Scalar::Util;
use Data::UUID;
our @ISA = qw();
our $VERSION = '0.15';
has output_method => ( is => 'rw', lazy => 1, default => sub { 'PerlGuard::Agent::Output::PerlGuardServer' } );
has output => (is => 'lazy' );
has profiles => ( is => 'rw', default => sub { {} });
has monitors => ( is => 'rw', default => sub { [] });
has async_mode => (is => 'rw', default => sub { 0 });
has api_key => (is => 'rw');
has data_uuid => (is => 'ro', default => sub { Data::UUID->new });
has warnings => (is => 'rw', default => sub { 0 });
our $CURRENT_PROFILE_UUID = undef;
# Current profile only makes sense in a sync app which can only have one request running at a time
# Alternatively it could be used with a local statment elsewhere in an async app to make use of lexical scoping
sub current_profile {
my $self = shift;
warn "current_profile is meaningless when running in async mode" if $self->async_mode();
#Check if $CURRENT_PROFILE has a value in is
if(defined $CURRENT_PROFILE_UUID) {
if($self->profiles->{$CURRENT_PROFILE_UUID}) {
if($self->warnings) {
warn "Profile identified has finished, this should not happen" if $self->profiles->{$CURRENT_PROFILE_UUID}->has_finished();
}
return $self->profiles->{$CURRENT_PROFILE_UUID};
}
else {
if($self->warnings) {
warn "the package variable CURRENT_PROFILE_UUID is not defined, this is potentially a race condition bug";
}
}
}
else {
if($self->warnings) {
warn "Using fallback mechanism to identify profile";
}
# This is not safe, as we could get monitors reporting on the wrong profile
my @uuids = keys %{ $self->profiles };
if(scalar(@uuids) == 1) {
return $self->profiles->{$uuids[0]};
}
else {
if($self->warnings) {
warn "Could not identify the most recent profile, we had " . scalar(@uuids) . " profiles currently active with keys @uuids and the current profile var thinks its " . $CURRENT_PROFILE_UUID ;
}
return;
}
}
}
sub _build_output {
my $self = shift;
my $output_method = $self->output_method();
eval "require $output_method";
die "Cannot require module $output_method, perhaps you specified an invalid module name in output_method" if $@;
my @params;
push(@params, api_key => $self->api_key) if($self->api_key);
return $output_method->new( @params );
}
# This supports a transaction being added for a specific profile, which is a future feature we will need to support async apps
# For now though when this is called there should only ever be one profile in process (sync app)
sub add_database_transaction {
my $self = shift;
my $database_transaction = shift;
my $intended_profile_uuid = shift;
if($intended_profile_uuid and (my $profile = $self->profiles->{$intended_profile_uuid})) {
$profile->add_database_transaction($database_transaction);
} else {
# Profile not specified! Time to guess
my $current_profile = $self->current_profile;
if($current_profile && Scalar::Util::blessed($current_profile)) {
$current_profile->add_database_transaction($database_transaction);
}
else {
if($self->warnings) {
warn "Caught a database transaction occuring outside of a profile";
}
}
}
}
sub add_webservice_transaction {
my $self = shift;
my $web_transaction = shift;
my $intended_profile_uuid = shift;
if($intended_profile_uuid and (my $profile = $self->profiles->{$intended_profile_uuid})) {
$profile->add_webservice_transaction($web_transaction);
} else {
# Profile not specified
my $current_profile = $self->current_profile;
if($current_profile && Scalar::Util::blessed($current_profile)) {
$current_profile->add_webservice_transaction($web_transaction);;
}
else {
if($self->warnings) {
warn "Caught a web transaction occuring outside of a profile"
}
}
}
}
sub create_new_profile {
my $self = shift;
my $profile = PerlGuard::Agent::Profile->new({
# Set some things
uuid => $self->data_uuid->create_str(),
agent => $self
});
$self->profiles->{$profile->uuid} = $profile;
Scalar::Util::weaken($self->profiles->{$profile->uuid});
return $profile;
}
sub remove_profile {
my $self = shift;
my $profile_id = shift;
$profile_id = $profile_id->uuid() if Scalar::Util::blessed($profile_id);
delete $self->profiles->{$profile_id};
}
sub detect_monitors {
my $self = shift;
foreach my $monitor(qw( PerlGuard::Agent::Monitors::DBI PerlGuard::Agent::Monitors::NetHTTP )) {
eval {
eval "require $monitor; 1" or die "skipping loading monitor $monitor";
my $monitor = $monitor->new(agent => $self);
$monitor->die_unless_suitable();
push(@{$self->monitors}, $monitor);
1;
} or do {
warn "Error when loading monitor $monitor: " . $@;
next;
}
}
}
sub start_monitors {
my $self = shift;
foreach my $monitor(@{$self->monitors}) { $monitor->start_monitoring() }
}
sub stop_monitors {
my $self = shift;
foreach my $monitor(@{$self->monitors}) { $monitor->stop_monitoring() }
}
1;
__END__
=head1 NAME
PerlGuard::Agent - Trace your application performance with PerlGuard
=head1 SYNOPSIS
use PerlGuard::Agent;
my $agent = PerlGuard::Agent->new($config);
my $profile = $agent->create_new_profile();
$profile->start_recording;
$profile->url( $my_url );
$profile->http_method( $my_http_method );
$profile->controller( "My::Controller" );
$profile->controller_action( "index_pages" );
$profile->finish_recording;
# Let variables fall out of scope to perform cleanup
=head1 DESCRIPTION
This is the PerlGuard agent which will help you collect and store
metrics also known as application performance monitoring. You will usually use
on of the plugins to integrate assuming you are using a supported framework.
DBI is required for DBI monitoring
Net::HTTP is requires for HTTP monitoring
=head1 AUTHOR
Jonathan Taylor, E<lt>jon@stackhaus.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2015 by Stackhaus LTD
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.18.1 or,
at your option, any later version of Perl 5 you may have available.
=cut
lib/PerlGuard/Agent/Frameworks.pm view on Meta::CPAN
# A subclass of this will be the entry point, which takes all config parameters, handles creation and deletion of Profile objects
package PerlGuard::Agent::Frameworks;
use 5.010001;
use Moo;
has agent => ( is=>'lazy' );
1;
lib/PerlGuard/Agent/Frameworks/CGIApplication.pm view on Meta::CPAN
package PerlGuard::Agent::Frameworks::CGIApplication;
use base 'Exporter';
use PerlGuard::Agent;
BEGIN {
$PerlGuard::Agent::Frameworks::CGIApplication::VERSION = '1.00';
}
@EXPORT = qw(
perlguard_config
perlguard_agent
);
# register a callback to the standard CGI::Application hooks
# one of 'init', 'prerun', 'postrun', 'teardown' or 'load_tmpl'
sub perlguard_config {
my $self = shift;
my $config = shift;
$self->{'PerlGuard::Agent::Frameworks::CGIApplication::perlguard_config'} = $config;
}
sub perlguard_agent {
my $self = shift;
if (not defined($self->{'PerlGuard::Agent::Frameworks::CGIApplication::perlguard_agent'})) {
my $agent = PerlGuard::Agent->new( $self->{'PerlGuard::Agent::Frameworks::CGIApplication::perlguard_config'} );
$agent->detect_monitors();
$agent->start_monitors();
#warn "Creating fresh perlguard agent";
$self->{'PerlGuard::Agent::Frameworks::CGIApplication::perlguard_agent'} = $agent;
}
return $self->{'PerlGuard::Agent::Frameworks::CGIApplication::perlguard_agent'};
}
sub import {
my $c = scalar(caller);
$c->add_callback('init', sub {
});
$c->add_callback('prerun', sub {
my $controller_instance = shift;
#warn "Creating new profile";
$controller_instance->{'PerlGuard::Profile'} = &perlguard_agent($controller_instance)->create_new_profile();
$controller_instance->{'PerlGuard::Profile'}->start_recording();
$PerlGuard::Agent::CURRENT_PROFILE_UUID = $controller_instance->{'PerlGuard::Profile'}->uuid();
});
$c->add_callback('postrun', sub {
my $controller_instance = shift;
my $profile = $controller_instance->{'PerlGuard::Profile'};
# my $handle;
# open ($handle,'>>','/tmp/cgiapp') or die("Cant open /tmp/cgiapp");
# print $handle "\n\n\n==============\n\n\n";
# use Data::Dumper;
# print $handle Dumper $controller_instance->query;
# print $handle "\n" . $controller_instance->query->self_url;
# print $handle "\n" . $controller_instance->query->request_method;
# print $handle "\n" . ref($controller_instance);
# print $handle "\n" . $controller_instance->get_current_runmode;
$profile->url( $controller_instance->query->self_url );
$profile->http_method( $controller_instance->query->request_method );
$profile->controller( ref($controller_instance) );
#For paul lets update the controller action to include the HTTP method
$profile->controller_action( $controller_instance->get_current_runmode . "_" . uc($controller_instance->query->request_method) );
if( my $cross_application_tracing_id = $controller_instance->query->http("X-PerlGuard-Auto-Track") ) {
$profile->cross_application_tracing_id($cross_application_tracing_id);
}
$profile->finish_recording();
$controller_instance->{'PerlGuard::Profile'} = undef;
$profile->save;
});
$c->add_callback('teardown', sub {
});
goto &Exporter::import
}
lib/PerlGuard/Agent/Frameworks/Mojolicious.pm view on Meta::CPAN
package PerlGuard::Agent::Frameworks::Mojolicious;
#use Moo;
use PerlGuard::Agent;
use Mojo::Base 'Mojolicious::Plugin';
use Mojo::IOLoop;
BEGIN {
$PerlGuard::Agent::Frameworks::Mojolicious::VERSION = '1.00';
}
sub register {
my ($self, $app, $args) = @_;
$args ||= {};
my $agent = PerlGuard::Agent->new($args);
$app->helper(perlguard_agent => sub {
return $agent;
});
$app->hook(after_build_tx => sub {
my $tx = shift;
unless($tx->{'PerlGuard::Profile'}) {
my $profile = $agent->create_new_profile();
$tx->{'PerlGuard::Profile'} //= $profile;
$profile->start_recording;
}
else {
warn "I think I already have a profile on this TX even though its just been built" if $ENV{'PERLGUARD_AGENT_DEBUG'}
}
});
$app->hook(after_dispatch => sub {
my $c = shift;
return if ($c->stash->{'mojo.static'});
my $profile = $c->tx->{'PerlGuard::Profile'};
$profile->finish_recording();
$profile->http_code( $c->tx->res->code );
$c->tx->{'PerlGuard::Profile'} = undef;
#This does not do what I think it does
if(Mojo::IOLoop->is_running()) {
Mojo::IOLoop->timer(1 => sub {
my $loop = shift;
$profile->save;
});
}
else {
$profile->save;
}
});
$app->hook(before_routes => sub {
my $c = shift;
my $stash = $c->stash;
unless ($stash->{'mojo.static'}) {
unless($c->tx->{'PerlGuard::Profile'}) {
warn "In before_routes we didn't have a profile on the transaction already so we had to make it";
my $profile = $agent->create_new_profile();
$c->tx->{'PerlGuard::Profile'} //= $profile;
$profile->start_recording;
}
else {
$c->tx->{'PerlGuard::Profile'}->http_code( $c->tx->res->code );
$c->tx->{'PerlGuard::Profile'}->url( $c->tx->req->url );
#$c->stash('PerlGuard::Profile', $c->tx->{'PerlGuard::Profile'});
}
}
});
$app->hook(around_dispatch => sub {
my ($next, $c) = @_;
#$c->stash->{'PerlGuard::Profile'} = $c->tx->{'PerlGuard::Profile'};
do {
if($c->tx->{'PerlGuard::Profile'}) {
local $PerlGuard::Agent::CURRENT_PROFILE_UUID = $c->tx->{'PerlGuard::Profile'}->uuid() unless $c->stash->{'mojo.static'};
$next->();
}
else {
warn "Perlguard profile was not defined at this point";
$next->();
}
};
});
$app->hook(around_action => sub {
my ($next, $c, $action, $last) = @_;
unless($c->stash->{'mojo.static'}) {
my $profile = $c->tx->{'PerlGuard::Profile'};
unless($profile) {
#warn "PerlGuard profile was not defined when we expected it to be";
}
else {
$profile->controller( ref($c) );
$profile->controller_action( $c->stash->{action} );
$profile->http_code( $c->tx->res->code );
if( $c->req ) {
$profile->url( $c->req->url );
$profile->http_method( $c->req->method );
if( my $cross_application_tracing_id = $c->req->headers->header("X-PerlGuard-Auto-Track") ) {
$profile->cross_application_tracing_id($cross_application_tracing_id);
}
}
do {
local $PerlGuard::Agent::CURRENT_PROFILE_UUID = $c->tx->{'PerlGuard::Profile'}->uuid() unless $c->stash->{'mojo.static'} ;
return $next->();
};
}
}
$next->();
});
$app->helper(perlguard_profile => sub {
my $c = shift;
return $c->tx->{'PerlGuard::Profile'};
});
$agent->detect_monitors();
$agent->start_monitors();
}
1;
lib/PerlGuard/Agent/LexWrap.pm view on Meta::CPAN
use strict;
use warnings;
package PerlGuard::Agent::LexWrap;
# ABSTRACT: Lexically scoped subroutine wrappers
our $VERSION = '0.26';
use Carp ();
{
no warnings 'redefine';
*CORE::GLOBAL::caller = sub (;$) {
my ($height) = ($_[0]||0);
my $i=1;
my $name_cache;
while (1) {
my @caller = CORE::caller($i++) or return;
$caller[3] = $name_cache if $name_cache;
$name_cache = $caller[0] eq 'PerlGuard::Agent::LexWrap' ? $caller[3] : '';
next if $name_cache || $height-- != 0;
return wantarray ? @_ ? @caller : @caller[0..2] : $caller[0];
}
};
}
sub import { no strict 'refs'; *{caller()."::wrap"} = \&wrap }
sub wrap (*@) { ## no critic Prototypes
my ($typeglob, %wrapper) = @_;
$typeglob = (ref $typeglob || $typeglob =~ /::/)
? $typeglob
: caller()."::$typeglob";
my $original;
{
no strict 'refs';
$original = ref $typeglob eq 'CODE' && $typeglob
|| *$typeglob{CODE}
|| Carp::croak "Can't wrap non-existent subroutine ", $typeglob;
}
Carp::croak "'$_' value is not a subroutine reference"
foreach grep {$wrapper{$_} && ref $wrapper{$_} ne 'CODE'}
qw(pre post);
no warnings 'redefine';
my ($caller, $unwrap) = *CORE::GLOBAL::caller{CODE};
my $imposter = sub {
if ($unwrap) { goto &$original }
my ($return, $prereturn);
if (wantarray) {
$prereturn = $return = [];
() = $wrapper{pre}->(\@_,$return) if $wrapper{pre};
if (ref $return eq 'ARRAY' && $return == $prereturn && !@$return) {
$return = [ &$original ];
() = $wrapper{post}->(@_, $return)
if $wrapper{post};
}
return ref $return eq 'ARRAY' ? @$return : ($return);
}
elsif (defined wantarray) {
$return = bless sub {$prereturn=1}, 'PerlGuard::Agent::LexWrap::Cleanup';
my $dummy = $wrapper{pre}->(\@_, $return) if $wrapper{pre};
unless ($prereturn) {
$return = &$original;
$dummy = scalar $wrapper{post}->(@_, $return)
if $wrapper{post};
}
return $return;
}
else {
$return = bless sub {$prereturn=1}, 'PerlGuard::Agent::LexWrap::Cleanup';
$wrapper{pre}->(\@_, $return) if $wrapper{pre};
unless ($prereturn) {
&$original;
$wrapper{post}->(@_, $return)
if $wrapper{post};
}
return;
}
};
ref $typeglob eq 'CODE' and return defined wantarray
? $imposter
: Carp::carp "Uselessly wrapped subroutine reference in void context";
{
no strict 'refs';
*{$typeglob} = $imposter;
}
return unless defined wantarray;
return bless sub{ $unwrap=1 }, 'PerlGuard::Agent::LexWrap::Cleanup';
}
package PerlGuard::Agent::LexWrap::Cleanup;
sub DESTROY { $_[0]->() }
use overload
q{""} => sub { undef },
q{0+} => sub { undef },
q{bool} => sub { undef },
q{fallback}=>1; #fallback=1 - like no overloading for other operations
1;
__END__
=head1 SYNOPSIS
use PerlGuard::Agent::LexWrap;
sub doit { print "[doit:", caller, "]"; return {my=>"data"} }
SCOPED: {
wrap doit =>
pre => sub { print "[pre1: @_]\n" },
post => sub { print "[post1:@_]\n"; $_[1]=9; };
my $temporarily = wrap doit =>
post => sub { print "[post2:@_]\n" },
pre => sub { print "[pre2: @_]\n "};
@args = (1,2,3);
doit(@args); # pre2->pre1->doit->post1->post2
}
@args = (4,5,6);
doit(@args); # pre1->doit->post1
=head1 DESCRIPTION
READ FIRST
This is a modified verison of Hook::LexWrap which has been modified
to suit our purposes. The namespace change is purely to avoid conflicting
with the original package and does not indicate any level of ownership.
PerlGuard::Agent::LexWrap allows you to install a pre- or post-wrapper (or both)
around an existing subroutine. Unlike other modules that provide this
capacity (e.g. Hook::PreAndPost and Hook::WrapSub), PerlGuard::Agent::LexWrap
implements wrappers in such a way that the standard C<caller> function
works correctly within the wrapped subroutine.
To install a prewrappers, you write:
use PerlGuard::Agent::LexWrap;
wrap 'subroutine_name', pre => \&some_other_sub;
#or: wrap *subroutine_name, pre => \&some_other_sub;
The first argument to C<wrap> is a string containing the name of the
subroutine to be wrapped (or the typeglob containing it, or a
reference to it). The subroutine name may be qualified, and the
subroutine must already be defined. The second argument indicates the
type of wrapper being applied and must be either C<'pre'> or
C<'post'>. The third argument must be a reference to a subroutine that
implements the wrapper.
To install a post-wrapper, you write:
wrap 'subroutine_name', post => \&yet_another_sub;
#or: wrap *subroutine_name, post => \&yet_another_sub;
To install both at once:
wrap 'subroutine_name',
pre => \&some_other_sub,
post => \&yet_another_sub;
or:
wrap *subroutine_name,
post => \&yet_another_sub, # order in which wrappers are
pre => \&some_other_sub; # specified doesn't matter
Once they are installed, the pre- and post-wrappers will be called before
and after the subroutine itself, and will be passed the same argument list.
The pre- and post-wrappers and the original subroutine also all see the same
(correct!) values from C<caller> and C<wantarray>.
=head2 Short-circuiting and long-circuiting return values
The pre- and post-wrappers both receive an extra argument in their @_
arrays. That extra argument is appended to the original argument list
(i.e. is can always be accessed as $_[-1]) and acts as a place-holder for
the original subroutine's return value.
In a pre-wrapper, $_[-1] is -- for obvious reasons -- C<undef>. However,
$_[-1] may be assigned to in a pre-wrapper, in which case PerlGuard::Agent::LexWrap
assumes that the original subroutine has been "pre-empted", and that
neither it, nor the corresponding post-wrapper, nor any wrappers that
were applied I<before> the pre-empting pre-wrapper was installed, need
be run. Note that any post-wrappers that were installed after the
pre-empting pre-wrapper was installed I<will> still be called before the
original subroutine call returns.
In a post-wrapper, $_[-1] contains the return value produced by the
wrapped subroutine. In a scalar return context, this value is the scalar
return value. In an list return context, this value is a reference to
the array of return values. $_[-1] may be assigned to in a post-wrapper,
and this changes the return value accordingly.
Access to the arguments and return value is useful for implementing
techniques such as memoization:
my %cache;
wrap fibonacci =>
pre => sub { $_[-1] = $cache{$_[0]} if $cache{$_[0]} },
post => sub { $cache{$_[0]} = $_[-1] };
or for converting arguments and return values in a consistent manner:
# set_temp expects and returns degrees Fahrenheit,
# but we want to use Celsius
wrap set_temp =>
pre => sub { splice @_, 0, 1, $_[0] * 1.8 + 32 },
post => sub { $_[-1] = ($_[0] - 32) / 1.8 };
=head2 Lexically scoped wrappers
Normally, any wrappers installed by C<wrap> remain attached to the
subroutine until it is undefined. However, it is possible to make
specific wrappers lexically bound, so that they operate only until
the end of the scope in which they're created (or until some other
specific point in the code).
If C<wrap> is called in a I<non-void> context:
my $lexical = wrap 'sub_name', pre => \&wrapper;
it returns a special object corresponding to the particular wrapper being
placed around the original subroutine. When that object is destroyed
-- when its container variable goes out of scope, or when its
reference count otherwise falls to zero (e.g. C<undef $lexical>), or
when it is explicitly destroyed (C<$lexical-E<gt>DESTROY>) --
the corresponding wrapper is removed from around
the original subroutine. Note, however, that all other wrappers around the
subroutine are preserved.
=head2 Anonymous wrappers
If the subroutine to be wrapped is passed as a reference (rather than by name
or by typeglob), C<wrap> does not install the wrappers around the
original subroutine. Instead it generates a new subroutine which acts
as if it were the original with those wrappers around it.
It then returns a reference to that new subroutine. Only calls to the original
through that wrapped reference invoke the wrappers. Direct by-name calls to
the original, or calls through another reference, do not.
If the original is subsequently wrapped by name, the anonymously wrapped
subroutine reference does not see those wrappers. In other words,
wrappers installed via a subroutine reference are completely independent
of those installed via the subroutine's name (or typeglob).
For example:
sub original { print "ray" }
# Wrap anonymously...
my $anon_wrapped = wrap \&original, pre => sub { print "do..." };
# Show effects...
original(); # prints "ray"
$anon_wrapped->(); # prints "do..ray"
# Wrap nonymously...
wrap *original,
pre => sub { print "fa.." },
post => sub { print "..mi" };
# Show effects...
original(); # now prints "fa..ray..mi"
$anon_wrapped->(); # still prints "do...ray"
=head1 DIAGNOSTICS
=over
=item C<Can't wrap non-existent subroutine %s>
An attempt was made to wrap a subroutine that was not defined at the
point of wrapping.
=item C<'pre' value is not a subroutine reference>
The value passed to C<wrap> after the C<'pre'> flag was not
a subroutine reference. Typically, someone forgot the C<sub> on
the anonymous subroutine:
wrap 'subname', pre => { your_code_here() };
and Perl interpreted the last argument as a hash constructor.
=item C<'post' value is not a subroutine reference>
The value passed to C<wrap> after the C<'post'> flag was not
a subroutine reference.
=item C<Uselessly wrapped subroutine reference in void context> (warning only)
When the subroutine to be wrapped is passed as a subroutine reference,
C<wrap> does not install the wrapper around the original, but instead
returns a reference to a subroutine which wraps the original
(see L<Anonymous wrappers>).
However, there's no point in doing this if you don't catch the resulting
subroutine reference.
=back
=head1 BLAME
Schwern made me do this (by implying it wasn't possible ;-)
=head1 BUGS
There are undoubtedly serious bugs lurking somewhere in code this funky :-)
Bug reports and other feedback are most welcome.
=head1 SEE ALSO
Sub::Prepend
=cut
lib/PerlGuard/Agent/Monitors.pm view on Meta::CPAN
package PerlGuard::Agent::Monitors;
use Moo;
use PerlGuard::Agent::LexWrap;
use Module::Loaded();
has agent => ( is => 'ro', required => 1, weak_ref => 1);
has overrides => ( is => 'rw', default => sub { [] });
sub is_module_loaded {
my $self = shift;
my $module_name = shift;
Module::Loaded::is_loaded($module_name)
}
sub start_monitoring {
die "Implement in sublass"
}
sub stop_monitoring {
die "Implement in subclass"
}
sub inform_agent_of_event {
}
sub die_unless_suitable {
}
1;
lib/PerlGuard/Agent/Monitors/DBI.pm view on Meta::CPAN
package PerlGuard::Agent::Monitors::DBI;
use Moo;
use DBI;
use PerlGuard::Agent::Monitors::DBI::Tracer;
use Scalar::Util qw(blessed);
extends 'PerlGuard::Agent::Monitors';
has tracer => ( is => 'rw' );
sub start_monitoring {
my $self = shift;
#my $handle;
#open ($handle,'>>','/tmp/dbi') or die("Cant open /tmp/dbi");
#print $handle "\n * \n * \n * \n * \n";
#use Data::Dumper;
my $tracer = PerlGuard::Agent::Monitors::DBI::Tracer->new(
sub {
my %args = @_;
unless(blessed($self->agent)) {
#warn "Agent was not a blessed object in DBI monitor";
#print $handle Dumper \%args;
return;
}
$self->agent->add_database_transaction({
start_time => $args{start},
finish_time => $args{finish},
query => $args{sql},
rows_returned => $args{rows}
});
}
);
$self->tracer($tracer);
}
sub stop_monitoring {
my $self = shift;
$self->tracer(undef);
}
1;
lib/PerlGuard/Agent/Monitors/DBI/Tracer.pm view on Meta::CPAN
package PerlGuard::Agent::Monitors::DBI::Tracer;
use strict;
use warnings;
use 5.008008;
our $VERSION = '0.03';
use DBI;
use Time::HiRes qw(gettimeofday tv_interval);
use Carp;
our $IN_DO;
my $org_execute = \&DBI::st::execute;
my $org_bind_param = \&DBI::st::bind_param;
my $org_db_do = \&DBI::db::do;
my $org_db_selectall_arrayref = \&DBI::db::selectall_arrayref;
my $org_db_selectrow_arrayref = \&DBI::db::selectrow_arrayref;
my $org_db_selectrow_array = \&DBI::db::selectrow_array;
my $pp_mode = $INC{'DBI/PurePerl.pm'} ? 1 : 0;
my $st_execute;
my $st_bind_param;
my $db_do;
my $selectall_arrayref;
my $selectrow_arrayref;
my $selectrow_array;
our $OUTPUT;
sub new {
my $class = shift;
# argument processing
my %args;
if (@_==1) {
if (ref $_[0] eq 'CODE') {
$args{code} = $_[0];
} else {
%args = %{$_[0]};
}
} else {
%args = @_;
}
for (qw(code)) {
unless ($args{$_}) {
croak "Missing mandatory parameter $_ for DBIx::Tracer->new";
}
}
my $logger = $args{code};
# create object
my $self = bless \%args, $class;
# wrap methods
my $st_execute = $class->_st_execute($org_execute, $logger);
$st_bind_param = $class->_st_bind_param($org_bind_param, $logger);
$db_do = $class->_db_do($org_db_do, $logger);
unless ($pp_mode) {
$selectall_arrayref = $class->_select_array($org_db_selectall_arrayref, 0, $logger);
$selectrow_arrayref = $class->_select_array($org_db_selectrow_arrayref, 0, $logger);
$selectrow_array = $class->_select_array($org_db_selectrow_array, 1, $logger);
}
no warnings qw(redefine prototype);
*DBI::st::execute = $st_execute;
*DBI::st::bind_param = $st_bind_param;
*DBI::db::do = $db_do;
unless ($pp_mode) {
*DBI::db::selectall_arrayref = $selectall_arrayref;
*DBI::db::selectrow_arrayref = $selectrow_arrayref;
*DBI::db::selectrow_array = $selectrow_array;
}
return $self;
}
sub DESTROY {
my $self = shift;
no warnings qw(redefine prototype);
*DBI::st::execute = $org_execute;
*DBI::st::bind_param = $org_bind_param;
*DBI::db::do = $org_db_do;
unless ($pp_mode) {
*DBI::db::selectall_arrayref = $org_db_selectall_arrayref;
*DBI::db::selectrow_arrayref = $org_db_selectrow_arrayref;
*DBI::db::selectrow_array = $org_db_selectrow_array;
}
}
# -------------------------------------------------------------------------
# wrapper methods.
sub _st_execute {
my ($class, $org, $logger) = @_;
return sub {
my $sth = shift;
my @params = @_;
my @types;
my $dbh = $sth->{Database};
my $ret = $sth->{Statement};
if (my $attrs = $sth->{private_DBIx_Tracer_attrs}) {
my $bind_params = $sth->{private_DBIx_Tracer_params};
for my $i (1..@$attrs) {
push @types, $attrs->[$i - 1]{TYPE};
push @params, $bind_params->[$i - 1] if $bind_params;
}
}
$sth->{private_DBIx_Tracer_params} = undef;
my $begin = [gettimeofday];
my $wantarray = wantarray ? 1 : 0;
my $res = $wantarray ? [$org->($sth, @_)] : scalar $org->($sth, @_);
#my $time = tv_interval($begin, [gettimeofday]);
# DBD::SQLite calls ::st::execute from ::do.
# It makes duplicated logging output.
unless ($IN_DO) {
$class->_logging($logger, $dbh, $ret, $begin, [gettimeofday], $sth->rows, \@params);
}
return $wantarray ? @$res : $res;
};
}
sub _st_bind_param {
my ($class, $org) = @_;
return sub {
my ($sth, $p_num, $value, $attr) = @_;
$sth->{private_DBIx_Tracer_params} ||= [];
$sth->{private_DBIx_Tracer_attrs } ||= [];
$attr = +{ TYPE => $attr || 0 } unless ref $attr eq 'HASH';
$sth->{private_DBIx_Tracer_params}[$p_num - 1] = $value;
$sth->{private_DBIx_Tracer_attrs }[$p_num - 1] = $attr;
$org->(@_);
};
}
sub _select_array {
my ($class, $org, $is_selectrow_array, $logger) = @_;
return sub {
my $wantarray = wantarray;
my ($dbh, $stmt, $attr, @bind) = @_;
no warnings qw(redefine prototype);
local *DBI::st::execute = $org_execute; # suppress duplicate logging
my $ret = ref $stmt ? $stmt->{Statement} : $stmt;
my $begin = [gettimeofday];
my $res;
if ($is_selectrow_array) {
$res = $wantarray ? [$org->($dbh, $stmt, $attr, @bind)] : $org->($dbh, $stmt, $attr, @bind);
}
else {
$res = $org->($dbh, $stmt, $attr, @bind);
}
#my $time = tv_interval($begin, [gettimeofday]);
my $rows = $stmt->rows if $stmt->can('rows');
$class->_logging($logger, $dbh, $ret, $begin, [gettimeofday], $rows, \@bind);
if ($is_selectrow_array) {
return $wantarray ? @$res : $res;
}
return $res;
};
}
sub _db_do {
my ($class, $org, $logger) = @_;
return sub {
my $wantarray = wantarray ? 1 : 0;
my ($dbh, $stmt, $attr, @bind) = @_;
local $IN_DO = 1;
my $ret = $stmt;
my $begin = [gettimeofday];
my $res = $wantarray ? [$org->($dbh, $stmt, $attr, @bind)] : scalar $org->($dbh, $stmt, $attr, @bind);
$class->_logging($logger, $dbh, $ret, $begin, [gettimeofday], $res, \@bind);
return $wantarray ? @$res : $res;
};
}
sub _logging {
my ($class, $logger, $dbh, $sql, $begin, $end, $rows, $bind_params) = @_;
$bind_params ||= [];
$logger->(
dbh => $dbh,
start => $begin,
finish => $end,
sql => $sql,
rows => $rows,
bind_params => $bind_params,
);
}
1;
__END__
=encoding utf8
=head1 NAME
DBIx::Tracer - Easy tracer for DBI
=head1 SYNOPSIS
use DBIx::Tracer;
my $tracer = DBIx::Tracer->new(
sub {
my %args = @_;
say $args{dbh};
say $args{time};
say $args{sql};
say "Bind: $_" for @{$args{bind_params}};
}
);
=head1 DESCRIPTION
DBIx::Tracer is easy tracer for DBI. You can trace a SQL queries without
modifying configuration in your application.
You can insert snippets using DBIx::Tracer, and profile it.
=head1 GUARD OBJECT
DBIx::Tracer uses Scope::Guard-ish guard object strategy.
C<< DBIx::Tracer->new >> installs method modifiers, and C<< DBIx::Tracer->DESTROY >> uninstall method modifiers.
You must keep the instance of DBIx::Trace in the context.
=head1 METHODS
=over 4
=item DBIx::Tracer->new(CodeRef: $code)
my $tracer = DBIx::Tracer->new(
sub { ... }
);
Create instance of DBIx::Tracer. Constructor takes callback function, will call on after each queries executed.
You must keep this instance you want to logging. Destructor uninstall method modifiers.
=back
=head1 CALLBACK OPTIONS
DBIx::Tracer passes following parameters to callback function.
=over 4
=item dbh
instance of $dbh.
=item sql
SQL query in string.
=item bind_params : ArrayRef[Str]
binded parameters for the query in arrayref.
=item time
Elapsed times for query in floating seconds.
=back
=head1 FAQ
=over 4
=item Why don't you use Callbacks feature in DBI?
I don't want to modify DBI configuration in my application for tracing.
=back
=head1 AUTHOR
Tokuhiro Matsuno E<lt>tokuhirom AAJKLFJEF@ GMAIL COME<gt>
=head1 THANKS TO
xaicron is author of L<DBIx::QueryLog>. Most part of DBIx::Tracer was taken from DBIx::QueryLog.
=head1 SEE ALSO
L<DBIx::QueryLog>
=head1 LICENSE
Copyright (C) Tokuhiro Matsuno
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
lib/PerlGuard/Agent/Monitors/NetHTTP.pm view on Meta::CPAN
package PerlGuard::Agent::Monitors::NetHTTP;
use Moo;
use Data::Dumper;
use PerlGuard::Agent::LexWrap;
use Time::HiRes;
use Scalar::Util qw(blessed);
extends 'PerlGuard::Agent::Monitors';
has requests_in_progress => ( is => 'rw', default => sub { {} });
sub die_unless_suitable {
eval 'use Net::HTTP::Methods; use LWP::UserAgent; 1' or die "Could not load modules required for NetHTTP monitoring";
}
sub start_monitoring {
my $self = shift;
my $simple_request_wrapper = wrap 'LWP::UserAgent::simple_request', pre => $self->simple_request_wrapper_sub();
my $simple_response_wrapper = wrap 'LWP::UserAgent::simple_request', post => $self->simple_response_wrapper_sub();
push(@{$self->overrides}, $simple_request_wrapper);
push(@{$self->overrides}, $simple_response_wrapper);
}
sub stop_monitoring {
my $self = shift;
foreach my $override(@{$self->overrides}) {
undef $override;
}
}
sub inform_agent_of_event {
my $self = shift;
my $trace = shift;
$self->agent->add_webservice_transaction($trace);
}
sub simple_response_wrapper_sub {
my $self = shift;
return sub {
my $request = $_[1];
my $response = $_[4];
my $request_id = $request->header('X-PerlGuard-Auto-Track');
return unless $request_id;
my $trace = $self->requests_in_progress->{$request_id};
unless($trace) {
#warn "Could not find a transaction trace matching the request\n";
return;
}
$trace->{finish_time} = [Time::HiRes::gettimeofday()];
$trace->{status_code} = $response->code();
$trace->{status_message} = $response->message();
$self->inform_agent_of_event($trace);
delete $self->requests_in_progress->{$request_id};
}
}
# What we want to do is stash a unique value in a header so that we can
# A) Link this up with its response later
# B) Use it as the unique ID for cross application tracing
sub simple_request_wrapper_sub {
my $self = shift;
return sub {
#Determine if we are ok to log
unless($self && $self->agent && $self->agent->current_profile()) {
#warn "Could not associate HTTP request with a profile, perhaps this request happened outside of the request";
return;
}
my $profile = $self->agent->current_profile();
my $request = $_[0]->[1];
my $request_id = $profile->generate_new_cross_application_tracing_id();
$request->header( 'X-PerlGuard-Auto-Track' => $request_id );
my $uri = blessed($request->uri) ? $request->uri->as_string : $request->uri;
$self->requests_in_progress->{$request_id} = {
cross_application_tracing_id => $request_id,
start_time => [Time::HiRes::gettimeofday()],
uri => $uri,
method => $request->method,
};
}
}
1;
lib/PerlGuard/Agent/Output.pm view on Meta::CPAN
package PerlGuard::Agent::Output;
use 5.010001;
use Moo;
sub save { die "Implement in subclass" }
1;
lib/PerlGuard/Agent/Output/PerlGuardServer.pm view on Meta::CPAN
package PerlGuard::Agent::Output::PerlGuardServer;
use Moo;
extends 'PerlGuard::Agent::Output';
use HTTP::Async;
use Encode;
use JSON;
use HTTP::Request;
use HTTP::Headers;
use Time::HiRes;
has api_key => ( is => 'rw', lazy => 1, default => \&_attempt_to_fetch_api_key_from_env_or_die);
has base_url => ( is => 'rw', lazy => 1, default => \&DEFAULT_BASE_URL );
has async_http => ( is => 'rw', lazy => 1, default => sub { HTTP::Async->new(timeout => 2, max_request_time=>2, slots=>1000000); });
has disabled_until => (is => 'rw', lazy => 1, default => sub { [0,0] });
has headers => (is => 'rw', lazy => 1, default => sub {
HTTP::Headers->new(
'X-API-KEY' => shift->api_key,
'content-type' => 'application/json'
)
});
has json_encoder => ( is => 'rw', lazy => 1, default => sub { JSON->new->utf8->convert_blessed->allow_blessed });
sub DEFAULT_BASE_URL {
return 'https://perlguard.com';
}
sub _attempt_to_fetch_api_key_from_env_or_die {
my $self = shift;
return $ENV{PERLGUARD_API_KEY} || die "No api_key specified, can be specified in PerlGuard::Agent->new() or with an ENV var named PERLGUARD_API_KEY";
}
sub save {
my $self = shift;
my $profile = shift;
return unless $profile->should_save();
my $content;
do {
no warnings 'uninitialized'; #Protect our end users from any future errors we might make here
my $controller = $profile->controller || $profile->http_code;
my $action = $profile->controller_action || $profile->url;
$content = {
"start_time" => $profile->start_time,
"finish_time" => $profile->finish_time,
"total_elapsed_time_in_ms" => $profile->total_elapsed_time_in_ms,
"cross_application_tracing_id" => $profile->cross_application_tracing_id,
# "project_id": 10,
"type" => "web",
"grouping_name" => $controller . '#' . $action,
"database_transactions" => $self->format_database_transactions($profile),
"web_transactions" => $self->format_webservice_transactions($profile),
"database_elapsed_time_in_ms" => $profile->database_elapsed_time_in_ms,
"web_elapsed_time_in_ms" => $profile->webservice_elapsed_time_in_ms,
"sum_of_database_transactions" => $profile->database_transaction_count,
"sum_of_web_transactions" => $profile->webservice_transaction_count,
};
$content = $self->json_encoder->encode($content);
};
#warn $content;
$self->check_responses();
unless($self->can_run_yet()) {
warn "Skipping due to previous errors\n";
return;
}
#without_collectors_do {} - We can't really include sending this report in the request time..
if($self->async_http->to_send_count > 250) {
warn "PerlGuard send queue has reached 250, dropping subsequent requests\n";
return;
}
if($self->async_http->in_progress_count > 250) {
warn "PerlGuard in progress count queue has reached 250, dropping subsequent requests\n";
return;
}
my $request_id = $self->async_http->add( HTTP::Request->new(
POST => $self->base_url . "/collector/v1/profile",
$self->headers,
$content
));
while($self->async_http->to_send_count > 0) {
$self->async_http->poke();
}
#warn "completed send";
# This helped keep things cleaner on local but it quite obviously causes a race condition,
#$self->async_http->remove($request_id);
}
sub flush {
my $self = shift;
while($self->async_http->not_empty) {
$self->async_http->next_response( $self->async_http->max_request_time );
}
}
sub check_responses {
my $self = shift;
while(my $response = $self->async_http->next_response) {
if($response->is_error) {
#print STDERR "Response is " . $response->as_string ."\n";
my $next_run_time = [Time::HiRes::gettimeofday];
$next_run_time->[0]++;
$self->disabled_until($next_run_time);
}
}; #Clear queue
}
sub can_run_yet {
my $self = shift;
return Time::HiRes::tv_interval( $self->disabled_until ) >= 0 ? 1 : 0;
}
sub format_database_transactions {
my $self = shift;
my $profile = shift;
my @results;
foreach my $row(@{$profile->database_transactions}) {
if($row->{start_time}) {
$row->{start_time_offset} = $profile->calculate_time_index_in_ms($row->{start_time});
}
if($row->{finish_time}) {
$row->{finish_time_offset} = $profile->calculate_time_index_in_ms($row->{finish_time});
}
push @results, $row;
}
return \@results;
}
sub format_webservice_transactions {
my $self = shift;
my $profile = shift;
my @results;
foreach my $row(@{$profile->webservice_transactions}) {
if($row->{start_time}) {
$row->{start_time_offset} = $profile->calculate_time_index_in_ms($row->{start_time});
}
if($row->{finish_time}) {
$row->{finish_time_offset} = $profile->calculate_time_index_in_ms($row->{finish_time});
}
push @results, $row;
}
return \@results;
}
1;
lib/PerlGuard/Agent/Output/StandardError.pm view on Meta::CPAN
# Output method purely for testing some concepts on the agent before implementing the server
package PerlGuard::Agent::Output::StandardError;
use Moo;
extends 'PerlGuard::Agent::Output';
# Takes a profile object and saves it
sub save {
my $self = shift;
my $profile = shift;
return unless $profile->should_save();
use Data::Dumper;
print STDERR "======\n";
print STDERR "Profiler ID " . $profile->uuid() . "\n";
print STDERR "Total elapsed time " . $profile->total_elapsed_time() . "\n";
print STDERR Dumper $profile->database_transactions();
print STDERR "======\n";
}
sub flush {
#noop
}
1;
lib/PerlGuard/Agent/Profile.pm view on Meta::CPAN
# This is a single web request, or a single execution of a script
package PerlGuard::Agent::Profile;
use 5.010001;
use Moo;
use Time::HiRes;
has agent => ( is => 'ro', required => 1, weak_ref => 1);
has uuid => ( is => 'lazy' );
has start_time => ( is => 'ro' );
has finish_time => ( is => 'ro' );
has start_time_hires => ( is => 'ro' );
has finish_time_hires => ( is => 'ro' );
has url => ( is => 'rw' );
has http_method => ( is => 'rw' );
has controller => ( is => 'rw' );
has controller_action => ( is => 'rw' );
has http_code => ( is => 'rw' );
has should_save => ( is => 'rw', default => sub { 1 } );
# has user; # A user definable value
# has script_name; # Superceeded by grouping_name which is more generic
# has hostname;
# has server_name;
has database_transactions => ( is => 'rw', default => sub {[]});
has webservice_transactions => ( is => 'rw', default => sub {[]});;
has cross_application_tracing_id => ( is => 'rw', default => sub { undef });
sub _build_uuid {
my $self = shift;
return "$self"; # Switch to an actual UUID later
}
sub start_recording {
my $self = shift;
$self->{start_time_hires} = [Time::HiRes::gettimeofday()];
$self->{start_time} = DateTime->now();
}
sub pause_recording {
}
sub finish_recording {
my $self = shift;
$self->{finish_time_hires} = [Time::HiRes::gettimeofday()];
$self->{finish_time} = DateTime->now();
}
sub has_finished {
my $self = shift;
return 1 if defined $self->{finish_time_hires};
return 0;
}
sub save {
my $self = shift;
$self->agent->output->save($self);
}
sub total_elapsed_time {
my $self = shift;
return Time::HiRes::tv_interval( $self->{start_time_hires}, $self->{finish_time_hires} );
}
sub total_elapsed_time_in_ms {
my $self = shift;
$self->convert_to_ms($self->total_elapsed_time);
}
sub database_transaction_count {
my $self = shift;
scalar(@{$self->database_transactions});
}
sub webservice_transaction_count {
my $self = shift;
scalar(@{$self->webservice_transactions});
}
sub database_elapsed_time {
my $self = shift;
my $total = 0;
foreach my $database_transaction(@{$self->database_transactions}) {
#warn $database_transaction->{start_time};
#warn "start " . join(",", @{$database_transaction->{start_time}});
#warn "finish " . join(",", @{$database_transaction->{finish_time}});
#warn "interval " . Time::HiRes::tv_interval( $database_transaction->{start_time}, $database_transaction->{finish_time});
$total += Time::HiRes::tv_interval( $database_transaction->{start_time}, $database_transaction->{finish_time});
}
return $total;
}
sub webservice_elapsed_time {
my $self = shift;
my $total = 0;
foreach my $webservice_transaction(@{$self->webservice_transactions}) {
$total += Time::HiRes::tv_interval( $webservice_transaction->{start_time}, $webservice_transaction->{finish_time});
}
return $total;
}
sub database_elapsed_time_in_ms {
my $self = shift;
$self->convert_to_ms($self->database_elapsed_time)
}
sub webservice_elapsed_time_in_ms {
my $self = shift;
$self->convert_to_ms($self->webservice_elapsed_time)
}
sub add_database_transaction {
my $self = shift;
my $database_transaction = shift;
push(@{$self->database_transactions}, $database_transaction);
}
sub add_webservice_transaction {
my $self = shift;
my $webservice_transaction = shift;
push(@{$self->webservice_transactions}, $webservice_transaction);
}
sub calculate_time_index_in_ms {
my $self = shift;
my $other_time = shift;
return( $self->convert_to_ms( Time::HiRes::tv_interval($self->{start_time_hires}, $other_time )));
}
sub convert_to_ms {
my $self = shift;
my $thing_to_convert = shift;
return sprintf("%.0f", $thing_to_convert * 1000)
}
sub do_not_save {
my $self = shift;
$self->should_save(0);
}
# Putting the application ID in here would really help the server later on but we aren't requiring the user to specify it yet
sub generate_new_cross_application_tracing_id {
my $self = shift;
return $self->{uuid} . '@' . join(',', (Time::HiRes::gettimeofday()));
}
sub DESTROY {
my $self = shift;
$self->agent->output->flush();
$self->agent->remove_profile($self->uuid);
}
1;
t/PerlGuard-Agent.t view on Meta::CPAN
# I have stripped out most of the tests for the initial CPAN release as they are only suitable for development
# Full test suite to follow once we establish which monitoring method to use (Hook::LexWrap may be unsuitable after initial customer testing)
# Before 'make install' is performed this script should be runnable with
# 'make test'. After 'make install' it should work as 'perl PerlGuard-Agent.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use strict;
use warnings;
use FindBin;
# use Mojo::JSON;
use Test::More tests => 6;
BEGIN { use_ok('PerlGuard::Agent') };
BEGIN { use_ok('PerlGuard::Agent::Profile') };
BEGIN { use_ok('PerlGuard::Agent::Output::StandardError') };
# BEGIN { use_ok('PerlGuard::Agent::Frameworks::Mojolicious') };
BEGIN { use_ok('PerlGuard::Agent::Monitors::DBI') };
BEGIN { use_ok('PerlGuard::Agent::Monitors::NetHTTP') };
BEGIN { use_ok('PerlGuard::Agent::Output::PerlGuardServer') };
#########################
my $agent = PerlGuard::Agent->new();
( run in 0.422 second using v1.01-cache-2.11-cpan-b32c08c6d1a )