Dear Folks, If anyone would cast a glance at the Persistent Embedding code below and let me know where I can start looking/hacking to stop it leaking at such a great rate, I will be very grateful.
The unaceptable leak rate appears to be associated with 1 the embedding application picking up threads 2 the consequent use of threaded Perl (to make the app work) since when the _same_ code used a non threaded Perl (on both Linux and FreeBSD), the leak rate was much lower. The leak appears to be (somewhat) platform independent: both Linux and FreeBSD appear to suffer similarly. What has been tried so far :- 1 minimise the use of the Perl API (ie have the embedded Perl code return results via the tied handle instead of via the Perl stack). This included replacing the tied handle with a tied scalar. 2 not caching the compiled code (this arrests the leak but slows it down ..) Probably the real answer is, 'this application is not for you'. I accept that but people have been happily using this before and its a shame to see it die for them. Thank you, Yours sincerely. -- Stanley Hopcroft IP Australia Ph: (02) 6283 3189 Fax: (02) 6281 1353 PO Box 200 Woden ACT 2606 http://www.ipaustralia.gov.au 1 The embedded code (like a CGI server: returns the client code output [on stdout] to the caller via the file system/tied handle) package Embed::Persistent; # # Hacked version of the sample code from the perlembedded doco. # # Only major changes are to separate the compiling and cacheing from # the execution so that the cache can be kept in "non-volatile" parent # process while the execution is done from "volatile" child processes # and that STDOUT is redirected to a file by means of a tied filehandle # so that it can be returned to Nagios in the same way as for # commands executed via the normal popen method. # use strict; use vars '%Cache'; use Symbol qw(delete_package); use Text::ParseWords qw(parse_line) ; package OutputTrap; # # Methods for use by tied STDOUT in embedded PERL module. # # Simply redirects STDOUT to a temporary file associated with the # current child/grandchild process. # use strict; # Perl before 5.6 does not seem to have warnings.pm ??? #use warnings; use IO::File; sub TIEHANDLE { my ($class, $fn) = @_; my $handle = new IO::File "> $fn" or die "Cannot open embedded work filei $!\n"; bless { FH => $handle, Value => 0}, $class; } sub PRINT { my $self = shift; my $handle = $self -> {FH}; print $handle join("",@_); } sub PRINTF { my $self = shift; my $fmt = shift; my $handle = $self -> {FH}; printf $handle ($fmt,@_); } sub CLOSE { my $self = shift; my $handle = $self -> {FH}; close $handle; } package Embed::Persistent; sub valid_package_name { my($string) = @_; $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; # second pass only for words starting with a digit $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; # Dress it up as a real package name $string =~ s|/|::|g; return "Embed::" . $string; } sub eval_file { my $filename = shift; my $delete = shift; my $pn = substr($filename, rindex($filename,"/")+1); my $package = valid_package_name($pn); my $mtime = -M $filename; if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime} <= $mtime) { # we have compiled this subroutine already, # it has not been updated on disk, nothing left to do #print STDERR "already compiled $package->hndlr\n"; } else { local *FH; open FH, $filename or die "open '$filename' $!"; local($/) = undef; my $sub = <FH>; close FH; # cater for routines that expect to get args without prgname # and for those using @ARGV $sub = "shift([EMAIL PROTECTED]);[EMAIL PROTECTED]@_;\n" . $sub; # cater for scripts that have embedded EOF symbols (__END__) $sub =~ s/__END__/\;}\n__END__/; #wrap the code into a subroutine inside our unique package my $eval = qq{ package main; use subs 'CORE::GLOBAL::exit'; sub CORE::GLOBAL::exit { die "ExitTrap: \$_[0] ($package)"; } package $package; sub hndlr { $sub; } }; { # hide our variables within this block my($filename,$mtime,$package,$sub); eval $eval; } if ($@){ print STDERR [EMAIL PROTECTED]"\n"; die; } #cache it unless we're cleaning out each time $Cache{$package}{mtime} = $mtime unless $delete; } } sub run_package { my $filename = shift; my $delete = shift; my $tmpfname = shift; my $ar = shift; my $pn = substr($filename, rindex($filename,"/")+1); my $package = valid_package_name($pn); my $res = 0; tie (*STDOUT, 'OutputTrap', $tmpfname); my @a = &parse_line('\s+', 0, $ar) ; eval {$res = $package->hndlr(@a);}; if ($@){ if ($@ =~ /^ExitTrap: /) { $res = 0; } else { # get return code (which may be negative) if ($@ =~ /^ExitTrap: (-?\d+)/) { $res = $1; } else { $res = 2; print STDERR "<"[EMAIL PROTECTED]">\n"; } } } untie *STDOUT; return $res; } 1; 2 client code #ifdef EMBEDDEDPERL strncpy(fname,processed_command,strcspn(processed_command," ")); fname[strcspn(processed_command," ")] = '\x0'; /* have "filename" component of command. Check for PERL */ fp=fopen(fname, "r"); if(fp==NULL) strcpy(raw_command,""); else{ fgets(raw_command,80,fp); fclose(fp); } isperl=FALSE; if(strstr(raw_command,"/bin/perl")!=NULL){ isperl = TRUE; args[0] = fname; args[2] = tmpfname; if(strchr(processed_command,' ')==NULL) args[3]=""; else args[3]=processed_command+strlen(fname)+1; /* call our perl interpreter to compile and optionally cache the command */ if(use_embedded_perl==TRUE) (void) perl_call_argv("Embed::Persistent::eval_file", G_DISCARD | G_EVAL, args); } #endif .. after a fork (call the compiled code) /******** BEGIN EMBEDDED PERL INTERPRETER EXECUTION ********/ #ifdef EMBEDDEDPERL if(isperl){ /* generate a temporary filename to which stdout can be redirected. */ snprintf(tmpfname,sizeof(tmpfname)-1,"/tmp/embeddedXXXXXX"); if((tmpfd=mkstemp(tmpfname))==-1) _exit(STATE_UNKNOWN); /* execute our previously compiled script - from perl_call_argv("Embed::Persistent::eval_file",..) */ ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(args[0],0))); XPUSHs(sv_2mortal(newSVpv(args[1],0))); XPUSHs(sv_2mortal(newSVpv(args[2],0))); XPUSHs(sv_2mortal(newSVpv(args[3],0))); PUTBACK; (void) perl_call_pv("Embed::Persistent::run_package", G_EVAL); SPAGAIN; pclose_result = POPi ; PUTBACK; FREETMPS; LEAVE; /* check return status */ if(SvTRUE(ERRSV)){ pclose_result=-2; #ifdef DEBUG1 printf("embedded perl ran %s with error %s\n",fname,SvPV(ERRSV,PL_na)); #endif } /* read back stdout from script */ fp=fopen(tmpfname, "r"); /* default return string in case nothing was returned */ strcpy(plugin_output,"(No output!)"); /* read output from plugin (which was redirected to temp file) */ fgets(plugin_output,sizeof(plugin_output)-1,fp); plugin_output[sizeof(plugin_output)-1]='\x0'; strip(plugin_output); /* close and delete temp file */ fclose(fp); close(tmpfd); unlink(tmpfname); #ifdef DEBUG1 printf("embedded perl plugin output was %d,%s\n",pclose_result, plugin_output); #endif ...
-- This message contains privileged and confidential information only for use by the intended recipient. If you are not the intended recipient of this message, you must not disseminate, copy or use it in any manner. If you have received this message in error, please advise the sender by reply e-mail. Please ensure all e-mail attachments are scanned for viruses prior to opening or using.
