long running perl programs & memory untilization

S

Stan Brown

I find myself in the position of writing long running (months) perl scripts
under FreeBSD, and Linux.

I seem to be having a lot of problems with memory leaks.

I was wondering if anyone had some words of wisdom as to how toadress these
issues? I'm interested in tips for avoiding them, as well as techniqies for
diagnsing existing problems.

If it helps my 'Native: language is C, and I just can't see anyway thet
these scripts should be leaking memory, based upon that experience.

I tend to use a lot of "local" variablse in subroutines, and allmost no
"global" variables at all. if that impacts this discussion.

Thanks for any wisdom that the comunity might be willing to share, and of
course, as always, pointers to docs are appreciated.
 
H

Helgi Briem

If it helps my 'Native: language is C, and I just can't see anyway thet
these scripts should be leaking memory, based upon that experience.

I tend to use a lot of "local" variablse in subroutines, and allmost no
"global" variables at all. if that impacts this discussion.

Well, that probably explains most of it. 'local' in Perl is
nothing like 'local' in C, but more like the opposite. It is
used to change the value of a global variable for use locally.

In Perl you should use 'my' to localise variables.
 
B

Ben Morrow

Helgi Briem said:
Well, that probably explains most of it. 'local' in Perl is
nothing like 'local' in C, but more like the opposite. It is
used to change the value of a global variable for use locally.

In Perl you should use 'my' to localise variables.

While this is true, it shouldn't lead to memory leaks.

The usual reason for memory leaks is that you have data structures
with circular references---the simplest case is '$x = \$x'---which can
therefore never be garbage collected. You need to break these
references when you don't need them, either by undefing the variables
concerned or by using WeakRef from CPAN.

Ben
 
S

Stan Brown

Well, that probably explains most of it. 'local' in Perl is
nothing like 'local' in C, but more like the opposite. It is
used to change the value of a global variable for use locally.
In Perl you should use 'my' to localise variables.

Sorry if I was not clear here. I am of course, using my $var; to
declare these "local" variables, in each subroutine. I was not even
aware of the "local" keyword in perl, untill now.
 
S

Stan Brown

While this is true, it shouldn't lead to memory leaks.
The usual reason for memory leaks is that you have data structures
with circular references---the simplest case is '$x = \$x'---which can
therefore never be garbage collected. You need to break these
references when you don't need them, either by undefing the variables
concerned or by using WeakRef from CPAN.

Thanks. The latest one of these "long running" scripts to exhibit this
behavior, is really quite simple, in what it does, and has no real
complex data structures.

I suppose it would be inappropriate to post it here for criticism, right?
 
B

Ben Morrow

Stan Brown said:
Thanks. The latest one of these "long running" scripts to exhibit this
behavior, is really quite simple, in what it does, and has no real
complex data structures.

I suppose it would be inappropriate to post it here for criticism, right?

Well, if either it's pretty short or you can cut it down to something
as short as possible that still leaks (guess which is better :), then
I'm sure noone would mind...

Ben
 
C

ctcgag

Stan Brown said:
Thanks. The latest one of these "long running" scripts to exhibit this
behavior, is really quite simple, in what it does, and has no real
complex data structures.

I suppose it would be inappropriate to post it here for criticism, right?

As long as the script is short and strict, it wouldn't be at all
inappropriate. Does the script run full-bore for months, or is it some
kind of server-like thing that spends most of it's time waiting?

Xho
 
S

Stan Brown

As long as the script is short and strict, it wouldn't be at all
inappropriate. Does the script run full-bore for months, or is it some
kind of server-like thing that spends most of it's time waiting?

It does setup stuff (a lot of that), and then goes into a loop. In this
loop it does a system call to v4lctl to capture an image, then goes bacl to
sleep and waits. Curently it's one image every 10 seconds. Running since
moday, it had grown to a size of 1/2 a gig :-(
 
B

Ben Morrow

Stan Brown said:
It does setup stuff (a lot of that), and then goes into a loop. In this
loop it does a system call

This is a little confusing... when I first read it, I parsed it as
'system call' in the sense of something like fcntl(2). It would be
better to say 'it runs v4lctl with system()' or something :).
to v4lctl to capture an image, then goes bacl to
sleep and waits. Curently it's one image every 10 seconds. Running since
moday, it had grown to a size of 1/2 a gig :-(

What does it do with the image? Are you sure you aren't keeping them
all in memory somewhere by mistake?

Post just the loop for us to have a look at.

Ben
 
S

Stan Brown

It does setup stuff (a lot of that), and then goes into a loop. In this
loop it does a system call to v4lctl to capture an image, then goes bacl to
sleep and waits. Curently it's one image every 10 seconds. Running since
moday, it had grown to a size of 1/2 a gig :-(

At the risk of being flamed :-(, but because I can't really see anyway to
provide a useful example without showing all the code here it is:


_____

#!/usr/bin/perl -w

# "@(#)webcam.pl
#
# "%W% %E% %U%"; /* SCCS what string */
#
# webcam.pl
#
# 10-30-2003 SDB XXXXXXXXXXXXXXX
#
# Captures video images

use strict;
use AppConfig::File;
use IO::Handle;
use Getopt::Mixed "nextOption" ;
use Time::HiRes qw( gettimeofday tv_interval);
use Data::Dumper;
use Term::ANSIColor qw:)constants);
use Date::Calc qw( Today Day_of_Week );
use Time::Local;
use Time::CTime;
use Time::HiRes qw(gettimeofday);
use Image::Magick;
use File::path;
use File::lockf;
use Term::ANSIColor qw:)constants);
use Video::Capture::V4l;
use Imager;
use Devel::Leak;

