perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@hyperreal.org
Subject cvs commit: modperl/Leak Leak.pm Leak.xs Makefile.PL typemap
Date Fri, 06 Nov 1998 21:07:54 GMT
dougm       98/11/06 13:07:54

  Added:       Leak     Leak.pm Leak.xs Makefile.PL typemap
  Log:
  new module for tracking memory leaks
  
  Revision  Changes    Path
  1.1                  modperl/Leak/Leak.pm
  
  Index: Leak.pm
  ===================================================================
  package Apache::Leak;
  
  use strict;
  use DynaLoader ();
  use Exporter ();
  *import = \&Exporter::import;
  {
      no strict;
      @EXPORT = qw(leak_test);
      $VERSION = '1.00';
      @ISA = qw(DynaLoader);
      __PACKAGE__->bootstrap($VERSION);
  }
  
  sub LOOP_N () {2}
  
  sub leak_test (&;$$) {
      my($cv, $x, $fh) = @_;
      $x  ||= LOOP_N;
      $fh ||= \*STDERR;
      my $first = $x;
  
      while($x--) {
  	my $handle;
  	my $enter = NoteSV($handle);
  	my $leave = 0;
  	print $fh "ENTER: $enter SVs\n";
  	{
  	    $cv->();
  	}
  	$leave = CheckSV($handle);
  	print $fh "\nLEAVE: $leave SVs\n";
  	if($enter != $leave) {
  	    my $n = $leave - $enter;
  	    if($x+1 == $first) {
  	    }
  	    else {
  		print $fh "!!! $n SVs leaked !!!\n";
  	    }
  	}
      }
  }
  
  sub handler {
      my $r = shift; 
      my $uri = $r->uri;
      my $handle;
      my $count = NoteSV($handle);
      $r->push_handlers(PerlLogHandler => sub {
  	warn "Leak test for $uri:\n";
          warn "  ENTER: $count SVs\n";
          $count = CheckSV($handle);
          warn "  LEAVE: $count SVs\n";
      });
      0;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Apache::Leak - Module for tracking memory leaks in mod_perl code
  
  =head1 SYNOPSIS
  
      use Apache::Leak;
  
      leak_test {
  	my $obj = Foo->new;
  	$obj->thingy;
      };
      #now look in error_log for results
  
  =head1 DESCRIPTION
  
  "Under Construction."
  
  =head1 SEE ALSO
  
  Devel::Leak
  
  =head1 AUTHOR
  
  Doug MacEachern
  Leak.xs derived from Nick Ing-Simmons' Devel::Leak
  
  
  
  1.1                  modperl/Leak/Leak.xs
  
  Index: Leak.xs
  ===================================================================
  /*
    Copyright (c) 1995,1996-1998 Nick Ing-Simmons. All rights reserved.
    This program is free software; you can redistribute it and/or
    modify it under the same terms as Perl itself.
  */
  /*
   modified by dougm for use with 5.004_04    
   future versions may be made special for the mod_perl environment
  */
  
  #include <EXTERN.h>
  #include <perl.h>
  #include <XSUB.h>
  
  #include "patchlevel.h"
  #if ((PATCHLEVEL == 4) && (SUBVERSION <= 76))
  #define PL_sv_arenaroot sv_arenaroot
  #endif
  
  typedef long used_proc _((void *, SV *, long));
  typedef struct hash_s *hash_ptr;
  
  #define MAX_HASH 1009
  
  static hash_ptr pile = NULL;
  
  static void
  LangDumpVec(char *who, int count, SV **data)
  {
      int i;
      PerlIO_printf(PerlIO_stderr(), "%s (%d):\n", who, count);
      for (i = 0; i < count; i++)
      {
  	SV *sv = data[i];
  	if (sv) {
  	    PerlIO_printf(PerlIO_stderr(), "%2d ", i);
  	    sv_dump(sv);
  	}
      }
  }
  
  struct hash_s {
      struct hash_s *link;
      SV *sv;
      char *tag;
  };
  
  static char *lookup(hash_ptr *ht, SV *sv, void *tag)
  {
      unsigned hash = ((unsigned long) sv) % MAX_HASH;
      hash_ptr p = ht[hash];
      while (p) {
  	if (p->sv == sv) {
  	    char *old = p->tag;
  	    p->tag = tag;
  	    return old;
  	}
  	p = p->link;
      }
      if ((p = pile))
  	pile = p->link;
      else
  	p = (hash_ptr) malloc(sizeof(struct hash_s));
      p->link  = ht[hash];
      p->sv    = sv;
      p->tag   = tag;
      ht[hash] = p;
      return NULL;
  }
  
  static void check_arenas()
  {
      SV *sva;
      for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
  	SV *sv = sva + 1;
  	SV *svend = &sva[SvREFCNT(sva)];
  	while (sv < svend) {
  	    if (SvROK(sv) && ((IV) SvANY(sv)) & 1) {
  		warn("Odd SvANY for %p @ %p[%d]",sv,sva,(sv-sva));
  		abort();
  	    }
  	    ++sv;
  	}
      }
  }
  
  static long int sv_apply_to_used(void *p, used_proc *proc, long int n)
  {
      SV *sva;
      for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
  	SV *sv = sva + 1;
  	SV *svend = &sva[SvREFCNT(sva)];
  
  	while (sv < svend) {
  	    if (SvTYPE(sv) != SVTYPEMASK) {
  		n = (*proc) (p, sv, n);
  	    }
  	    ++sv;
  	}
      }
      return n;
  }
  
  static char old[] = "old";
  static char new[] = "new";
  
  static long note_sv(void *p, SV *sv, long int n) {
      lookup(p, sv, old);
      return n+1;
  }
  
  static long note_used(hash_ptr **x)
  {
      hash_ptr *ht;
      Newz(603, ht, MAX_HASH, hash_ptr);
      *x = ht;
      return sv_apply_to_used(ht, note_sv, 0);
  }
  
  static long check_sv(void *p, SV *sv, long hwm)
  {
      char *state = lookup(p,sv,new);
      if (state != old) {                           
  	fprintf(stderr, "%s %p : ", state ? state : new, sv);
  	sv_dump(sv);
      }
      return hwm+1;
  }
  
  static long check_used(hash_ptr **x) {
      hash_ptr *ht = *x;
      long count = sv_apply_to_used(ht, check_sv, 0);
      long i;
      for (i = 0; i < MAX_HASH; i++) {
  	hash_ptr p = ht[i];
  	while (p) {
  	    hash_ptr t = p;
  	    p = t->link;
  	    if (t->tag != new) {
  		LangDumpVec(t->tag ? t->tag : "NUL", 1, &t->sv);
  	    }
  	    t->link = pile;
  	    pile = t;
  	}
      }
      free(ht);
      *x = NULL;
      return count;
  }
  
  MODULE = Apache::Leak	PACKAGE = Apache::Leak
  
  PROTOTYPES: Enable
  
  IV
  NoteSV(obj)
      hash_ptr *	obj = NO_INIT
  
      CODE:
      RETVAL = note_used(&obj);
  
      OUTPUT:
      obj
      RETVAL
  
  IV
  CheckSV(obj)
      hash_ptr *	obj
  
      CODE:
      RETVAL = check_used(&obj);
  
      OUTPUT:
      RETVAL
  
  void
  check_arenas()
  
  
  
  
  
  1.1                  modperl/Leak/Makefile.PL
  
  Index: Makefile.PL
  ===================================================================
  use ExtUtils::MakeMaker;
  
  WriteMakefile(
      NAME	=> "Apache::Leak",
      VERSION_FROM => "Leak.pm",
  );
  
  
  
  
  1.1                  modperl/Leak/typemap
  
  Index: typemap
  ===================================================================
  hash_ptr *		T_PTR
  
  
  
  

Mime
View raw message