#!/usr/bin/perl -slw

# Origional:
# 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 thr
+eads!

use Tk;
use Tk::JPEG;
use LWP::UserAgent;
use MIME::Base64;
use IO::Socket;
use threads;
use threads::shared;

my $host = 'enter an ip';
my @urls = qw[ /cgi-bin/nph-zms?mode=jpeg&monitor=1&scale=100&maxfps=5
+&user=web&pass=webuser /cgi-bin/nph-zms?mode=jpeg&monitor=2&scale=100
+&maxfps=5&user=web&pass=webuser /cgi-bin/nph-zms?mode=jpeg&monitor=3&
+scale=100&maxfps=5&user=web&pass=webuser /cgi-bin/nph-zms?mode=jpeg&m
+onitor=4&scale=100&maxfps=5&user=web&pass=webuser ];

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',Peer
+Port=>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 le
+aks!
            $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 { $stop=1; })->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;
[download]

Hehe, just when you think you've got it solved a memory leak crops up! And it's a nasty one; gotta find it.

UPDATE: It's within these two lines

            $image[ $n ]->delete if $image[ $n ];   ## Addendum: 
            $image[ $n ] = $mw->Photo( -format=>'jpeg', -data=>$data )
+;
[download]

The first one does not seem to be clearing out the previous image, hence when the second line executes my system has more memory space consumed. I take it this problem is within Tk widget distruction? Any ideas from out there? Thanks

UPDATE: It's within these two lines

I concur. I spent a while trying to find a leak in the threads code before trying this none threaded version--which leaks at exactly the same rate. I've tried various things, but Tk::Photo just seems to be hanging onto some memory somewhere. You may have to go to the Tk list to get answers.

If anyone can see how to stop this non-threaded version from leaking, it's a fair bet that it would fix the threaded version also.

#! perl -slw
use strict;
require Tk;
#use Tk::X11Font;
require Tk::JPEG;
require LWP::UserAgent;
require MIME::Base64;
require IO::Socket;

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');

my @photos =  (
    $top->Label()->pack(-side => 'left'),
    $top->Label()->pack(-side => 'right'),
    $bottom->Label()->pack(-side => 'left'),
    $bottom->Label()->pack(-side => 'right'),
);

my @jpgs = glob $ARGV[0];
my @data = map{ local $/; open my $fh, '<:raw', $_; <$fh> } @jpgs;
my @image;

$mw->Button(-text=>"Stop",-command => sub { $stop=1; })->pack();
$mw->repeat( 1000, sub{
    for my $n ( 0 .. 3 ) {
        my $data = MIME::Base64::encode_base64( $data[ rand @data ] );
        $image[ $n ]->delete if $image[ $n ];
        undef $image[ $n ];
        $image[ $n ] = $mw->Photo( -format=>'jpeg', -data=>$data );
        $photos[ $n ]->configure( -image => $image[ $n ] );
    }
} );

Tk->MainLoop;
[download]

---

Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.

Lingua non convalesco, consenesco et abolesco. -- Rule 1 has a caveat! -- Who broke the cabal?

"Science is about questioning the status quo. Questioning authority".

In the absence of evidence, opinion is indistinguishable from prejudice.