# Config file name goes here
# May be modifed with -f <filename> at runtime
$::cfg_file = "/opt/local/lib/webcam.conf";

# Can be turned on at runtime with a -d
$::Debug=0;

$::OverRide_PID_File = 0;
$::Grab_Use_Internal = 1;


sub print_ussage() {
##################################################################
#
# Pritns a short summary of caommand line options
#
# NOTE: this should _only_ be called by Getop::Mixed, as we use
# arguments passed to us by it
#
###################################################################

print "$0 Called with an invalid option: $_[1]\n\n";

print "Valid options:\n";
print " [-f config file]\n";
print " [-d debug level]\n";
print " [-i] force use of internal video graber code\n";
print " [-e] force use of external v4lctl program to capture images\n";
print " [-F] Run even if PID file exists\n";

# Can't call clean_house() here, as we have not yet parsed command line
# arguments _or_ config file, and we don't know where our logfile is
exit;
}

sub parse_command_line() {
##################################################################
#
# parse command line arguments and sets global variables
# optionaly set there
#
###################################################################
# Ok, let's do the config thing
# Parse the command line arguments
my ($option, $value, $pretty);

my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;

print_debug(2,"Entering $function_name()\n",0,0);


Getopt::Mixed::init('F i e f=s d:i debug:i configfile=s');
$Getopt::Mixed::badOption = \&print_ussage;
while (($option, $value, $pretty) = nextOption()) {
if(( $option eq 'f') || ( $option eq 'configfile' ))
{
$::cfg_file = $value;
}
if(( $option eq 'd') || ( $option eq 'debug'))
{
$::Debug = 1;
if($value > 1)
{
$::Debug = $value;
}
}
if ($option eq 'F')
{
$::OverRide_PID_File = 1;
}
if ($option eq 'i')
{
$::Grab_Use_Internal = 1;
}
if ($option eq 'e')
{
$::Grab_Use_Internal = 0;
}
if ($::Debug >= 4)
{
print("option = $option\n");
print("value = $value\n");
print("pretty = $pretty\n");
}
}
Getopt::Mixed::cleanup();
print_debug(3,"Returning from $function_name()\n",0,0);
}

sub parse_config_file() {
##################################################################
#
# parse config file and sets global variables optionaly set there
#
#
###################################################################
# Ok, let's do the config thing
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;

print_debug(2,"Entering $function_name()\n",0,0);
my $tmp;
my $state = AppConfig::State->new(
{
CASE => 1,
PEDANTIC => 0,
GLOBAL => {
DEFAULT => '<undef>',
ARGCOUNT => 1,
EXPAND_UID => 1,
EXPAND_ENV => 1,
},
}
);
$state->define("webcam_pid_file",
{
DEFAULT => "webcam.pid",
});
$state->define("webcam_pid_directory",
{
DEFAULT => "/opt/local/run/",
});
$state->define("webcam_log_file",
{
DEFAULT => "/opt/local/log/webcam.log",
});
$state->define("dest_dir",
{
DEFAULT => "/usr/images",
});
$state->define("movie_maker_script",
{
DEFAULT => "/home/stan/make_movie.pl",
});
$state->define("camera_ID",
{
DEFAULT => "camera1",
});
$state->define("im_lbl_color",
{
DEFAULT => "blue",
});
$state->define("dest_file_template",
{
DEFAULT => "%H_%M_%S",
# DEFAULT => "%M_%S",
});
$state->define("dest_directory_template",
{
DEFAULT => "%B_%d_%Y",
# DEFAULT => "%Y_%B_%d_%H",
});
$state->define("video_dev",
{
DEFAULT => "/dev/video0",
});
$state->define("interval_time",
{
DEFAULT => 10,
});
$state->define("label_font_size",
{
DEFAULT => 14,
});
$state->define("video_type",
{
# DEFAULT => "Composite1",
DEFAULT => "Television",
});
$state->define("loglevel",
{
DEFAULT => 3,
});
if ( ! -r $::cfg_file)
{
print("I can't read the config file that you have specifed: $::cfg_file\n");
print("I have a set of hardcoded configuration defaults that I am using\n");
}
else
{
my $cfgfile = AppConfig::File->new($state, $::cfg_file);
}
# Now load all of these vaules into a hash for use
# by the rest of the code
$::config{im_lbl_color} = $state->get("im_lbl_color");
$::config{webcam_pid_file} = $state->get("webcam_pid_file");
$::config{webcam_pid_directory} = $state->get("webcam_pid_directory");
$::config{webcam_log_file} = $state->get("webcam_log_file");
$::config{dest_dir} = $state->get("dest_dir");
$::config{video_dev} = $state->get("video_dev");
$::config{video_type} = $state->get("video_type");
$::config{interval_time} = $state->get("interval_time");
$::config{loglevel} = $state->get("loglevel");
$::config{dest_file_template} = $state->get("dest_file_template");
$::config{dest_directory_template} = $state->get("dest_directory_template");
$::config{camera_ID} = $state->get("camera_ID");
$::config{movie_maker_script} = $state->get("movie_maker_script");
$::config{label_font_size} = $state->get("label_font_size");

# Build PID file that's specific to my camera ID
# and combine filename and directory name into a fully qualifed
# path name for later use
if ( $::config{webcam_pid_directory} =~ m'/$' )
{
# add trailing slash if necessary
$::config{webcam_pid_directordirectory} = join '' , $::config{webcam_pid_directory} , '/';
}
$tmp = join '' , $::config{webcam_pid_directory} , '/' , $::config{camera_ID} , '.' , $::config{webcam_pid_file};
$::config{webcam_pid_file} = $tmp;

# Check to see if supplied dirctory name has a trailing slash and add if it
# not
if ( ! ( $::config{dest_dir} =~ m'/$' ))
{
# add trailing slash if necessary
$::config{dest_dir} = join '' , $::config{dest_dir} , '/';
}
$::config{dest_dir} = join '' , $::config{dest_dir} , $::config{camera_ID} , '/';
print_debug(3,"Returning from $function_name()\n",0,0);
}

