In fairness, I offer the following 2 programs. "rtest.pl" and "rserver.pl"
What follows is SIMPLE perl code for a reflector setup. Please note, this code is a dirty. Real dirty. I does the job, but there are problems that I leave up to you guys to fix for yourselves.
Basically, all you do for setup is put both programs in a directory on a *nix server ( no windows since I use forking, though, I did NOT test this , so it's possible that the newest activestate build will support the forking with IO::Socket )
Edit rtest.pl to change the IP and Port to your streaming cam
Edit rserver.pl if you want the default port somewhere other then 8000.
Upload the HTML page and java applet to the SAME hostname ( unless you use signed ) and edit the parameters to point at the hostname and port of the SERVER, not the webcam.
run it ( perl rtest.pl & ) Wait 10 seconds. It will print a few messages first ( Connecting and Sent Int ) and 10 seconds later it will print out a status message showing the frames per second that it's grabbing.
Now, you can run rserver ( perl rserver.pl & ) and load up the web page.
PROBLEMS:
Like I said, this code is dirty. It was proof of concept. The reader writes the frames to a file ( img.jpg ) that the server loads and sends off to the client. You run into the problem that you get lots of visual errors because the server will sometimes load up frames AS THEY ARE BEING WRITTEN.
Also, you run into the problem that your HD is constantly writing.
The server will only send frames to the client if it has changed ( since you probably are only streaming 5-7frames a second to rtest, but clients have better download rates and could in theory pull multiples of the same frame ) so it checks to tsee if the the frame it just loaded is the same as the one it just sent and if so, keeps reloading frame till it's different.
Remeber CODE IS DIRTY: For Example:
rserver.pl
Code: Select all
while ($a < 101) {
# causing an infinate loop for testing purposes
if ($a eq 100) {
$a = 0;
} Code: Select all
while () {
While I am not planning on sharing the next few generations of code , I will give hints to you guys as to a few nifty things you can do with the existing code and the future.
If rtest is not running, but has run in the past, the applets will display the last frame rtest pulled down and not send more until the image changes. That's intresting in of itself.
If you put a sleep ( or use sleep out of time::hires ) in either server or rtest.pl you can limit the FPS. ( And control your bandwidth better )
Now. The real problem of the graphical errors. ( Reading partially written frames ) . Well, that's the million dollar question. 2 ways to fix it:
IPC
Controlserver w/threads/threads::shared
I never tested or even attempted IPC. But the control server with Perl 5.8.5 and threads.... well, last night I tested 10 computers in a local collage lab pulling 6.2 frames a second with NO graphical errors and LOW system load.
One more hint on the control server. Central loop - load grabber - load server - my $img : shared; Use $oldimg to make sure you don't resend frames, don't share oldimg since people may run at different speeds.
OH! And if you do go the threaded control server route, you will need to take out the socket code and use IO::Socket ( Or IO::Socket::INET ) to make the connection to the cam since it is thread safe.
rtest.pl
Code: Select all
#!/usr/bin/perl
use Socket;
use Fcntl ':flock'; # import LOCK_* constants
$host = "HOST_IP_OR_HOSTNAME_HERE";
$port = "PORT_YOU_ARE_RUNNING_ON";
&connectAndInit;
$start = time;
$a = 0;
$oldelapsed = 0;
while () {
my $img = &getImage;
if ($img eq 0) {
print "$a - NO IMAGE RETeRNED!!!\n";
next;
}
$elapsed = time - $start;
$newframe++;
$totalframe++;
if ($elapsed/10 eq int($elapsed/10) && $elapsed ne $oldelapsed) {
$oldelapsed = $elapsed;
$current = $newframe / 10;
$total = $totalframe / $elapsed;
print "Current FPS: $current ( $newframe frames )\nTotal FPS: $total ( $totalframe frames)\n";
$newframe = 0;
}
open(FILE,">img.jpg");
flock(FILE,LOCK_EX);
binmode FILE;
print FILE $img;
flock(FILE,LOCK_UN);
close FILE;
open(FILE,">img$a.jpg");
flock(FILE,LOCK_EX);
binmode FILE;
print FILE $img;
flock(FILE,LOCK_UN);
close FILE;
$a++;
if ($a eq 100) {
$a = 0;
}
}
$end = time;
$elapsed = $end - $start;
$persecond = 100/$elapsed;
print "TotalTime: $elapsed\nPerSecond: $persecond\n";
sub connectAndInit {
socket SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') || die('blah');
if (connect SOCK, sockaddr_in($port, inet_aton($host))) {
} else { &error("Could Not Connect"); }
print "Connected\n";
binmode SOCK;
$/ = "";
sleep 1;
syswrite(SOCK,"streamReq\r\n");
print "Sent Req\n";
$more = 1;
read(SOCK,my $buf,4);
if ($buf !~ /ok/) {
die("Did Not Return OK on request - \"$buf\"");
}
}
sub getImage {
undef $imgData;
if ($more) {
syswrite(SOCK,chr(64),1);
$more = 0;
}
read(SOCK,$buf,4);
$size = unpack('N',$buf);
if ($size eq "" || $size eq 0) {
return "";
}
my $imgData;
read(SOCK,$imgData,$size);
$more = 1;
return $imgData;
}
sub error {
print $_[0];
exit;
}
Code: Select all
#!/usr/bin/perl
use strict;
use IO::Socket;
#get the port to bind to or default to 8000
my $port = $ARGV[0] || 8000;
#ignore child processes to prevent zombies
$SIG{CHLD} = 'IGNORE';
#create the listen socket
my $listen_socket = IO::Socket::INET->new(LocalPort => $port,
Listen => 10,
Proto => 'tcp',
Reuse => 1);
#make sure we are bound to the port
die "Cant't create a listening socket: $@" unless $listen_socket;
warn "Server ready. Waiting for connections ... \n";
#wait for connections at the accept call
while (my $connection = $listen_socket->accept)
{
my $child;
# perform the fork or exit
die "Can't fork: $!" unless defined ($child = fork());
if ($child == 0)
{ #i'm the child!
#close the child's listen socket, we dont need it.
&imgRoutine($connection);
#if the child returns, then just exit;
exit 0;
}
else
{ #i'm the parent!
#who connected?
warn "Connecton recieved ... ",$connection->peerhost,"\n";
#close the connection, the parent has already passed
# it off to a child.
$connection->close();
}
#go back and listen for the next connection!
}
sub imgRoutine
{
my $socket = shift;
my $a = 0;
my $read;
my $good = 0;
while ($good eq 0) {
while (!$read) {
$read = <$socket>;
}
$read =~ s/\r//gi;
$read =~ s/\n//gi;
#print "I received: $read\n";
if ($read eq "") {
next;
}
if ($read eq "streamReq") {
print $socket "ok\r\n";
$good = 1;
}
if ($good eq 0) {
print $socket "Unknown Command (\"$read\")\r\n";
undef $read;
}
}
my $oldimg = "undef";
my $wait = 1;
while ($a < 101) {
# causing an infinate loop for testing purposes
if ($a eq 100) {
$a = 0;
}
#read the ready command
if ($wait) {
#print "Waiting for ready\n";
read($socket,my $temp,1) || die("Connection Drop");
}
$/ = "";
open(FILE,"img.jpg");
binmode(FILE);
my $img = <FILE>;
close FILE;
if ($img eq $oldimg) {
$wait = 0;
next;
}
#print "Opening img$a\.jpg\n";
$wait = 1;
$oldimg = $img;
my $size = length($img);
$size = pack('N',$size);
print $socket $size;
print $socket $img;
$a++;
}
}
Couldn't resist adding a few more tidbits.