Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/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); }

In reply to Webcam 0.2 by Arjen

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others lurking in the Monastery: (11)
    As of 2014-10-31 10:03 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      For retirement, I am banking on:










      Results (216 votes), past polls