sub logit($$$) {
##################################################################
#
# Log Status/Warning/Error messages
# Opens and closes the file each time, in case someone
# has selected the same logfile for both tasks
#
# Argument 1 is the class
# 1 = ERROR
# 2 = WARNING
# 3 = STATUS
#
# Argument 2 is the logfile name as a string
#
# Argument 3 is the message
#
# Note that the camera ID is added to the message
#
##################################################################
my $status = $_[0];
my $filename = $_[1];
my $msg = $_[2];
my $dayetime;
my $mstat;
my $datetime;
my $lock;
my $lck_status;
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;

print_debug(2,"Entering $function_name()\n",0,0);
print_debug(3,"$argtmp\n",0,0);

open FH, ">/tmp/webcam.log.lck";
$lock = new File::lockf(\*FH);

# Try to get a lock for writing
#
# Tries 3 times, waiting 1 second between each atempt
# If the lock atempt fails it comes back with
# a Non-Zero status.
$lck_status = $lock->slock(3, 1, 0);
if($lck_status ne 0)
{
#failure
print "Failed to obtain lock on logfile!!!!\n";
close FH;
unlink("/tmp/webcam.log.lck");
return ();
}
else
{
# got the lock
open( LOGFILE , ">>$filename");
LOGFILE->autoflush(1);

if($status == 1)
{
$mstat = "ERROR";
}
if($status == 2)
{
$mstat = "WARNING";
}
if($status == 3)
{
$mstat = "STATUS";
}
if($status > 3)
{
$mstat = "INFO";
}
if($::config{loglevel} >= $status)
{
$datetime = localtime();
print LOGFILE ("$0 PID $$ ID $::config{camera_ID} $datetime $mstat: $msg\n");
}
close LOGFILE;
print_debug(3,"Returning from $function_name()\n",0,0);
}
File::lockf::ulock FH;
close FH;
unlink("/tmp/webcam.log.lck");
}

sub clean_house($) {
##################################################################
#
# Dose end of program file closing and gnereal cleanup
#
###################################################################
my $remove_run_file = $_[0];
my $function_name = (caller(0))[3];
print_debug(2,"Entering $function_name()\n",0,0);

logit(1,
$::config{webcam_log_file},
"Exiting");
if ($remove_run_file == 1)
{
unlink($::config{webcam_pid_file});
}
exit;
}


sub addtime($$$$$) {
##################################################################
#
# reads in temporary capture file adds timestamp, and writes
# it to the permanent location
#
# Argument 1 is filename that the labled image should be stored as
#
# Argument 2 is the label to apply
#
# Argument 3 is the filename that the image is curently in
#
# Argument 4 is the color to label the image with
#
# Argument 5 is the font size to use for the label
#
###################################################################
my $final_filename = $_[0];
my $l_tstamp = $_[1];
my $l_tmpfile = $_[2];
my $l_lbl_color = $_[3];
my $l_lbl_size = $_[4];
my $image = Image::Magick->new(magick=>'GIF',font=>'clean');
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;

print_debug(2,"Entering $function_name()\n",0,0);
print_debug(3,"$argtmp\n",0,0);

$image->Read($l_tmpfile);

#On ajoute le text
$image->Annotate(fill=>'whie',
pointsize=>$l_lbl_size,
text=>$l_tstamp,
gravity=>'SouthWest',
stroke=>$l_lbl_color,
fill=>'black',
y=>(int($l_lbl_size * 1.4)));


#On écrit le fichier
$image->Write($final_filename);
print_debug(3,"Returning from $function_name()\n",0,0);
}

sub print_debug($$$$) {
##################################################################
#
# Print debug message to STDERR with appropriate number
# of leading "-"s to show level of debuging required
# to invoke this message
#
# Argument 1 is the debuging level required to get this mesage
# Argument 2 is the message
# Argument 3 is a flag to get a datestamp
# Argument 4 is a flag to get PID printed
#
##################################################################
my ($level, $msg, $need_date, $pid_flag) = @_;
my $leader = '';
my $datetime = '';
my $i = 0;

STDERR->autoflush(1);
if ($::Debug >= $level)
{
if($pid_flag == 1)
{
$leader = " PID->$$: "
}
for ($i = 1; $i <= $level; $i++) {
$leader = "$leader-";
}
$leader = "$leader ";
$msg = "$leader$msg";
if ($need_date == 1)
{
$datetime = localtime();
# Yes, the leading space is on purpose
# It helps to sort out these from the other
# noise the program may be putting ot
# If I asked for a datestamp, then I'm probably
# be scaning through the noise, looking for timeing
# rleationships
print STDERR (" $0: $datetime: $msg");
}
else
{
print STDERR ("$0: $msg");
}
}
}

