Thanks very much to the useful advice I had from the two lists, here's the
current situation + code.
Having spent most of yesterday in debugging mode it looks like the culprit
is the MIME::Entity object.
This Object ($entity) is NOT being destroyed when it goes out of scope,
however I could not find any other references to the entity in any of the
other objects in this subroutine. There are a couple of other objects which
are part of the entity object so these too do not get destroyed.
The answer to my original question, i.e. how to go about finding a memory
leak, I discovered a module called Devel::Leak.
It's the one used in Apache::Leak.
It allows you to trace WHERE in a code there's a leak, but not why:-(
I don't think I've done anything wrong in my code, but when I added a
DESTROY sub to my copy of the MIME::Parser modules I get a whole long list
of objects which are destroyed in perls Global Garbage Cleanup at the end of
my script.
Has anybody seen this behaviour with the MIME::Parser objects before?
Here is the code which has the leak:-
sub parse_message
{
my $self=shift;
my $message = shift;
my $msg_id = shift;
print STDERR "Parsing message\n" if $self->{debug}>0;
my $mime_handler = new MIME::Parser();
#$mime_handler->output_dir( "/tmp" );
#$mime_handler->output_prefix( "news" );
$mime_handler->output_to_core( 1 );
my $entity = $mime_handler->parse_data( $message );
# Extract the headers
#
my $head = $entity->head();
$head->unfold();
##Added to allow parsing of ALL Message Headers!
my @header = grep {defined($_) ? $_ : ()} @{$head->header};
my %otherHeaders=();
foreach my $Header(@header)
{
my ($Head)=$Header=~/^(.*?)\:.*$/;
unless($Head=~/^[Newsgroups|Subject|From|Date]/)
{
my $headval=$head->get($Head);
chomp $headval;
$otherHeaders{$Head}=$headval;
}
}
$otherHeaders{'X-IDPath'}=$msg_id;
my $channels = $head->get('Newsgroups');
my $subject = $head->get('Subject');
my $from = $head->get('From');
my $date = $head->get('Date');
chomp $channels;
chomp $subject;
chomp $from;
chomp $date;
# Create the message object
#
print STDERR "Creating iBus::Message\n" if $self->{debug}>0;
my $out_message = new iBus::Message( {
channels => $channels,
title => $subject,
date => $date,
from => $from,
extraHeaders=>{%otherHeaders}, #Use an anonymous copy
} );
# Add each of the entities to the message
#
my $i;
if ( $entity->is_multipart() )
{
print STDERR "Message is Multipart\n" if $self->{debug}>1;
foreach $i ( 0 .. ($entity->parts-1) )
{
my $element = $entity->parts( $i );
unless( $element )
{
return undef;
}
my $body = $element->bodyhandle;
if ( $body )
{
my $mimetype = $element->mime_type;
my $data = $body->as_string();
print STDERR "Adding Body Part $i\n" if
$self->{debug}>1;
print STDERR Dumper($body) if
$self->{debug}>2;
$out_message->add( $data, $mimetype );
}
else
{
print STDERR "No body in element $i\n" if
$self->{debug}>1;
}
}
}
else
{
print STDERR "Message is Non-Multipart\n" if
$self->{debug}>1;
my $body = $entity->bodyhandle;
my $mimetype = $entity->mime_type;
my $data = $body->as_string();
if ($body)
{
print STDERR "Adding Body\n" if $self->{debug}>1;
print STDERR Dumper($body) if $self->{debug}>2;
$out_message->add( $data, $mimetype );
}
else
{
print STDERR "No body in message\n" if
$self->{debug}>1;
}
}
#$mime_handler = undef;
#$entity = 0;
#$head = 0;
return $out_message;
}
_______________________________________________
Perl-Unix-Users mailing list. To unsubscribe go to
http://listserv.ActiveState.com/mailman/subscribe/perl-unix-users
