| View previous topic :: View next topic |
| Author |
Message |
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
 Posted: Tue Apr 18, 2006 3:34 pm Post subject: Stream viewer for perl Tk (winders/linux) |
 |
|
I took some inspiration from Mark from his website, and added to it to support 4 (or more) viewers. To add more than 4 viewers you'll need to edit the source code in this.
| Code: |
#!/usr/bin/perl -slw
# Origional:
# http://www.awe.com/ha/multipart.html
# Test program to decode the multipart-replace stream that
# ZoneMinder sends. It's a hack for this stream only though
# and could be easily improved. For example we ignore the
# Content-Length.
#
# Mark J Cox, mark@awe.com, February 2006
# ---
# Added onto by Russ Handorf to support multiple "monitors"
# Russ Handorf, rhandorf@handorf.org, April 2006
# Thanks to BrowserUK and perlmonks for the wonderous teachings of threads!
use Tk;
use Tk::JPEG;
use LWP::UserAgent;
use MIME::Base64;
use IO::Socket;
use threads;
use threads::shared;
my $user="webusername";
my $pass="webpassword";
my $host = 'someipaddress';
my @urls = ("/cgi-bin/nph-zms?mode=jpeg&monitor=1&scale=100&maxfps=5&user=$user&pass=$pass", "/cgi-bin/nph-zms?mode=jpeg&monitor=2&scale=100&maxfps=5&user=$user&pass=$pass", "/cgi-bin/nph-zms?mode=jpeg&monitor=3&scale=100&maxfps=5&user=$user&pass=$pass", "/cgi-bin/nph-zms?mode=jpeg&monitor=4&scale=100&maxfps=5&user=$user&pass=$pass");
my @data :shared = ('') x 4; ## 4 shared image data buffers
my @flags :shared = (0) x 4; ## 4 shared 'image ready' flags
sub loadJpg {
my( $host, $url, $no, $dataref ) = @_;
next if $flags[ $no ]; ## If the flag is still set do nothing
#load the image
my $sock = IO::Socket::INET->new(PeerAddr=>$host,Proto=>'tcp',PeerPort=>80,);
return unless defined $sock;
$sock->autoflush(1);
print $sock "GET $url HTTP/1.0\r\nHost: $host\r\n\r\n";
my $status = <$sock>;
die unless ($status =~ m|HTTP/\S+\s+200|);
my ($grab,$jpeg,$data,$image,$thisbuf,$lastimage);
while (my $nread = sysread($sock, $thisbuf, 4096)) {
$grab .= $thisbuf;
if ( $grab =~ s/(.*?)\n--ZoneMinderFrame\r\n//s ) {
$jpeg .= $1;
$jpeg =~ s/--ZoneMinderFrame\r\n//; # Heh, what a
$jpeg =~ s/Content-Length: \d+\r\n//; # Nasty little
$jpeg =~ s/Content-Type: \S+\r\n\r\n//; # Hack
#$data = encode_base64($jpeg);
$data=$jpeg;
## copy to the appropriate shared buffer
$dataref->[ $no ] = $data;
## Set the appropriate 'image ready' flag
$flags[ $no ] = 1;
$lastimage->delete if ($lastimage); #essential as Photo leaks!
$lastimage = $image;
undef $jpeg;
undef $data;
}
$jpeg .= $1 if ($grab =~ s/(.*)(?=\n)//s);
}
}
## Start the threads passing
## The host, url, buffer/flag number and buffer reference
my @threads = map{
threads->new( \&loadJpg, $host, $urls[ $_ ], $_, \@data );
} 0 .. 3;
my $stop = 0;
my $mw = MainWindow->new(title=>"Cams");
$mw->minsize( qw(640 480));
my $top = $mw->Frame()->pack(-side=>'top');
my $bottom = $mw->Frame()->pack(-side=>'bottom');
## Use an array, indexed by passed number
my @photos = (
$top->Label()->pack(-side => 'left'),
$top->Label()->pack(-side => 'right'),
$bottom->Label()->pack(-side => 'left'),
$bottom->Label()->pack(-side => 'right'),
);
$mw->Button(-text=>"Stop",-command => sub { exit; })->pack();
## Set up a regular callback in the main thread that
## a) checks the flags for each image
## and if it is set
## b) Locks the data
## c) Encodes the data
## d) Creates a Photo object from it
## e) Sets it into the widget
## f) Clears the flag ready for the next
$mw->repeat( 1000, sub{
for my $n ( 0 .. 3 ) {
if( $flags[ $n ] ) {
lock( @data );
my $data = encode_base64( $data[ $n ] );
$image[ $n ]->delete if $image[ $n ]; ## Addendum:
$image[ $n ] = $mw->Photo( -format=>'jpeg', -data=>$data );
$photos[ $n ]->configure( -image => $image[ $n ] );
$flags[ $n ] = 0;
}
}
} );
MainLoop;
|
|
|
| Back to top |
|
 |
|
|
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
| Posted: Tue Apr 18, 2006 5:34 pm Post subject: |
|
|
| Well, I regret to report that there is a memory leak somewhere in there. I think I know where it is though and will report the fix when I get it. |
|
| Back to top |
|
|
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
| Posted: Tue Apr 18, 2006 7:06 pm Post subject: |
|
|
the leak has to do with the following two lines
$image[ $n ]->delete if $image[ $n ]; ## Addendum:
$image[ $n ] = $mw->Photo( -format=>'jpeg', -data=>$data );
I'm still trying to figure out why it seems that the previous image isnt being deleted.
Anyone out there familiar with perl's Tk? |
|
| Back to top |
|
|
zoneminder
Site Admin
Joined: 09 Jul 2003
Posts: 4994
Location: Bristol, UK
|
| Posted: Tue Apr 18, 2006 8:56 pm Post subject: |
|
|
I've done some perl/Tk stuff. Perl has garbage collection so ordinarily you have to work pretty hard to get a leak if you have removed all references.
When you are doing | Code: | | $image[ $n ]->delete if $image[ $n ]; ## Addendum: |
you could be doing one of two things, either calling a delete method or accessing an object member called delete. I suspect you are trying to do the former but I didn't think there was a delete method for a Photo object. Are you sure you don't mean ->destroy()? Or if you are trying to remove it from the array (which is unnecessary as you are reassigning right after), | Code: | | delete $image[ $n ] |
I would have expected the assignment in the second line to have overwritten the reference in the first and so allowed it to be garbage collected (at some point in the future). You may get an initial appearance of a leak but eventually it should catch up. Or if there are other references still active then you need to track those down and find them.
I'm interested to know how this project goes as I did consider doing a perl/Tk viewer but figured it would be a bit slow. I'd be keen to know what kind of performance you get from it.
_________________
Phil |
|
| Back to top |
|
|
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
| Posted: Tue Apr 18, 2006 9:29 pm Post subject: |
|
|
Thanks for the reply,
I'm new to Tk, and did this in following advice  The symptom is that the script starts off using 19-20M for 4 cameras, and then starts chewing around 200k each second into the sys memory until the system becomes unstable. When the
$image[ $n ] = $mw->Photo( -format=>'jpeg', -data=>$data );
line is commented out, the leak stops. Data is still flowing, and printing it to the console is just fine as well; it's only when it displays it does the leak appear. I'll try it again with using destroy.
Thanks again! |
|
| Back to top |
|
|
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
| Posted: Tue Apr 18, 2006 9:33 pm Post subject: |
|
|
| Changing it from delete to destroy made the leak worse :/ |
|
| Back to top |
|
|
zoneminder
Site Admin
Joined: 09 Jul 2003
Posts: 4994
Location: Bristol, UK
|
| Posted: Wed Apr 19, 2006 8:56 am Post subject: |
|
|
I have had another look and I notice that Photo is derived from Image which does have a destroy method so that should be ok. I suspect you are just getting bitten by garbage collection but it's difficult to prove. If you run your loop much slower do you find it settles at a memory level or keep growing?
_________________
Phil |
|
| Back to top |
|
|
iamamoose
Joined: 20 Apr 2006
Posts: 1
|
| Posted: Thu Apr 20, 2006 12:58 pm Post subject: |
|
|
Yeah, so I found out pretty quickly that you needed to do the undocumented delete manually on your Photo object or it would leak memory. If you try my original version with only a single thread do you still get a leak? My first guess would be this is some complication due to threading and if so I'd solve it by not doing threading at all (some loop or select should be sufficient as ZM is continually sending data so you don't can hack it and not worry about blocking)
Cheers, Mark
http://www.awe.com/ha |
|
| Back to top |
|
|
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
| Posted: Thu Apr 20, 2006 7:48 pm Post subject: |
|
|
Hi Marc,
I do not get a leak with your origional version. I will though try and slow down the loop to see if that helps with anything.
It's an interesting problem |
|
| Back to top |
|
|
keyboardgnome
Joined: 08 Apr 2006
Posts: 27
|
| Posted: Tue May 02, 2006 3:17 pm Post subject: |
|
|
| FYI- I havent heard back from anyone who maintains Perl Tk per this memory leak. I'll let you know once I do though. |
|
| Back to top |
|
|
PinkCloud
Joined: 19 May 2008
Posts: 1
|
| Posted: Mon May 19, 2008 3:10 pm Post subject: |
|
|
Hi there,
I was just wondering whether you had managed to stop the leak as i am having same problem and i am looking for ways to stop it.
_________________
| Label Printing | Printed Labels | - PinkCloud |
|
| Back to top |
|
|
|
FAQ
Search
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