sub grab_one($$) {
##################################################################
#
# grab_one
#
# Grabs one frame from video capture card
#
# Argument 1 is the name of the file to save to
#
# Argument 2 is the video object
#
# Retruns 1 if capture succceded, 0 otherwise
#
##################################################################
my $l_tmpfile = $_[0];
my $grab = $_[1];
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;
print_debug(2,"Entering $function_name()\n",0,0);
print_debug(3,"$argtmp\n",0,0);
my $fr;
my $temp = '';
$| = 1;
my $frame = 0;
my $count = 0;

$fr = $grab->capture( $frame, 844 , 576 );

for ( 0 .. 1 ) {
my $nfr = $grab->capture( 1 - $frame, 844, 576 );
if ( ! $grab->sync($frame))
{
logit(1,
$::config{webcam_log_file},
"Can't synch this frame");
return(0);
}
unless ( $count == 0 ) {

# save $fr now, as it contains the raw BGR data
$temp = '';
if( ! open( JP, '>', \$temp ))
{
logit(1,
$::config{webcam_log_file},
"Can't Open temporary file $temp");
return(0);
}
print JP "P6\n840 576\n255\n"; #header
$nfr = reverse $nfr;
print JP $nfr;
close JP;

my $img = Imager->new();
if ( ! $img->read( data => $temp, type => 'pnm' ))
{
logit(1,
$::config{webcam_log_file},
"$img->errstr()");
}
$img->flip( dir => "hv" );
if ( ! $img->write( data => \$temp, type => 'jpeg' ))
{
logit(1,
$::config{webcam_log_file},
"$img->errstr()");
}
}
$count++;
$frame = 1 - $frame;
$fr = $nfr;
} # endfor

# Save it
if( ! open( JP, "> $l_tmpfile" ))
{
logit(1,
$::config{webcam_log_file},
"Can't Open temporary file $l_tmpfile");
return(0);
}
print JP $temp;
close JP;
print_debug(3,"Returning from $function_name()\n",0,0);
return(1);
}

sub init_video($) {
##################################################################
#
# init_video
#
# set up capture card initialy
#
# Argument 1 is the ID of the card
#
##################################################################
my $l_video_dev = $_[0];
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;

print_debug(2,"Entering $function_name()\n",0,0);
print_debug(3,"$argtmp\n",0,0);

my $grab = new Video::Capture::V4l($l_video_dev)
or die "Unable to open Videodevice: $!";

# the following initializes the camera for NTSC
my $channel = $grab->channel(0);
my $tuner = $grab->tuner(0);
$tuner->mode(1);
$channel->norm(1);
$tuner->set;
$channel->set;


print_debug(3,"Returning from $function_name()\n",0,0);
return($grab);
}


# main()
my @t;
my @fields;
my $tt;
my $incd;
my $my_pid;
my $handle;
my $filename;
my $last_field;
my $grab;
my $good_frame;
my $sleep_time;
my ($last_trigger_time, $grab_time);
my ($movie_dirname , $movie_filename);
my ($tmp , $tmp2);
my ($dcount, $ndcount);
my $timestamp;
my $dirname = '';
my $prev_dirname = '';
my $tmpfile = "/tmp/webcam$$.jpeg";

parse_command_line();
parse_config_file();

if($::OverRide_PID_File != 1)
{
if( -r $::config{webcam_pid_file})
{
# add log event here.
logit(3,
$::config{webcam_log_file},
"Can'r run because $::config{webcam_pid_file} exists, and th -F flag was not specifed");
print "I see a PID file for my camera ID exists already\n";
print "So, it appears thta there is already a copy of me running\n";
print "If this is incorrect, you can either remove $::config{webcam_pid_file}\n";
print "Or use the -F argument on the command line, when you start me\n";
clean_house(0);
}
}

# Create the run file, also used for signaling me to shutdown
# Removal of this file by an external
# entity (task, person) is the prefered way of cleanly terminating
# this program
$my_pid = $$;
# Write my PID to the run status file
open( PIDFILE , ">$::config{webcam_pid_file}");
print PIDFILE "$my_pid\n";
close PIDFILE;

logit(3,
$::config{webcam_log_file},
"Started");


# FIXME
if ($::Grab_Use_Internal != 1)
{
system("/usr/bin/v4lctl -c $::config{video_dev} setinput $::config{video_type}");
}
else
{
$grab = init_video($::config{video_dev});
}

