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