in reply to Tk, threads, and mjpeg stream

To use Tk and threads together, all your interaction with Tk objects *must* be from one thread only.

In the following code, the threads load the image data into shared buffers and then set a flag to indicate that the data is ready.

In the main thread, I've set up a repeating callback that checks the flags and when set, does the steps necessary to load the new image into the gui.

I've simulated the network fetch by loading a randomly selected, suitably sized image from a directory, but all the principal steps remain:

To run this demo as is, create 4 directories (c:\test\pics\(one|two|three|four) in this example), and place a number of suitably sized jpgs in each directory. 

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

my $host = 'c:\test\pics'; ## Dummy 'host' for testing
my @urls = qw[ one two three four ]; ## Dummy 'urls' for testing

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 ) = @_;
    my @jpgs = glob "$host/$url/*.jpg";
    while( sleep 1+rand 4 ) { ## Simulate network delays
        next if $flags[ $no ];  ## If the flag is still set do nothing

        ## Load the image
        my $jpg = $jpgs[ rand @jpgs ]; 
        open my $fh, '<:raw', $jpg or warn "$jpg : $!" and next;
        my $data = do{ local $/; <$fh> };
        close $fh;

        ## copy to the appropriate shared buffer
        $dataref->[ $no ] = $data;

        ## Set the appropriate 'image ready' flag
        $flags[ $no ] = 1;
    }
}

## 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]
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.

Replies are listed 'Best First'.
Re^2: Tk, threads, and mjpeg stream
by satanklawz (Beadle) on Apr 18, 2006 at 15:05 UTC
    BrowserUK, Thanks again for your excellent suggestion. Below is where I currently am in the learning phase of how all this works. 
    #!/usr/bin/perl -slw
use Tk;
use Tk::JPEG;
use LWP::UserAgent;
use MIME::Base64;
use IO::Socket;
use threads;
use threads::shared;

my $host = 'someipaddress';
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);
           
            ## 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]
    When I run this, I get the following errors 
    XS_Tk__Callback_Call error:couldn't recognize image data at /usr/lib/p
+erl5/site_perl/5.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.

Tk::Error: couldn't recognize image data at /usr/lib/perl5/site_perl/5
+.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.
 Tk callback for image
 Tk::After::repeat at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread
+-multi/Tk/After.pm line 79
 [repeat,[{},after#4,1000,repeat,[\&main::__ANON__]]]
 ("after" script)
XS_Tk__Callback_Call error:couldn't recognize image data at /usr/lib/p
+erl5/site_perl/5.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.

Tk::Error: couldn't recognize image data at /usr/lib/perl5/site_perl/5
+.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.
 Tk callback for image
 Tk::After::repeat at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread
+-multi/Tk/After.pm line 79
 [repeat,[{},after#5,1000,repeat,[\&main::__ANON__]]]
 ("after" script)
XS_Tk__Callback_Call error:couldn't recognize image data at /usr/lib/p
+erl5/site_perl/5.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.

Tk::Error: couldn't recognize image data at /usr/lib/perl5/site_perl/5
+.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.
 Tk callback for image
 Tk::After::repeat at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread
+-multi/Tk/After.pm line 79
 [repeat,[{},after#6,1000,repeat,[\&main::__ANON__]]]
 ("after" script)
XS_Tk__Callback_Call error:couldn't recognize image data at /usr/lib/p
+erl5/site_perl/5.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.

Tk::Error: couldn't recognize image data at /usr/lib/perl5/site_perl/5
+.8.0/i386-linux-thread-multi/Tk/Image.pm line 21.
 Tk callback for image
 Tk::After::repeat at /usr/lib/perl5/site_perl/5.8.0/i386-linux-thread
+-multi/Tk/After.pm line 79
 [repeat,[{},after#7,1000,repeat,[\&main::__ANON__]]]
 ("after" script)

    [download]
    I had thought that the string that was being passed was not being encoded correctly (or something along those lines) so I inserted a print statement of the array $data$n and got back actual jpeg information. 
    /9j/4AAQSkZJRgABAQAAAQABAAD/2wBDAAgGBgcGBQgHBwcJCQgKDBQNDAsLDBkSEw8UHR
+ofHh0a
HBwgJC4nICIsIxwcKDcpLDAxNDQ0Hyc5PTgyPC4zNDL/2wBDAQkJCQwLDBgNDRgyIRwhMj
+IyMjIy
AAF9AQIDAAQRBRIhMUEGE1FhByJxFDKBkaEII0KxwRVS0fAkM2JyggkKFhcYGRolJicoKS
+o0NTY3
...
<trunkated because there's a lot of stuff, and it's a live image>
...
TFRuykAemab5oJKnG4VHuJbpRcY4vuwM8jjFOQttBdAM0cFtygZ9KGyxBZulArAMvnHAz3
+pxJWMg
kcDr+NCEBQR3PBFRyHltpBJx/OmrAf/ZDQoN

    [download]
    Thanks again, I'm still working on this one...
[reply]
[d/l]
[select]
      I solved it- after I sent the post I realized I had encoded in 64, and did it again! DOH; regardless it works now! Here's the code for all to see: 
      #!/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]
[reply]
[d/l]
        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
[reply]
[d/l]
Re^2: Tk, threads, and mjpeg stream
by satanklawz (Beadle) on Apr 18, 2006 at 14:29 UTC
    Excellent suggestion, the only difference that I have between yours and mine is that I have an actual data stream that is never ending. That's another part of my problem :/ I'll see what I can do with what you've suggested. I'll report back soon, thanks!
[reply]

In Section Seekers of Perl Wisdom