$dcount = Devel::Leak::NoteSV($handle);
while (1) # Forever
{

# This program inherently will run forever
# To cause it to stop, remove it's pid file
if( ! (-r $::config{webcam_pid_file}))
{
last;
}
$last_trigger_time = gettimeofday;
logit(6,
$::config{webcam_log_file},
"Start of loop, elapsed time in this capture 0 seconds");


# if $dirname contains a / then it must have already been set up
# so we need to save a copy that will be used later
# # to check to se if it has been changed
# we use this to trigger directory completion processing
if ( $dirname =~ m'[^/]' )
{
$prev_dirname = $dirname;
}


# Build directory name
@t = localtime(time);
$dirname = strftime $::config{dest_directory_template} , @t;
$dirname = join '' , $::config{dest_dir} , $dirname , '/';

# build filename
$filename = strftime $::config{dest_file_template} , @t;
$filename = join '' , $filename , '.jpeg';

# Does the destination directory exist?
if( ! (-r $dirname))
{
# No, need to create it
# This is also the place to add any processing that
# may be required at directory creation time
logit(3,
$::config{webcam_log_file},
"Need to create new directory $dirname");
eval { mkpath($dirname) };
if ($@)
{
logit(1,
$::config{webcam_log_file},
"Failed to create new directory $dirname");
print "Failed to creat directory $dirname\n";
clean_house(1);
}
# Ok we've created the new directory
# Were we using one before? Or is this initial
# startup ?
if ( $prev_dirname =~ m'/$' )
{
if(-r $prev_dirname)
{
# Post directory fill processing goes hee
# Trigger mpeg creation here
# Build directory name
$movie_dirname = $::config{dest_dir};
# Does the destination directory exist?
if( ! (-r $movie_dirname))
{
# No, need to create it
logit(3,
$::config{webcam_log_file},
"Need to create new directory $movie_dirname");
eval { mkpath($movie_dirname) };
if ($@)
{
logit(1,
$::config{webcam_log_file},
"Failed to create new directory $movie_dirname");
print "Failed to create directory $dirname\n";
clean_house(1);
}
}
@fields = split "/", $prev_dirname;
$last_field = $fields[(scalar(@fields) - 1)];
$movie_filename = join '' , $last_field , ".mpeg";
logit(3,
$::config{webcam_log_file},
"Creating new movie file from the contents of directory $prev_dirname it's filename will be $movie_filename. It will be placed in $movie_dirname");
system("$::config{movie_maker_script} -s $prev_dirname -p $movie_dirname -c $movie_filename &");
}
}
}

# trigger capture here
$tt = gettimeofday-$last_trigger_time;
logit(6,
$::config{webcam_log_file},
"Elapsed time just before capture is called $tt");
if ($::Grab_Use_Internal != 1)
{
system("/usr/bin/v4lctl -c $::config{video_dev} snap jpeg 844x576 $tmpfile");
$good_frame = 1;
}
else
{
$good_frame = grab_one($tmpfile,$grab);
}
$tt = gettimeofday-$last_trigger_time;
logit(6,
$::config{webcam_log_file},
"Elapsed time just after capture is called $tt");

if( $good_frame == 1)
{
# Create string to label image with
$timestamp = scalar(localtime(time));
$tmp = join '' , $dirname, $filename;
$tmp2 = join '' , ' ' ,$::config{camera_ID} , ' - ' , $timestamp;
addtime($tmp,
$tmp2,
$tmpfile,
$::config{im_lbl_color},
$::config{label_font_size});
}
unlink($tmpfile);
$tt = gettimeofday-$last_trigger_time;
logit(6,
$::config{webcam_log_file},
"Elapsed time just after timestamping $tt");

$grab_time = gettimeofday-$last_trigger_time;
$sleep_time = $::config{interval_time} - $grab_time;
$grab_time = sprintf "%0.9f" , $grab_time;
$sleep_time = sprintf "%0.9f" , $sleep_time;
if ($sleep_time < (0.5 * $::config{interval_time})) # < 50%
{
print BOLD RED ON_WHITE "Grab time = $grab_time Sleep time = $sleep_time";
}
else
{
if ($sleep_time < (0.7 * $::config{interval_time})) # > 50% < 70%
{
print BOLD RED ON_BLACK "Grab time = $grab_time Sleep time = $sleep_time";
}
else # > 70%
{
print BOLD BLUE ON_BLACK "Grab time = $grab_time Sleep time = $sleep_time";
}

}
print "\n";
logit(3,
$::config{webcam_log_file},
"Total time to capture and procees this image $grab_time seconds");
logit(4,
$::config{webcam_log_file},
"Need to sleep for $sleep_time seconds");
if($sleep_time < 1)
{
logit(1,
$::config{webcam_log_file},
"You're pushing it buster, I almost didn't get back to grab a frame");
}
if($sleep_time <= 0)
{
logit(1,
$::config{webcam_log_file},
"Frame missed due to system load!");
}

# The standard high resolution timer, sleeps for the value in the last
# argument in seconds.
select undef, undef, undef, $sleep_time;
$ndcount = Devel::Leak::CheckSV($handle);
if($dcount != $ndcount)
{
$incd = $ndcount - $dcount;
print "------> $incd more objects found\n";
}
$dcount = Devel::Leak::NoteSV($handle);
}

logit(3,
$::config{webcam_log_file},
"Normal exit");
clean_house(1);
 
S

Stan Brown

This is a little confusing... when I first read it, I parsed it as
'system call' in the sense of something like fcntl(2). It would be
better to say 'it runs v4lctl with system()' or something :).
What does it do with the image? Are you sure you aren't keeping them
all in memory somewhere by mistake?

Well, I don't think so, it's writen to a file, and the actual capture is
done in a subrotuine, so all of it's variable should go out of scope upon
retrun from that subrotuine, right?
Post just the loop for us to have a look at.

Oops!

