Apache-DB-0.14/0000755000076400007640000000000011005173050012066 5ustar frankfrankApache-DB-0.14/lib/0000755000076400007640000000000011005173050012634 5ustar frankfrankApache-DB-0.14/lib/Apache/0000755000076400007640000000000011005173050014015 5ustar frankfrankApache-DB-0.14/lib/Apache/DProf.pm0000644000076400007640000001351410502074626015403 0ustar frankfrankpackage Apache::DProf; use strict; use Apache::DB (); use File::Path (); { no strict; $VERSION = '0.08'; } # Need to determine if we are in a mod_perl 1.x or 2.x environment # and load the appropriate modules BEGIN { use constant MP2 => eval { exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 }; die "mod_perl is required to run this module: $@" if $@; if (MP2) { require Apache2::RequestRec; require Apache2::ServerUtil; } } # Adjust to handle mp1 and mp2 differently my $prof_path; if (MP2) { my $s = Apache2::ServerUtil::server_root(); if( $ENV{APACHE_DPROF_PATH} ) { $prof_path = "$s/" . $ENV{APACHE_DPROF_PATH}; } else { $prof_path = "$s/" . "logs/dprof"; } } else { if ($ENV{APACHE_DPROF_PATH_ABSOLUTE}) { $prof_path = $ENV{APACHE_DPROF_PATH_ABSOLUTE}; } else { $prof_path = Apache->server_root_relative($ENV{APACHE_DPROF_PATH} || "logs/dprof"); } } if($ENV{MOD_PERL}) { File::Path::rmtree($prof_path) if -d $prof_path and $ENV{APACHE_DPROF_CLEANUP}; if (MP2) { Apache2::ServerUtil->server->push_handlers( PerlChildInitHandler => \&handler ) or die "Cannot push handler: $!"; } else { Apache->push_handlers(PerlChildInitHandler => \&handler); } } sub handler { my $r = shift; my $dir = "$prof_path/$$"; # Untained $dir $dir =~ m/^(.*?)$/; $dir = $1; File::Path::mkpath($dir); chdir $dir or die "Cannot move into '$dir': $!"; warn("Entering handler...."); Apache::DB->init; require Devel::DProf; if (MP2) { } else { chdir $Apache::Server::CWD; } return 0; } 1; __END__ =head1 NAME Apache::DProf - Hook Devel::DProf into mod_perl =head1 SYNOPSIS #in httpd.conf PerlModule Apache::DProf =head1 DESCRIPTION The Apache::DProf module will run a Devel::DProf profiler inside each child server and write the I file in the directory I<$ServerRoot/logs/dprof/$$> when the child is shutdown. Next time the parent server pulls in Apache::DProf (via soft or hard restart), the I<$ServerRoot/logs/dprof> is cleaned out before new profiles are written for the new children. =head1 WHY It is possible to profile code run under mod_perl with only the B module available on CPAN. You must have apache version 1.3b3 or higher. When the server is started, B installs an C block to write the I file, which will be run when the server is shutdown. Here's how to start and stop a server with the profiler enabled: % setenv PERL5OPT -d:DProf % httpd -X -d `pwd` & ... make some requests to the server here ... % kill `cat logs/httpd.pid` % unsetenv PERL5OPT % dprofpp There are downsides to this approach: - Setting and unsetting PERL5OPT is a pain. - Server startup code will be profiled as well, which we are not really concerned with, we're interested in runtime code, right? - It will not work unless the server is run in non-forking C<-X> mode These limitations are due to the assumption by Devel::DProf that the code you are profiling is running under a standard Perl binary (the one you run from the command line). C relies on the Perl C<-d> switch for intialization of the Perl debugger, which happens inside C function call. It also relies on Perl's special C subroutines for termination when it writes the raw profile to I. Under the standard command line Perl interpreter, these C blocks are run when the C function is called. Also, Devel::DProf will not profile any code if it is inside a forked process. Each time you run a Perl script from the command line, the C and C functions are called, Devel::DProf works just fine this way. Under mod_perl, the C and C functions are called only once, when the parent server is starting. Any C blocks encountered during server startup or outside of C scripts are suspended and run when the server is shutdown via apache's child exit callback hook. The parent server only runs Perl startup code, all request time code is run in the forked child processes. If you followed the previous paragraph, you should be able to see, Devel::DProf does not fit into the mod_perl model too well. The Apache::DProf module exists to make it fit without modifying the Devel::DProf module or Perl itself. The B module also requires apache version 1.3b3 or higher and C enabled. It is configured simply by adding this line to your httpd.conf file: PerlModule Apache::DProf When the Apache::DProf module is pulled in by the parent server, it will push a C via the Apache push_handlers method. When a child server is starting the C subroutine will called. This handler will create a directory C relative to B where Devel::DProf will create it's I file. Then, the handler will initialize the Perl debugger and pull in Devel::DProf who will then install it's hooks into the debugger and start it's profile timer. The C subroutine installed by Devel::DProf will be run when the child server is shutdown and the I<$ServerRoot/dprof/$$/tmon.out> file will be generated and ready for B. B I<$ServerRoot/logs/dprof/> will need to be writable by the user Apache is running as (i.e. nobody, apache, etc.). If you can not write to $ServerRoot as this user, set $ENV{APACHE_DPROF_PATH_ABSOLUTE} to an absolute path of a directory this user can. =head1 AUTHOR Originally written by Doug MacEachern Currently maintained by Frank Wiles =head1 LICENSE This module is distributed under the same terms as Perl itself. =head1 SEE ALSO Devel::DProf(3), Apache::DB(3), mod_perl(3), Apache(3) =cut Apache-DB-0.14/lib/Apache/SmallProf.pm0000755000076400007640000001517410462257502016300 0ustar frankfrankpackage Apache::SmallProf; use strict; use vars qw($VERSION @ISA); use Apache::DB 0.13; @ISA = qw(DB); $VERSION = '0.09'; $Apache::Registry::MarkLine = 0; BEGIN { use constant MP2 => eval { exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 }; die "mod_perl is required to run this module: $@" if $@; if (MP2) { require APR::Pool; require Apache2::RequestUtil; require Apache2::RequestRec; require Apache2::ServerUtil; } } sub handler { my $r = shift; my $dir; if (MP2) { $dir = Apache2::ServerUtil::server_root(); } else { $dir = $r->server_root_relative; } my $sdir = $r->dir_config('SmallProfDir') || 'logs/smallprof'; $dir = "$dir/$sdir"; # Untaint $dir $dir =~ m/^(.*?)$/; $dir = $1; mkdir $dir, 0755 unless -d $dir; # Die if we can't make the directory die "$dir does not exist: $!" if !-d $dir; (my $uri = $r->uri) =~ s,/,::,g; $uri =~ s/^:+//; my $db = Apache::SmallProf->new(file => "$dir/$uri", dir => $dir); $db->begin; if (MP2) { $r->pool->cleanup_register(sub { local $DB::profile = 0; $db->end; 0; }); } else { $r->register_cleanup(sub { local $DB::profile = 0; $db->end; 0; }); } 0; } package DB; sub new { my $class = shift; my $self = bless {@_}, $class; Apache::DB->init; $self; } use strict; use Time::HiRes qw(time); $DB::profile = 0; #skip startup profiles sub begin { $DB::trace = 1; $DB::drop_zeros = 0; $DB::profile = 1; if (-e '.smallprof') { do '.smallprof'; } $DB::prevf = ''; $DB::prevl = 0; my($diff,$cdiff); my($testDB) = sub { my($pkg,$filename,$line) = caller; $DB::profile || return; %DB::packages && !$DB::packages{$pkg} && return; }; # "Null time" compensation code $DB::nulltime = 0; for (1..100) { my($u,$s,$cu,$cs) = times; $DB::cstart = $u+$s+$cu+$cs; $DB::start = time; &$testDB; ($u,$s,$cu,$cs) = times; $DB::cdone = $u+$s+$cu+$cs; $DB::done = time; $diff = $DB::done - $DB::start; $DB::nulltime += $diff; } $DB::nulltime /= 100; my($u,$s,$cu,$cs) = times; $DB::cstart = $u+$s+$cu+$cs; $DB::start = time; } sub DB { my($pkg,$filename,$line) = caller; $DB::profile || return; %DB::packages && !$DB::packages{$pkg} && return; my($u,$s,$cu,$cs) = times; $DB::cdone = $u+$s+$cu+$cs; $DB::done = time; # Now save the _< array for later reference. If we don't do this here, # evals which do not define subroutines will disappear. no strict 'refs'; $DB::listings{$filename} = \@{"main::_<$filename"} if defined(@{"main::_<$filename"}); use strict 'refs'; my $delta = $DB::done - $DB::start; $delta = ($delta > $DB::nulltime) ? $delta - $DB::nulltime : 0; $DB::profiles{$filename}->[$line]++; $DB::times{$DB::prevf}->[$DB::prevl] += $delta; $DB::ctimes{$DB::prevf}->[$DB::prevl] += ($DB::cdone - $DB::cstart); ($DB::prevf, $DB::prevl) = ($filename, $line); ($u,$s,$cu,$cs) = times; $DB::cstart = $u+$s+$cu+$cs; $DB::start = time; } use File::Basename qw(dirname basename); sub out_file { my($self, $fname) = @_; if($fname =~ /eval/) { $fname = basename($self->{file}) || "smallprof.out"; } elsif($fname =~ s/^Perl.*Handler subroutine \`(.*)\'$/$1/) { } else { for (keys %INC) { if($fname =~ s,.*$_,$_,) { $fname =~ s,/+,::,g; last; } } if($fname =~ m,/,) { $fname = basename($fname); } } return "$self->{dir}/$fname.prof"; } sub end { my $self = shift; # Get time on last line executed. my($u,$s,$cu,$cs) = times; $DB::cdone = $u+$s+$cu+$cs; $DB::done = time; my $delta = $DB::done - $DB::start; $delta = ($delta > $DB::nulltime) ? $delta - $DB::nulltime : 0; $DB::times{$DB::prevf}->[$DB::prevl] += $delta; $DB::ctimes{$DB::prevf}->[$DB::prevl] += ($DB::cdone - $DB::cstart); my($i, $stat, $time, $ctime, $line, $file); my %cnt = (); foreach $file (sort keys %DB::profiles) { my $out = $self->out_file($file); open(OUT, ">$out") or die "can't open $out $!"; if (defined($DB::listings{$file})) { $i = -1; foreach $line (@{$DB::listings{$file}}) { ++$i or next; chomp $line; $stat = $DB::profiles{$file}->[$i] || 0 or !$DB::drop_zeros or next; $time = defined($DB::times{$file}->[$i]) ? $DB::times{$file}->[$i] : 0; $ctime = defined($DB::ctimes{$file}->[$i]) ? $DB::ctimes{$file}->[$i] : 0; printf OUT "%10d %.6f %.6f %10d:%s\n", $stat, $time, $ctime, $i, $line; } } else { $line = "The code for $file is not in the symbol table."; warn $line; for ($i=1; $i <= $#{$DB::profiles{$file}}; $i++) { next unless ($stat = $DB::profiles{$file}->[$i] || 0 or !$DB::drop_zeros); $time = defined($DB::times{$file}->[$i]) ? $DB::times{$file}->[$i] : 0; $ctime = defined($DB::ctimes{$file}->[$i]) ? $DB::ctimes{$file}->[$i] : 0; printf OUT "%10d %.6f %.6f %10d:%s\n", $stat, $time, $ctime, $i, $line; } } close OUT; } } sub sub { no strict 'refs'; local $^W = 0; goto &$DB::sub unless $DB::profile; if (defined($DB::sub{$DB::sub})) { my($m,$s) = ($DB::sub{$DB::sub} =~ /.+(?=:)|[^:-]+/g); $DB::profiles{$m}->[$s]++; $DB::listings{$m} = \@{"main::_<$m"} if defined(@{"main::_<$m"}); } goto &$DB::sub; } 1; __END__ =head1 NAME Apache::SmallProf - Hook Devel::SmallProf into mod_perl =head1 SYNOPSIS use Apache::DB (); Apache::DB->init; PerlFixupHandler Apache::SmallProf =head1 DESCRIPTION Devel::SmallProf is a line-by-line code profiler. Apache::SmallProf provides this profiler in the mod_perl environment. Profiles are written to I<$ServerRoot/logs/smallprof> and unlike I the profile is split into several files based on package name. The I documentation explains how to analyize the profiles, e.g.: % sort -nrk 2 logs/smallprof/CGI.pm.prof | more 1 0.104736 629: eval "package $pack; $$auto"; 2 0.002831 647: eval "package $pack; $code"; 5 0.002002 259: return $self->all_parameters unless @p; 5 0.000867 258: my($self,@p) = self_or_default(@_); ... =head1 LICENSE This module is distributed under the same terms as Perl itself. =head1 SEE ALSO Devel::SmallProf(3), Apache::DB(3), Apache::DProf(3) =head1 AUTHOR Devel::SmallProf - Ted Ashton Apache::SmallProf derived from Devel::SmallProf - Doug MacEachern Currently maintained by Frank Wiles Apache-DB-0.14/DB.xs0000644000076400007640000000260111005172650012733 0ustar frankfrank#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef WIN32 #define SIGINT 2 #endif static void my_init_debugger() { dTHR; PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(PL_dbargs); PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV)); PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV))); sv_setiv(PL_DBsignal, 0); PL_curstash = PL_defstash; } static Sighandler_t ApacheSIGINT = NULL; MODULE = Apache::DB PACKAGE = Apache::DB PROTOTYPES: DISABLE BOOT: ApacheSIGINT = rsignal_state(whichsig("INT")); int init_debugger() CODE: if (!PL_perldb) { PL_perldb = PERLDB_ALL; my_init_debugger(); RETVAL = TRUE; } else RETVAL = FALSE; OUTPUT: RETVAL MODULE = Apache::DB PACKAGE = DB void ApacheSIGINT(...) CODE: #if ((PERL_REVISION == 5) && (PERL_VERSION >= 10)) if (ApacheSIGINT) (*ApacheSIGINT)(SIGINT, NULL, NULL); #else if (ApacheSIGINT) (*ApacheSIGINT)(SIGINT); #endif Apache-DB-0.14/DB.pm0000644000076400007640000000765011005173014012721 0ustar frankfrankpackage Apache::DB; use 5.005; use strict; use DynaLoader (); BEGIN { use constant MP2 => eval { exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 }; die "mod_perl is required to run this module: $@" if $@; if (MP2) { require APR::Pool; require Apache2::RequestRec; } } { no strict; @ISA = qw(DynaLoader); $VERSION = '0.14'; __PACKAGE__->bootstrap($VERSION); } $Apache::Registry::MarkLine = 0; sub init { if(init_debugger()) { warn "[notice] Apache::DB initialized in child $$\n"; } 1; } sub handler { my $r = shift; init(); { local $@; my $loaded_db; if ($ENV{PERL5DB}) { (my $directive = $ENV{PERL5DB}) =~ s/^\s*BEGIN\s*{\s*(.*)\s*}\z/$1/s; $directive =~ s/^require\b/do/; $loaded_db = eval($directive); } if (!$loaded_db) { # Fallback require 'Apache/perl5db.pl'; } } $DB::single = 1; if( MP2 ) { if (ref $r) { $SIG{INT} = \&DB::catch; $r->pool->cleanup_register(sub { $SIG{INT} = \&DB::ApacheSIGINT(); }); } } else { if (ref $r) { $SIG{INT} = \&DB::catch; $r->register_cleanup(sub { $SIG{INT} = \&DB::ApacheSIGINT(); }); } } return 0; } 1; __END__ =head1 NAME Apache::DB - Run the interactive Perl debugger under mod_perl =head1 SYNOPSIS PerlFixupHandler +Apache::DB SetHandler perl-script PerlHandler +Apache::Registry Options +ExecCGI =head1 DESCRIPTION Perl ships with a very useful interactive debugger, however, it does not run "out-of-the-box" in the Apache/mod_perl environment. Apache::DB makes a few adjustments so the two will cooperate. =head1 FUNCTIONS =over 4 =item init This function initializes the Perl debugger hooks without actually starting the interactive debugger. In order to debug a certain piece of code, this function must be called before the code you wish debug is compiled. For example, if you want to insert debugging symbols into code that is compiled at server startup, but do not care to debug until request time, call this function from a PerlRequire'd file: #where db.pl is simply: # use Apache::DB (); # Apache::DB->init; PerlRequire conf/db.pl #where modules are loaded PerlRequire conf/init.pl If you are using mod_perl 2.0 you will need to use the following as your db.pl: use APR::Pool (); use Apache::DB (); Apache::DB->init(); =item handler This function will start the interactive debugger. It will invoke I if needed. Example configuration: PerlFixupHandler Apache::DB SetHandler perl-script PerlHandler My::handler =back =head1 SELinux Security-enhanced Linux (SELinux) is a mandatory access control system many linux distrobutions are implementing. This new security scheme can assist you with protecting a server, but it doesn't come without its own set of issues. Debugging applications running on a box with SELinux on it takes a couple of extra steps and unfortunately the instructions that follow have only been tested on RedHat/Fedora. 1) You need to edit/create the file "local.te" and add the following: if (httpd_tty_comm) { allow { httpd_t } admin_tty_type:chr_file { ioctl getattr }; } 2) Reload your security policy. 3) Run the command "setsebool httpd_tty_comm true". You should be aware as you debug applications on a system with SELinux your code may very well be correct, but the system policy is denying your actions. =head1 CAVEATS =over 4 =item -X The server must be started with the C<-X> to use Apache::DB. =item filename/line info The filename of Apache::Registry scripts is not displayed. =back =head1 SEE ALSO perldebug(1) =head1 AUTHOR Originally written by Doug MacEachern Currently maintained by Frank Wiles =head1 LICENSE This module is distributed under the same terms as Perl itself. Apache-DB-0.14/MANIFEST0000644000076400007640000000026710453017302013227 0ustar frankfrankChanges DB.pm DB.xs MANIFEST Makefile.PL README lib/Apache/DProf.pm lib/Apache/SmallProf.pm perldb.conf META.yml Module meta-data (added by MakeMaker) Apache-DB-0.14/META.yml0000664000076400007640000000044311005173050013342 0ustar frankfrank# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Apache-DB version: 0.14 version_from: DB.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 Apache-DB-0.14/Changes0000644000076400007640000000347211005173005013367 0ustar frankfrank=item 0.14 - April 27, 2008 Added patch from Niko Tyni which fixes Apache::DB for use with Perl 5.10 =item 0.13 - April 17, 2006 Fixed Apache::DProf and Apache::SmallProf to work when using taint mode. =item 0.12 - April 3, 2006 Fixed mod_perl 1.x bug in Apache::SmallProf that was using mp2 code mistakenly. Add $ENV{APACHE_DPROF_PATH_ABSOLUTE} override for those unlucky soles that can NOT write to ServerRoot. [Philip M. Gollucci ] =item 0.11 - January 24, 2006 Refactored how we were detecting mod_perl 1.x vs mod_perl 2.x Cleaned up a small documentation bug in Apache::SmallProf =item 0.10 - May 15, 2005 Ported all modules to mod_perl 2.0.0-RC6 including API changes. Added documentation regarding necessary steps when debugging with SELinux thanks to Dave Hageman . Added missing license information. Added fix for graphical debuggers thanks to Eric Promislow . General documentation cleanup. =item 0.09 - May 11, 2004 Fix required module problems in Apache::SmallProf, thanks to Jens Gassmann for spotting the problem. =item 0.08 - April 14, 2004 Increment version to fix PAUSE upload problem. =item 0.07 - April 7, 2004 Ported modules to work with mod_perl 2.0 [Frank Wiles ] Fixed compilation problem on WIN32 platform. =item 0.06 - October 11, 1999 fix APACHE_DPROF_PATH [Balazs Rauznitz ] fix Apache::DB for 5.005_6x+ sync Apache::SmallProf w/ Devel::SmallProf 0.07 (cpu time support) =item 0.05 - June 6, 1999 included example perldb.conf included Apache::SmallProf included Apache::DProf =item 0.04 - April 14, 1999 added init() function updated docs =item 0.03 - April 5, 1999 fix for threaded Perl =item 0.02 - April 1, 1999 first public release Apache-DB-0.14/perldb.conf0000644000076400007640000000113010453017302014203 0ustar frankfrank #define options: #interactive debugger: httpd -X -DPERLDB #DProf: httpd -X -DPERLDPROF #SmallProf: httpd -X -DPERLSMALLPROF my @dbs = qw(DB DProf SmallProf); my $init_db = 0; my $handler = ""; for (@dbs) { my $define = "PERL\U$_"; next unless $init_db = Apache->define($define); $handler = "Apache::$_"; last; } if ($init_db) { require Apache::DB; Apache::DB::->init; eval "require $handler;"; die $@ if $@; print "Apache::DB configured with $handler\n"; push @{ $Location{'/'}->{PerlFixupHandler} }, $handler; } Apache-DB-0.14/README0000644000076400007640000000110510453017302012746 0ustar frankfrankThis package provides debugging and profiling tools for mod_perl: Apache::DB - Hooks for the interactive Perl debugger Apache::DProf - Hooks for Devel::DProf Apache::SmallProf - Hooks for Devel::SmallProf These modules are very useful for helping to determine the cause of errors and performance problems in mod_perl applications. They should function with both mod_perl 1.x and 2.x. These modules were originally written by Doug MacEachern. They are currently being maintained by Frank Wiles . Please E-mail him with any bugs you may find. Apache-DB-0.14/Makefile.PL0000644000076400007640000000154710453017302014052 0ustar frankfrankuse ExtUtils::MakeMaker; use 5.005; use strict; use File::Copy 'cp'; use subs 'iedit'; my $perl5db; for (@INC) { last if -e ($perl5db = "$_/perl5db.pl"); } warn "creating Apache/perl5db.pl from $perl5db\n"; cp $perl5db => './perl5db.pl'; #poor man's patch iedit './perl5db.pl', "s/^END /sub db_END /"; #iedit './perl5db.pl', "s/(.SIG{INT}) /#\$1 /"; WriteMakefile( 'NAME' => 'Apache::DB', 'VERSION_FROM' => 'DB.pm', 'macro' => { CVSROOT => 'modperl.com:/local/cvs_repository', }, ); sub MY::postamble { return <<'EOF'; cvs_tag : cvs -d $(CVSROOT) tag v$(VERSION_SYM) . @echo update DB.pm VERSION now EOF } sub MY::post_initialize { my $self = shift; $self->{PM}{"perl5db.pl"} = '$(INST_ARCHLIB)/' . "Apache/perl5db.pl"; ''; } sub iedit { my $file = shift; system $^X, "-pi~", "-e", "@_", $file; }