Perl/Tk Webcam Access 1

[Kirsle]

Just thought I'd share the results of my latest mad-scientist experiments with Perl:

Accessing a webcam through Perl, in a way that Perl receives all the jpeg images for each frame recorded by the webcam device, and can do with them what it wants (in this case, displaying them in a Perl/Tk window). The framerate isn't bad either -- on par with any other webcam app I've ever used.

It uses ffmpeg to do all the hard work; ffmpeg outputs an mjpeg stream (motion jpeg - really a ton of jpegs concatenated together) to stdout and Perl just reads from it using a pipe.

Here's my Perlmonks thread about it, and a blog post with screenshot.

This is just a proof of concept script, and it only works on Linux (probably). ffmpeg is cross-platform though, so if you modify the command it uses you can make it work on Windows (though I don't currently know the right args to make ffmpeg work with a cam on Windows).

Here's the code:

#!/usr/bin/perl -w

# Perl/Tk Webcam Streamer and Snapshot Taker
# Proof of Concept
# Author: Casey Kirsle, [URL unfurl="true"]http://www.cuvou.com/[/URL]

use Tk;
use Tk::JPEG;
use MIME::Base64 "encode_base64";

# Some things that might need to be configured.
my $device = shift(@ARGV) || "/dev/video0";
if ($device =~ /^\// && !-e $device) {
	die "Can't see video device: $device";
}

# Tk MainWindow
my $mw = MainWindow->new (
	-title => 'Tk Stream',
);
$mw->protocol (WM_DELETE_WINDOW => \&onExit);

# A label to display the photos.
my $photo = $mw->Label ()->pack();

# A button to capture a photo
my $capture = $mw->Button (
	-text => "Take Picture",
	-command => \&snapshot,
)->pack();

$mw->update();

my $cmd = "ffmpeg -b 100K -an -f video4linux2 -s 320x240 -r 10 -i $device -b 100K -f image2pipe -vcodec mjpeg - "
	. "| perl -pi -e 's/\\xFF\\xD8/KIRSLESEP\\xFF\\xD8/ig'";
open (PIPE, "$cmd |");

my ($image,$lastimage);

my $i = 0;
my $jpgBuffer = ""; # last complete jpg image
my $buffer = ""; # bytes read
my $lastFrame = ""; # last complete jpg (kept until another full frame was read; for capturing to disk)
while (read(PIPE, $buffer, 2048)) {
	my (@images) = split(/KIRSLESEP/, $buffer);
	shift(@images) if length $images[0] == 0;
	if (scalar(@images) == 1) {
		# Still the old image.
		my $len = length $images[0];
		$jpgBuffer .= $images[0];
	}
	elsif (scalar(@images) == 2) {
		# We've completed the old image.
		$jpgBuffer .= shift(@images);
		my $len = length $images[0];
		next if length $jpgBuffer == 0;

		# Put this into the last frame received, in case the user
		# wants to save this snapshot to disk.
		$lastFrame = $jpgBuffer;

		# Create a new Photo object to hold the jpeg
		eval {
			$image = $mw->Photo (
				-data => encode_base64($jpgBuffer),
				-format => 'JPEG',
			);
		};
		# Update the label to display the snapshot
		eval {
			$photo->configure (-image => $image);
		};
		# Delete the last image to free up memory leaks,
		# then copy the new image to it.
		$lastimage->delete if ($lastimage);
		$lastimage = $image;

		# Refresh the GUI
		$mw->update();

		# Start reading the next image.
		$jpgBuffer = shift(@images);
	}
	else {
		print "Weird error: 3 items in array!\n";
		exit(1);
	}
}

sub snapshot {
	# Make up a capture filename.
	my $i = 0;
	my $fname = "capture" . (sprintf("%04d",$i)) . ".jpg";
	while (-f $fname) {
		$fname = "capture" . (sprintf("%04d",++$i)) . ".jpg";
	}

	# Save it.
	open (WRITE, ">$fname");
	binmode WRITE;
	print WRITE $lastFrame;
	close (WRITE);
	print "Frame capture saved as $fname\n";
}

sub onExit {
	# Close ffmpeg.
	print "Exiting!\n";
	close (PIPE);
}

Cuvou.com | My personal homepage

perl -e '$|=$i=1;print" oo\n<|>\n_|_";x:sleep$|;print"\b",$i++%2?"/":"_";goto x;'

 

[MikeLacey]

Hi,

Pretty unique... You should turn this into a FAQ.

Mike

Mike

http://www.myspace.com/micahhowzat

 

[Annihilannic]

If it is unique, then surely, by definition, it is not frequent.

Nice one Kirsle!

Annihilannic.