Sorry, I should have read this _before_ posting the whole thing :-(

I'll avoid the temptation to post just the loop, again :)
 
M

Michele Ouellet

It does setup stuff (a lot of that), and then goes into a loop. In this
loop it does a system call to v4lctl to capture an image, then goes bacl to
sleep and waits. Curently it's one image every 10 seconds. Running since
moday, it had grown to a size of 1/2 a gig :-(

Hi Everyone,

I am no Perl guru and not at all familiar with memory management under Linux
or Unix. But I have experience with images.

Have you considered that the problem may be memory fragmentation rather than
a memory leak? Images typically require large CONTIGUOUS blocks of memory
so, if the memory manager des not occasional compact free memory, that kind
of situation can easily occur. I have seen this with older versions of
Windows, such as Windows 95 and Windows 98.

If your images are all of the same size, fragmentation is less likely, but
otherwise...

If fragmentation is impossible, I will be glad to know this. Otherwise, you
might have to write your own memory manager for your images.

My two bits,

Michèle Ouellet
Stelvio Inc.
 
S

Stan Brown

Hi Everyone,
I am no Perl guru and not at all familiar with memory management under Linux
or Unix. But I have experience with images.
Have you considered that the problem may be memory fragmentation rather than
a memory leak? Images typically require large CONTIGUOUS blocks of memory
so, if the memory manager des not occasional compact free memory, that kind
of situation can easily occur. I have seen this with older versions of
Windows, such as Windows 95 and Windows 98.

I can't see how that would cause the size of teh perl script process to
grow.

Or perhaps I'm missing something here?
 
B

Ben Morrow

Stan Brown said:
I can't see how that would cause the size of teh perl script process to
grow.

Or perhaps I'm missing something here?

If you have a braindead memory manager like Win9x's which never
compacts, then what can happen is this:

1. Perl requests a 10Mb (say) block for an image. The process's
address space is increased by 10Mb.

2. Perl frees the image. The 10Mb goes back into the process's free
space pool (note that it does not go back to the OS: in general,
a process's address space never shrinks).

3. Perl requests some more small allocations, which get made out of
the now free 10Mb block.

4. Perl requests the next 10Mb block. There is now no continuous block
of memory that large in the process's free space pool, as the one
we released last time now has some small allocations somewhere in
the middle. So we increase the process size by another 10Mb.

5. Goto 2.

This shouldn't happen under any decent OS, as the malloc
implementation should detect that fragmentation is occurring and
compact the free space pool.
 
S

Stan Brown

This is a little confusing... when I first read it, I parsed it as
'system call' in the sense of something like fcntl(2). It would be
better to say 'it runs v4lctl with system()' or something :).
What does it do with the image? Are you sure you aren't keeping them
all in memory somewhere by mistake?
Post just the loop for us to have a look at.

Well, since I aparantely ofended all of you by posting it all, as I judge
from zero reolies, here is the cut down version:


#!/usr/bin/perl -w

# "@(#)webcam.pl
#
# "%W% %E% %U%"; /* SCCS what string */
#
# webcam.pl
#
# 10-30-2003 SDB XXXXXXXXXXXXXXX
#
# Captures video images

use strict;
use AppConfig::File;
use IO::Handle;
use Getopt::Mixed "nextOption" ;
use Time::HiRes qw( gettimeofday tv_interval);
use Data::Dumper;
use Term::ANSIColor qw:)constants);
use Date::Calc qw( Today Day_of_Week );
use Time::Local;
use Time::CTime;
use Time::HiRes qw(gettimeofday);
use Image::Magick;
use File::path;
use File::lockf;
use Term::ANSIColor qw:)constants);
use Video::Capture::V4l;
use Imager;
use Devel::Leak;

# Config file name goes here
# May be modifed with -f <filename> at runtime
$::cfg_file = "/opt/local/lib/webcam.conf";

# Can be turned on at runtime with a -d
$::Debug=0;

$::OverRide_PID_File = 0;
$::Grab_Use_Internal = 1;



sub addtime($$$$$) {
##################################################################
#
# reads in temporary capture file adds timestamp, and writes
# it to the permanent location
#
# Argument 1 is filename that the labled image should be stored as
#
# Argument 2 is the label to apply
#
# Argument 3 is the filename that the image is curently in
#
# Argument 4 is the color to label the image with
#
# Argument 5 is the font size to use for the label
#
###################################################################
my $final_filename = $_[0];
my $l_tstamp = $_[1];
my $l_tmpfile = $_[2];
my $l_lbl_color = $_[3];
my $l_lbl_size = $_[4];
my $image = Image::Magick->new(magick=>'GIF',font=>'clean');
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;

print_debug(2,"Entering $function_name()\n",0,0);
print_debug(3,"$argtmp\n",0,0);

$image->Read($l_tmpfile);

#On ajoute le text
$image->Annotate(fill=>'white',
pointsize=>$l_lbl_size,
text=>$l_tstamp,
gravity=>'SouthWest',
stroke=>$l_lbl_color,
fill=>'black',
y=>(int($l_lbl_size * 1.4)));


#On écrit le fichier
$image->Write($final_filename);
print_debug(3,"Returning from $function_name()\n",0,0);
}


sub grab_one($$) {
##################################################################
#
# grab_one
#
# Grabs one frame from video capture card
#
# Argument 1 is the name of the file to save to
#
# Argument 2 is the video object
#
# Retruns 1 if capture succceded, 0 otherwise
#
##################################################################
my $l_tmpfile = $_[0];
my $grab = $_[1];
my $function_name = (caller(0))[3];
my $argtmp = join ', ', map "Arg$_ " .
( defined $_[$_] ? "->$_[$_]<-" :
'*UNDEF*'), 0 .. $#_;
print_debug(2,"Entering $function_name()\n",0,0);
print_debug(3,"$argtmp\n",0,0);
my $fr;
my $temp = '';
$| = 1;
my $frame = 0;
my $count = 0;

$fr = $grab->capture( $frame, 844 , 576 );

for ( 0 .. 1 ) {
my $nfr = $grab->capture( 1 - $frame, 844, 576 );
if ( ! $grab->sync($frame))
{
logit(1,
$::config{webcam_log_file},
"Can't synch this frame");
return(0);
}
unless ( $count == 0 ) {

# save $fr now, as it contains the raw BGR data
$temp = '';
if( ! open( JP, '>', \$temp ))
{
logit(1,
$::config{webcam_log_file},
"Can't Open temporary file $temp");
return(0);
}
print JP "P6\n840 576\n255\n"; #header
$nfr = reverse $nfr;
print JP $nfr;
close JP;

my $img = Imager->new();
if ( ! $img->read( data => $temp, type => 'pnm' ))
{
logit(1,
$::config{webcam_log_file},
"$img->errstr()");
}
$img->flip( dir => "hv" );
if ( ! $img->write( data => \$temp, type => 'jpeg' ))
{
logit(1,
$::config{webcam_log_file},
"$img->errstr()");
}
}
$count++;
$frame = 1 - $frame;
$fr = $nfr;
} # endfor

# Save it
if( ! open( JP, "> $l_tmpfile" ))
{
logit(1,
$::config{webcam_log_file},
"Can't Open temporary file $l_tmpfile");
return(0);
}
print JP $temp;
close JP;
print_debug(3,"Returning from $function_name()\n",0,0);
return(1);
}


