Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

Webcam 0.2

by Arjen (Sexton)
on Jul 08, 2000 at 01:35 UTC ( #21591=sourcecode: print w/ replies, xml ) Need Help??

Category: GUI Programming
Author/Contact Info Arjen Wiersma (arjen@wiersma.org)
Description: I created this program when I still lived back in the netherlands. I had a Webcam-II hooked up to my Linux machine and at that time there were not many good programs for webcams, so I created my own.

This program uses Stamp and vidcat as utilities to capture and textstamp the picture.

My original page for links to the above programs.

Cheers
#!/usr/bin/perl -w
use Tk;
use Tk::JPEG;
use Tk::NoteBook;
use Tk::FileSelect;
use Tk::DialogBox;
use File::Copy;
use Net::FTP;

$version = "0.2";
%options = ();

# general data
$first_in_seq = 1;

# No configurable data
$sequence = 0;
$no_config = 0;

    &read_rc;
    &make_stamprc;
    
# The Main screen!
    $main = MainWindow->new();
    $main->title("Webcam II upload util");
    $main->minsize(qw(250 250));

    $menu = $main->Frame(-relief=>'groove',
                -borderwidth=>1)->pack(-side=>'top',-fill=>'x');
    $file_menu = $menu->Menubutton(-text=>'File',-tearoff=>0)->pack(-s
+ide=>'left');
        $file_menu->command(-label=>'Configure',-command=>sub{ &config
+ure });
        $file_menu->separator;
        $file_menu->command(-label=>'Exit',-command=>sub{ &write_rc; e
+xit;  });
    $help_menu = $menu->Menubutton(-text=>'Help',-tearoff=>0)->pack(-s
+ide=>'right');
        $help_menu->command(-label=>'About',-command=>sub{ &about });

# lets build a frame for the Picture....
    
    $picture = $main->Frame->pack(-side=>'top',
                      -fill=>'x',
                    padx=>3,
                    pady=>3);
    $snapshot = $picture->Button(-text=>'No Picture Yet',-command=>sub
+{ 
                     if ($sequence == 0){ &take_shot } 
        })->pack(-side=>'top',-fill=>'x');
    if ( ($options{'pic_name'}) && (-r $options{'pic_name'}) ) {
        $snap = $picture->Photo(-format=>'JPEG',-file => $options{'pic
+_name'});
        $snapshot->configure( -image => $snap );
    }

# The buttonbar
    $single_frm = $main->Frame->pack(-side=>'top',-fill=>'x',padx=>3,p
+ady=>3);
    $single_frm->Label(-text=>'Single shot: ')->pack(-side=>'left');
    $save_opts = $single_frm->Menubutton(-text=>'Save',-relief=>'raise
+d',-tearoff=>0)->pack(-side=>'right');
    $save_local = $save_opts->command(-label=>'Save local',-command=>s
+ub{ if ($sequence == 0){ &save_single } });
    $save_ftp = $save_opts->command(-label=>'Save on FTP',-command=>su
+b{ print "Do FTP save\n"; },-state=>'disabled');
    $take_shot = $single_frm->Button(-text=>'Take',-command=>sub{ if (
+$sequence == 0){ &take_shot } })->pack(-side=>'right');
    $change_text = $single_frm->Button(-text=>'Change text',-command=>
+sub{ &change_text })->pack(-side=>'right');

    $seq_frm = $main->Frame->pack(-side=>'top',-fill=>'x',padx=>3,pady
+=>3);
    $seq_frm->Label(-text=>'FTP sequence: ')->pack(-side=>'left');
    $stop_seq = $seq_frm->Button(-text=>'Stop',-command=>sub{ $start_s
+eq->configure(-state=>'normal'); 
                              $sequence = 0; $first_in_seq = 1; 
                            })->pack(-side=>'right');
    $start_seq = $seq_frm->Button(-text=>'Start',-command=>sub{ $start
+_seq->configure(-state=>'disabled'); 
                                    $sequence = 1; 
                                    &take_continuos;})->pack(-side=>'r
+ight');
    
    if ($no_config) { 
                $snapshot->configure(-state=>'disabled');
                $save_local->configure(-state=>'disabled');
                $save_ftp->configure(-state=>'disabled');
                $take_shot->configure(-state=>'disabled');
                $change_text->configure(-state=>'disabled');
                $stop_seq->configure(-state=>'disabled');
                $start_seq->configure(-state=>'disabled');
                &configure; 
            }
    MainLoop;

    &write_rc;

sub read_rc {
    if ( -r "$ENV{HOME}/.webcamII" ) {
        open(RCFILE, "$ENV{HOME}/.webcamII") or die "Can't open/create
+ rc file!\n$ENV{HOME}/.webcamII\n\t$!\n";
        while (<RCFILE>) {
            chomp;
            s/#.*//;
            s/^\s+//;
            s/\s+$//;
            next unless length;
            ($opt,$val) = split(/\s*=\s*/,$_,2);
            $options{$opt} = $val;
        }
        close(RCFILE);
        if (! $options{"pic_name"} ) { $options{"pic_name"} = "$ENV{HO
+ME}/webcamII.jpg"  };
        if (! $options{"ftp_server"} ) { if ($main) { $start_seq->conf
+igure(-state=>'disabled'); $no_config = 1} }
        if (! $options{"dev_name"} ) { warn "No device was configured!
+"; $no_config = 1; };
    } else {
        $no_config = 1;
    }
}

sub write_rc {
    open(RCFILE, ">$ENV{HOME}/.webcamII") or die "Can't open/create rc
+ file!\n$ENV{HOME}/.webcamII\n\t$!\n";
    foreach $key (keys %options) {
        print RCFILE "$key = $options{$key}\n";
    }
    close(RCFILE);
}

sub about {
    $about_win = $main->Toplevel(-title=>"About webcamII.pl");
    $about_win->Label(-text=>"webcamII.pl\n\nAuthor: Arjen Wiersma <ar
+jen\@wiersma.org>\nVersion:" .
                                 "$version\n\ncomments:\nThis program 
+was made to be a wrapper to some\n" . 
                                 "utilities i used to take and modify 
+pictures from my webcam.\n\n" . 
                                 "I would like to have comments and id
+eas as to improving the program.\n")->pack(-side=>'top');
    $about_win->Button(-text=>"Ok, I've seen enough",-command=>[$about
+_win=>'destroy'])->pack(-side=>'top');
}

sub change_text {
    $top = $options{'top_string'};
    $exect = $options{'exec_top'};
    $low = $options{'low_string'};
    $execl = $options{'exec_low'};
    $change_win = $main->Toplevel(-title=>"Change picture text");
    $top_text = $change_win->Frame->pack(-side=>'top',-fill=>'x');
    $top_text->Label(-text=>'Top text: ')->pack(-side=>'left');
    $top_text->Checkbutton(-text=>'execute',-variable=>\$exect)->pack(
+-side=>'right');
    $top_text->Entry(-width=>20,-textvariable=>\$top)->pack(-side=>'ri
+ght');
        $low_text = $change_win->Frame->pack(-side=>'top',-fill=>'x');
    $low_text->Label(-text=>'Low text: ')->pack(-side=>'left');
    $low_text->Checkbutton(-text=>'execute',-variable=>\$execl)->pack(
+-side=>'right');
    $low_text->Entry(-width=>20,-textvariable=>\$low)->pack(-side=>'ri
+ght');
    $buttons = $change_win->Frame(-relief=>'groove')->pack(-side=>'top
+',-fill=>'x');
    $buttons->Button(-text=>'Save',-command=>sub{   $options{'top_stri
+ng'} = $top;
                            $options{'exec_top'} = $exect;
                            $options{'low_string'} = $low;
                            $options{'exec_low'} = $execl;
                            &make_stamprc; 
                            })->pack(-side=>'left');
    $buttons->Button(-text=>'Close',-command=>[$change_win=>'destroy']
+)->pack(-side=>'right');
}

sub configure {
    $con_win = $main->Toplevel(-title=>"webcamII.pl configuration");
    
    $options = $con_win->NoteBook->pack(padx=>3,pady=>3);
# General configuration
    $webcamII_page = $options->add("webcamII",-label=>'webcamII');

    $dev_lbl = $webcamII_page->Label(-text=>'Device: ');
    $dev_ent = $webcamII_page->Entry(-width=>20,-textvariable=>\$optio
+ns{'dev_name'});
    Tk::grid($dev_lbl,-column=>'0',-row=>'0',-sticky=>'e');
    Tk::grid($dev_ent,-column=>'1',-row=>'0');

    $pic_lbl = $webcamII_page->Label(-text=>'Picture: ');
    $pic_ent = $webcamII_page->Entry(-width=>20,-textvariable=>\$optio
+ns{'pic_name'});
        Tk::grid($pic_lbl,-column=>'0',-row=>'1',-sticky=>'e');
    Tk::grid($pic_ent,-column=>'1',-row=>'1');

# FTP configuration
    $FTP_page = $options->add("FTP",-label=>'FTP');
    $FTP_serv_lbl = $FTP_page->Label(-text=>"Server: ");
    $FTP_serv_ent = $FTP_page->Entry(-width=>20,-textvariable=>\$optio
+ns{'ftp_server'});
    Tk::grid($FTP_serv_lbl,-column=>'0',-row=>'0',-sticky=>'e');
    Tk::grid($FTP_serv_ent,-column=>'1',-row=>'0');
        
    $FTP_user_lbl = $FTP_page->Label(-text=>"Username: ");
    $FTP_user_ent = $FTP_page->Entry(-width=>20,-textvariable=>\$optio
+ns{'ftp_user'});
    Tk::grid($FTP_user_lbl,-column=>'0',-row=>'1',-sticky=>'e');
    Tk::grid($FTP_user_ent,-column=>'1',-row=>'1');

    $FTP_pass_lbl = $FTP_page->Label(-text=>"Password: ");
    $FTP_pass_ent = $FTP_page->Entry(-width=>20,-textvariable=>\$optio
+ns{'ftp_pass'});
        Tk::grid($FTP_pass_lbl,-column=>'0',-row=>'2',-sticky=>'e');
    Tk::grid($FTP_pass_ent,-column=>'1',-row=>'2');

    $FTP_cwd_lbl = $FTP_page->Label(-text=>"Directory: ");
    $FTP_cwd_ent = $FTP_page->Entry(-width=>20,-textvariable=>\$option
+s{'ftp_cwd'});
    Tk::grid($FTP_cwd_lbl,-column=>'0',-row=>'3',-sticky=>'e');
    Tk::grid($FTP_cwd_ent,-column=>'1',-row=>'3');
                
    $FTP_delay_lbl = $FTP_page->Label(-text=>"Delay: ")->pack(-side=>'
+left');
    $FTP_delay_ent = $FTP_page->Entry(-width=>5,-textvariable=>\$optio
+ns{'delay_time'});
        Tk::grid($FTP_delay_lbl,-column=>'0',-row=>'4',-sticky=>'e');
    Tk::grid($FTP_delay_ent,-column=>'1',-row=>'4',-sticky=>'w');
# Stamp configuration
    $stamp_page = $options->add("Stamp",-label=>'Stamp');
    $top_lbl = $stamp_page->Label(-text=>"Top string: ");
    $top_ent = $stamp_page->Entry(-width=>20,-textvariable=>\$options{
+'top_string'});
    $top_exec = $stamp_page->Checkbutton(-text=>'execute',-variable=>\
+$options{'exec_top'});
        Tk::grid($top_lbl,-column=>'0',-row=>'0',-sticky=>'e');
    Tk::grid($top_ent,-column=>'1',-row=>'0',-sticky=>'w');
    Tk::grid($top_exec,-column=>'2',-row=>'0',-sticky=>'w');

        $low_lbl = $stamp_page->Label(-text=>"Low string: ");
    $low_ent = $stamp_page->Entry(-width=>20,-textvariable=>\$options{
+'low_string'});
    $low_exec = $stamp_page->Checkbutton(-text=>'execute',-variable=>\
+$options{'exec_low'});
    Tk::grid($low_lbl,-column=>'0',-row=>'1',-sticky=>'e');
    Tk::grid($low_ent,-column=>'1',-row=>'1',-sticky=>'w');
    Tk::grid($low_exec,-column=>'2',-row=>'1',-sticky=>'w');
    $con_win->Button(-text=>'Close',-command=>[$con_win=>'destroy'])->
+pack(-side=>'right');
}

sub take_shot {
    &make_stamprc;
    if (! -r "/tmp/webcamIIrc") { &make_stamprc }
# Take a shot from the camera
    system("vidcat -d $options{'dev_name'} -f jpeg > /tmp/webcamII.jpg
+") == 0 
        or die "vidcat failed: $1\n";
    system("stamp -r /tmp/webcamIIrc") == 0 or die "stamp failed: $!\n
+";
    $snap = $picture->Photo(-format=>'JPEG',-file => $options{'pic_nam
+e'});
    $snapshot->configure(-image=>$snap);
}

sub take_continuos {
    &make_stamprc;
    if (! -r "/tmp/webcamIIrc") { &make_stamprc }
    return unless $sequence;
    if ($sequence) {
        system("vidcat -d $options{'dev_name'} -f jpeg > /tmp/webcamII
+.jpg") == 0 or die "vidcat failed: $1\n";
            system("stamp -r /tmp/webcamIIrc") == 0 or die "stamp fail
+ed: $!\n";
        $snap = $picture->Photo(-format=>'JPEG',-file => $options{'pic
+_name'});
            $snapshot->configure(-image=>$snap);
        if (! &upload ) { 
                    $sequence = 0;
                    $start_seq->configure(-state=>'normal');
                    exit;
                }
        $main->after(($options{'delay_time'} * 1000),\&take_continuos)
+;
    }
}

sub save_single {
    @types = ( ["Jpeg files",['.jpg']] );
    $file= $main->getSaveFile(-filetypes=>\@types,
                  -initialfile=>'snap',
                  -defaultextension=>'.jpg');
    if (defined $file) {
        copy($options{'pic_name'},$file) == 1 or warn "Couldn't copy!\
+n\t$!\n";
    }
}

sub upload {
    $ftp = Net::FTP->new($options{'ftp_server'},-timeout=>60) or retur
+n 1;
    $ftp->login($options{'ftp_user'},$options{'ftp_pass'}) or die;
    if ( $options{'ftp_cwd'} ) { $ftp->cwd($options{'ftp_cwd'}) or die
+; }
    $ftp->type('I');
    $ftp->put($options{'pic_name'}) or die;
    $ftp->quit or return 1;
}

sub make_stamprc {
# make a RC file for STAMP.
    open (STAMP, ">/tmp/webcamIIrc");
    print STAMP "infile\t/tmp/webcamII.jpg\n";
    if ($options{'pic_name'}) { print STAMP "outfile\t$options{'pic_na
+me'}\n"; }
    print STAMP "use3d\t1\n";
    print STAMP "rotate\t0\n";
    if ($options{'low_string'}) { print STAMP "lowerstring\t$options{'
+low_string'}\n"; }
    if ($options{'exec_low'}  ) { print STAMP "lstringexec\t$options{'
+exec_low'}\n"; }
    if ($options{'top_string'}) { print STAMP "upperstring\t$options{'
+top_string'}\n"; }
    if ($options{'exec_top'}  ) { print STAMP "ustringexec\t$options{'
+exec_top'}\n"; }
    print STAMP "upperfont\t/usr/local/share/stamp/fonts/computer.fnt\
+n";
    print STAMP "lowerfont\t/usr/local/share/stamp/fonts/computer.fnt\
+n";
    print STAMP "redfore\t255\n";
    print STAMP "greenfore\t238\n";
    print STAMP "bluefore\t245\n";
    print STAMP "redback\t20\n";
    print STAMP "blueback\t115\n";
    print STAMP "greenback\t6\n";
    print STAMP "shaderate\t10\n";
    print STAMP "usecolors\t1\n";
    close(STAMP);
}

Comment on Webcam 0.2
Download Code
Re: Webcam 0.2
by Beatnik (Parson) on Jan 17, 2001 at 03:45 UTC
    When Stamp started Coredumping on me, I hacked this piece of code.

    #!/usr/bin/perl use Net::FTP; use GD; # Beatnik (c) 2000 - yadayadayada # http://stampl.sourceforge.net $inputfile = "/tmp/me.jpg"; # Local input filename $outputfile = "/tmp/recent.jpg"; # Local output filename $remotefile = "recent.jpg"; # Remote filename $remotedir = ""; # Remote directory $hostname = "ftp.myhost.com"; # Remote hostname $username = "user"; # username for remote host $password = "password"; # password for remote host $interval = 45; # Amount of seconds to wait before uploading again $textbot = "StamPL - Test"; # The text that should be added at the bot +tom for(;;) { $texttop = localtime; $ltop = length($texttop)*8; $lbot = length($textbot)*8; $result = qx|cqcam -32+ -a+ -r -j -x 320 -y 240 -q 75 > $inputfile|; if ($result) { die $result; } $image = GD::Image->newFromJpeg($inputfile); $blue = $image->colorClosest(0,0,255); $shadow = $image->colorClosest(128,128,128); ($width,$height) = $image->getBounds(); $w = $width/2; $ttop = $w-($ltop/2); $tbot = $w-($lbot/2); $image->string(gdMediumBoldFont,$ttop+2,3,$texttop,$blue); $image->string(gdMediumBoldFont,$ttop,1,$texttop,$shadow); $image->string(gdMediumBoldFont,$tbot,($height-14),$textbot,$blue); $image->string(gdMediumBoldFont,$tbot+2,($height-14)+2,$textbot,$shado +w); open(FILE,">$outputfile") || die $!; print FILE $image->jpeg(); close(FILE); $ftp = Net::FTP->new($hostname); $ftp->login($username,$password); $ftp->cwd($remotedir); $ftp->put($outputfile,$remotefile); $ftp->quit; sleep($interval); }


    It uses GD (which limits palette to 256 colors :( ) and Net::FTP. It also uses cqcam (which is also used by Stamp), and it currently on Sourceforge somewhere.
    Ofcourse sleep() isnt really a clean way to do it, but I didnt felt like forking :)

    Greetz
    Beatnik
    ... Quidquid perl dictum sit, altum viditur.
      Dayum, that's alot of code. I wrote a piece of cam-like software today. I have found a program that works astonishingly well (gqcam) on my linux box. The only problem being that it doesn't auto upload. So, I took it upon myself to write some code for it:
      #!/usr/bin/perl -w use Net::FTP; my $hostname; my $username; my $password; my $boink; my $directory; my $filename; my $ftp; my $sleeptime; $boink = 0; while ($boink == 0) { $ftp = Net::FTP->new($hostname) or die "can't connect: $@\n"; $ftp->login($username,$password) or die "can't login: $@\n"; $ftp->cwd($directory) or die "can't cwd to $directory\n"; $ftp->type(binary) or die "cannot change type to binary\n"; $ftp->put($filename) or die "cannot put $filename\n"; $ftp->close; sleep($sleeptime); }
      Althogh this is nothing revolutionary, I thought that I might as well post it because it runs under -w, as far as I am aware. I attempted to launch gqcam from the program with: `gqcam &`; but that generated error after error for the cam program. If anyone has any input on this, let me know.
        The huge amount of code is mostly for GD... the timestamp and footer stuff. I can compact it to a one-liner but then again... :))
        The whole purpose was to more or less mimick the Stamp app behaviour (which it kinda does).

        Greetz
        Beatnik
        ... Quidquid perl dictum sit, altum viditur.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://21591]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others romping around the Monastery: (9)
As of 2014-09-18 06:20 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (108 votes), past polls