Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
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
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            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 making s'mores by the fire in the courtyard of the Monastery: (10)
    As of 2015-07-28 11:08 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (254 votes), past polls