# main()
my @t;
my @fields;
my $tt;
my $incd;
my $my_pid;
my $handle;
my $filename;
my $last_field;
my $grab;
my $good_frame;
my $sleep_time;
my ($last_trigger_time, $grab_time);
my ($movie_dirname , $movie_filename);
my ($tmp , $tmp2);
my ($dcount, $ndcount);
my $timestamp;
my $dirname = '';
my $prev_dirname = '';
my $tmpfile = "/tmp/webcam$$.jpeg";

if ($::Grab_Use_Internal != 1)
{
system("/usr/bin/v4lctl -c $::config{video_dev} setinput $::config{video_type}");
}
else
{
$grab = init_video($::config{video_dev});
}

$dcount = Devel::Leak::NoteSV($handle);
while (1) # Forever
{

# This program inherently will run forever
# To cause it to stop, remove it's pid file
if( ! (-r $::config{webcam_pid_file}))
{
last;
}
$last_trigger_time = gettimeofday;
logit(6,
$::config{webcam_log_file},
"Start of loop, elapsed time in this capture 0 seconds");


# if $dirname contains a / then it must have already been set up
# so we need to save a copy that will be used later
# # to check to se if it has been changed
# we use this to trigger directory completion processing
if ( $dirname =~ m'[^/]' )
{
$prev_dirname = $dirname;
}


# Build directory name
@t = localtime(time);
$dirname = strftime $::config{dest_directory_template} , @t;
$dirname = join '' , $::config{dest_dir} , $dirname , '/';

# build filename
$filename = strftime $::config{dest_file_template} , @t;
$filename = join '' , $filename , '.jpeg';

# Does the destination directory exist?
if( ! (-r $dirname))
{
# No, need to create it
# This is also the place to add any processing that
# may be required at directory creation time
logit(3,
$::config{webcam_log_file},
"Need to create new directory $dirname");
eval { mkpath($dirname) };
if ($@)
{
logit(1,
$::config{webcam_log_file},
"Failed to create new directory $dirname");
print "Failed to creat directory $dirname\n";
clean_house(1);
}
# Ok we've created the new directory
# Were we using one before? Or is this initial
# startup ?
if ( $prev_dirname =~ m'/$' )
{
if(-r $prev_dirname)
{
# Post directory fill processing goes hee
# Trigger mpeg creation here
# Build directory name
$movie_dirname = $::config{dest_dir};
# Does the destination directory exist?
if( ! (-r $movie_dirname))
{
# No, need to create it
logit(3,
$::config{webcam_log_file},
"Need to create new directory $movie_dirname");
eval { mkpath($movie_dirname) };
if ($@)
{
logit(1,
$::config{webcam_log_file},
"Failed to create new directory $movie_dirname");
print "Failed to create directory $dirname\n";
clean_house(1);
}
}
@fields = split "/", $prev_dirname;
$last_field = $fields[(scalar(@fields) - 1)];
$movie_filename = join '' , $last_field , ".mpeg";
logit(3,
$::config{webcam_log_file},
"Creating new movie file from the contents of directory $prev_dirname it's filename will be $movie_filename. It will be placed in $movie_dirname");
system("$::config{movie_maker_script} -s $prev_dirname -p $movie_dirname -c $movie_filename &");
}
}
}

# trigger capture here
$tt = gettimeofday-$last_trigger_time;
logit(6,
$::config{webcam_log_file},
"Elapsed time just before capture is called $tt");
if ($::Grab_Use_Internal != 1)
{
system("/usr/bin/v4lctl -c $::config{video_dev} snap jpeg 844x576 $tmpfile");
$good_frame = 1;
}
else
{
$good_frame = grab_one($tmpfile,$grab);
}
$tt = gettimeofday-$last_trigger_time;
logit(6,
$::config{webcam_log_file},
"Elapsed time just after capture is called $tt");

if( $good_frame == 1)
{
# Create string to label image with
$timestamp = scalar(localtime(time));
$tmp = join '' , $dirname, $filename;
$tmp2 = join '' , ' ' ,$::config{camera_ID} , ' - ' , $timestamp;
addtime($tmp,
$tmp2,
$tmpfile,
$::config{im_lbl_color},
$::config{label_font_size});
}
unlink($tmpfile);
$tt = gettimeofday-$last_trigger_time;
logit(6,
$::config{webcam_log_file},
"Elapsed time just after timestamping $tt");

$grab_time = gettimeofday-$last_trigger_time;
$sleep_time = $::config{interval_time} - $grab_time;
$grab_time = sprintf "%0.9f" , $grab_time;
$sleep_time = sprintf "%0.9f" , $sleep_time;
if ($sleep_time < (0.5 * $::config{interval_time})) # < 50%
{
print BOLD RED ON_WHITE "Grab time = $grab_time Sleep time = $sleep_time";
}
else
{
if ($sleep_time < (0.7 * $::config{interval_time})) # > 50% < 70%
{
print BOLD RED ON_BLACK "Grab time = $grab_time Sleep time = $sleep_time";
}
else # > 70%
{
print BOLD BLUE ON_BLACK "Grab time = $grab_time Sleep time = $sleep_time";
}

}
print "\n";
logit(3,
$::config{webcam_log_file},
"Total time to capture and procees this image $grab_time seconds");
logit(4,
$::config{webcam_log_file},
"Need to sleep for $sleep_time seconds");
if($sleep_time < 1)
{
logit(1,
$::config{webcam_log_file},
"You're pushing it buster, I almost didn't get back to grab a frame");
}
if($sleep_time <= 0)
{
logit(1,
$::config{webcam_log_file},
"Frame missed due to system load!");
}

# The standard high resolution timer, sleeps for the value in the last
# argument in seconds.
select undef, undef, undef, $sleep_time;
$ndcount = Devel::Leak::CheckSV($handle);
if($dcount != $ndcount)
{
$incd = $ndcount - $dcount;
print "------> $incd more objects found\n";
}
$dcount = Devel::Leak::NoteSV($handle);
}

