Stream viewer for perl Tk (winders/linux)

[keyboardgnome]

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: Select all

#!/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;

[keyboardgnome]

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.

[keyboardgnome]

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?

[zoneminder]

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: Select all

 $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: Select all

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.

[keyboardgnome]

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!

[keyboardgnome]

Changing it from delete to destroy made the leak worse :/

[zoneminder]

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?

[iamamoose]

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

[keyboardgnome]

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

[keyboardgnome]

FYI- I havent heard back from anyone who maintains Perl Tk per this memory leak. I'll let you know once I do though.

[PinkCloud]

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.