r19351 - in /branches/upstream/libapache-db-perl: ./ current/ current/lib/ current/lib/Apache/
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Sat May 3 18:07:01 UTC 2008
Author: gregoa
Date: Sat May 3 18:07:00 2008
New Revision: 19351
URL: http://svn.debian.org/wsvn/?sc=1&rev=19351
Log:
[svn-inject] Installing original source of libapache-db-perl
Added:
branches/upstream/libapache-db-perl/
branches/upstream/libapache-db-perl/current/
branches/upstream/libapache-db-perl/current/Changes
branches/upstream/libapache-db-perl/current/DB.pm
branches/upstream/libapache-db-perl/current/DB.xs
branches/upstream/libapache-db-perl/current/MANIFEST
branches/upstream/libapache-db-perl/current/META.yml
branches/upstream/libapache-db-perl/current/Makefile.PL
branches/upstream/libapache-db-perl/current/README
branches/upstream/libapache-db-perl/current/lib/
branches/upstream/libapache-db-perl/current/lib/Apache/
branches/upstream/libapache-db-perl/current/lib/Apache/DProf.pm
branches/upstream/libapache-db-perl/current/lib/Apache/SmallProf.pm (with props)
branches/upstream/libapache-db-perl/current/perldb.conf
Added: branches/upstream/libapache-db-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/Changes?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/Changes (added)
+++ branches/upstream/libapache-db-perl/current/Changes Sat May 3 18:07:00 2008
@@ -1,0 +1,77 @@
+=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 <pgollucci at p6m7g8.com>]
+
+=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 <dhageman at dracken.com>.
+
+Added missing license information.
+
+Added fix for graphical debuggers thanks to
+Eric Promislow <ericp at ActiveState.com>.
+
+General documentation cleanup.
+
+=item 0.09 - May 11, 2004
+
+Fix required module problems in Apache::SmallProf, thanks to
+Jens Gassmann <jens.gassmann at atomix.de> 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 <frank at wiles.org>]
+
+Fixed compilation problem on WIN32 platform.
+
+=item 0.06 - October 11, 1999
+
+fix APACHE_DPROF_PATH [Balazs Rauznitz <balazs at Commissioner.com>]
+
+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
+
+
Added: branches/upstream/libapache-db-perl/current/DB.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/DB.pm?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/DB.pm (added)
+++ branches/upstream/libapache-db-perl/current/DB.pm Sat May 3 18:07:00 2008
@@ -1,0 +1,194 @@
+package 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.13';
+ __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
+
+ <Location /perl>
+ PerlFixupHandler +Apache::DB
+
+ SetHandler perl-script
+ PerlHandler +Apache::Registry
+ Options +ExecCGI
+ </Location>
+
+=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<Apache::DB::init> if needed. Example configuration:
+
+ <Location /my-handler>
+ PerlFixupHandler Apache::DB
+ SetHandler perl-script
+ PerlHandler My::handler
+ </Location>
+
+=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 <frank at wiles.org>
+
+=head1 LICENSE
+
+This module is distributed under the same terms as Perl itself.
+
Added: branches/upstream/libapache-db-perl/current/DB.xs
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/DB.xs?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/DB.xs (added)
+++ branches/upstream/libapache-db-perl/current/DB.xs Sat May 3 18:07:00 2008
@@ -1,0 +1,59 @@
+#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 (ApacheSIGINT) (*ApacheSIGINT)(SIGINT);
Added: branches/upstream/libapache-db-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/MANIFEST?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/MANIFEST (added)
+++ branches/upstream/libapache-db-perl/current/MANIFEST Sat May 3 18:07:00 2008
@@ -1,0 +1,10 @@
+Changes
+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)
Added: branches/upstream/libapache-db-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/META.yml?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/META.yml (added)
+++ branches/upstream/libapache-db-perl/current/META.yml Sat May 3 18:07:00 2008
@@ -1,0 +1,10 @@
+# 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.13
+version_from: DB.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: branches/upstream/libapache-db-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/Makefile.PL?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/Makefile.PL (added)
+++ branches/upstream/libapache-db-perl/current/Makefile.PL Sat May 3 18:07:00 2008
@@ -1,0 +1,56 @@
+use 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;
+}
+
+
+
+
+
+
+
Added: branches/upstream/libapache-db-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/README?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/README (added)
+++ branches/upstream/libapache-db-perl/current/README Sat May 3 18:07:00 2008
@@ -1,0 +1,15 @@
+This 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 <frank at wiles.org>.
+Please E-mail him with any bugs you may find.
+
Added: branches/upstream/libapache-db-perl/current/lib/Apache/DProf.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/lib/Apache/DProf.pm?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/lib/Apache/DProf.pm (added)
+++ branches/upstream/libapache-db-perl/current/lib/Apache/DProf.pm Sat May 3 18:07:00 2008
@@ -1,0 +1,197 @@
+package 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<tmon.out> 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<Devel::DProf> module available on CPAN. You must have
+apache version 1.3b3 or higher. When the server is started,
+B<Devel::DProf> installs an C<END> block to write the I<tmon.out>
+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<Devel::Dprof> relies on the
+Perl C<-d> switch for intialization of the Perl debugger, which
+happens inside C<perl_parse()> function call. It also relies on
+Perl's special C<END> subroutines for termination when it writes the
+raw profile to I<tmon.out>. Under the standard command line Perl
+interpreter, these C<END> blocks are run when the C<perl_run()>
+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<perl_parse()> and C<perl_run()> functions are
+called, Devel::DProf works just fine this way.
+
+Under mod_perl, the C<perl_parse()> and C<perl_run()> functions are
+called only once, when the parent server is starting. Any C<END>
+blocks encountered during server startup or outside of
+C<Apache::Registry> 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<Apache::DProf> module also requires apache version 1.3b3 or
+higher and C<PerlChildInitHandler> 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<PerlChildInitHandler> via the Apache push_handlers
+method. When a child server is starting the C<Apache::DProf::handler>
+subroutine will called. This handler will create a directory
+C<dprof/$$> relative to B<ServerRoot> where Devel::DProf will create
+it's I<tmon.out> 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<END> 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<dprofpp>.
+
+B<NOTE:> 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 $ServerRoto 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 <frank at wiles.org>
+
+=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
Added: branches/upstream/libapache-db-perl/current/lib/Apache/SmallProf.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/lib/Apache/SmallProf.pm?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/lib/Apache/SmallProf.pm (added)
+++ branches/upstream/libapache-db-perl/current/lib/Apache/SmallProf.pm Sat May 3 18:07:00 2008
@@ -1,0 +1,291 @@
+package Apache::SmallProf;
+
+use strict;
+use vars qw($VERSION @ISA);
+use Apache::DB 0.13;
+ at 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;
+
+ unless (-d $dir) {
+ die "$dir does not exist: $!";
+ }
+
+ (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
+
+ <IfDefine PERLSMALLPROF>
+
+ <Perl>
+ use Apache::DB ();
+ Apache::DB->init;
+ </Perl>
+
+ <Location />
+ PerlFixupHandler Apache::SmallProf
+ </Location>
+ </IfDefine>
+
+=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<Devel::SmallProf> the profile is
+split into several files based on package name.
+
+The I<Devel::SmallProf> 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, at 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 <frank at wiles.org>
Propchange: branches/upstream/libapache-db-perl/current/lib/Apache/SmallProf.pm
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libapache-db-perl/current/perldb.conf
URL: http://svn.debian.org/wsvn/branches/upstream/libapache-db-perl/current/perldb.conf?rev=19351&op=file
==============================================================================
--- branches/upstream/libapache-db-perl/current/perldb.conf (added)
+++ branches/upstream/libapache-db-perl/current/perldb.conf Sat May 3 18:07:00 2008
@@ -1,0 +1,28 @@
+<Perl>
+
+#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;
+}
+
+</Perl>
More information about the Pkg-perl-cvs-commits
mailing list