logit(3,
$::config{webcam_log_file},
"Normal exit");
clean_house(1);


No matter whether this is run with the "internal" graber, or the external
system(0 call to v4lctl it grows rapidly.

What am I doing wrong.
 
B

Ben Morrow

Stan Brown said:
Well, since I aparantely ofended all of you by posting it all, as I judge
from zero reolies, here is the cut down version:

Well, speaking for myself, I was hardly offended :). I just couldn't
see anything obvious, and didn't really feel like trying to understand
all that code.
use strict;
use AppConfig::File;
use IO::Handle;
use Getopt::Mixed "nextOption" ;
use Time::HiRes qw( gettimeofday tv_interval);
use Data::Dumper;
use Term::ANSIColor qw:)constants);
use Date::Calc qw( Today Day_of_Week );
use Time::Local;
use Time::CTime;
use Time::HiRes qw(gettimeofday);
use Image::Magick;
use File::path;
use File::lockf;
use Term::ANSIColor qw:)constants);
use Video::Capture::V4l;
use Imager;
use Devel::Leak;

Part of providing a minimal example is removing all modules that can
be removed while still leaking. IMHO (and not really having much
justification for this beyond instinct), the only modules likely to
cause leaks here are Image::Magick, Imager and V::C::V4l. As you say
below that it still leaks if you use system() to run v4lctl, I reckon
your problem may be with Image::Magick. What happens if you just run
your addtime() routine in a loop?

If that doesn't leak, then try again, cutting out *absolutely*
*everything* you can that doesn't stop the leak.
$::cfg_file = "/opt/local/lib/webcam.conf";

On an unrelated subject, doing this rather defeats the point of
strictures. You shoould write

our $cfg_file = "/opt/local/lib/webcam.conf";

and then refer to $cfg_file thereafter.

Ben
 
S

Stan Brown

On an unrelated subject, doing this rather defeats the point of
strictures. You shoould write
our $cfg_file = "/opt/local/lib/webcam.conf";
and then refer to $cfg_file thereafter.

Thanks, that ugliness had been bothering me for years, but I didn't
understand how to clean it up.

Tha tip is very much appreciated!
 
S

Stan Brown

Part of providing a minimal example is removing all modules that can
be removed while still leaking. IMHO (and not really having much
justification for this beyond instinct), the only modules likely to
cause leaks here are Image::Magick, Imager and V::C::V4l. As you say
below that it still leaks if you use system() to run v4lctl, I reckon
your problem may be with Image::Magick. What happens if you just run
your addtime() routine in a loop?

Good catch, I replaced the addtiem subroutine with a simple rename call,
which does aeverything that the original subroutine does _except_ adding
the timestamp to the image, and that appears to ahve stoped teh memory
leak.

I grabed the majority of the code for that loop from a perl script that I
found on one of my debian machines. Unfortunately teh comments were in
French, which I don't speak, so perhaps I munged up the use of it.

I'm enclosing a copyt of just thta subroutine, in the hope that someone can
point out how I'm miss using it. Or sugest an alternative way of doing the
same thing.

Thanks for everyone's patienace with thie!



sub addtime($$$$$) {
##################################################################
#
# reads in temporary capture file adds timestamp, and writes
# it to the permanent location
#
# Argument 1 is filename that the labled image should be stored as
#
# Argument 2 is the label to apply
#
# Argument 3 is the filename that the image is curently in
#
# Argument 4 is the color to label the image with
#
# Argument 5 is the font size to use for the label
#
###################################################################
my $final_filename = $_[0];
my $l_tstamp = $_[1];
my $l_tmpfile = $_[2];
my $l_lbl_color = $_[3];
my $l_lbl_size = $_[4];
my $image = Image::Magick->new(magick=>'GIF',font=>'clean');

$image->Read($l_tmpfile);

#On ajoute le text
$image->Annotate(fill=>'white',
pointsize=>$l_lbl_size,
text=>$l_tstamp,
gravity=>'SouthWest',
stroke=>$l_lbl_color,
fill=>'black',
y=>(int($l_lbl_size * 1.4)));


#On écrit le fichier
$image->Write($final_filename);
}

The call to this subroutine is followed (in main() imediately by:


unlink($tmpfile);

Anyone see anything wrong with this?
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Members online

No members online now.

Forum statistics

Threads
473,744
Messages
2,569,484
Members
44,903
Latest member
orderPeak8CBDGummies

Latest Threads

Top