7 use File
::Glob
':glob';
12 my $HOME=$ENV{"HOME"};
14 print "HOME environment variable not set. Exiting.\n";
18 $version="Snatch 20020510";
19 $configdir=$HOME."/.snatch";
20 $configfile=$configdir."/config.txt";
21 $historyfile=$configdir."/history.txt";
22 $logofile=$configdir."/logo.xpm";
24 my $backchannel_socket="/tmp/snatch.$$";
25 my $uaddr=sockaddr_un
($backchannel_socket);
26 my $proto=getprotobyname('tcp');
31 $CONFIG{'REALPLAYER'}='{realplay,~/RealPlayer8/realplay,/usr/bin/realplay,/usr/local/bin/realplay}';
32 $CONFIG{'LIBSNATCH'}='{/usr/local/lib/libsnatch.so,/usr/lib/libsnatch.so,~/snatch/libsnatch.so,~/.snatch/libsnatch.so}';
33 $CONFIG{'OUTPUT_PATH'}=$HOME;
34 $CONFIG{'OSS_DEVICE'}="/dev/dsp*";
35 $CONFIG{'ESD_SOCK'}="/var/run/esound/socket";
36 $CONFIG{'AUDIO_MUTE'}='no';
37 $CONFIG{'VIDEO_MUTE'}='no';
38 $CONFIG{'DEBUG'}='no';
41 die $! unless mkdir $configdir, 0770;
46 static char * snatch_xpm[] = {
73 " %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ",
74 " %S%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ",
75 "%->%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%>-%",
76 "S>;S----------------------------;@@%",
77 "S>;*{{{{{{{{{{{******{{*{{{{{{{{-@>%",
78 "S>;*{{{*^@--SSSSSSSSSSSSSS---@^{-->%",
79 "S>;*{{-......................(.SS@>%",
80 "S>;^{^...............(!/....:)..;->%",
81 "S>;^{S..+!]=++!:.:!]#,)#'!]=!)!]/->%",
82 "S>;^{;.:)'_+)]!)'_')+_,+)'_]_,:)#->%",
83 "S>;@*..#))]')=!_#,,)#)],,./()'')/->%",
84 "S>;@*;/:#])!).,,_!+)#)'_,(,:)(]_.->%",
85 "S>;S@S.]__:++.!'!_!!(_]'__:#!.++.->%",
86 "S>;-{^;........................S;->%",
87 "S>;S{{{-......................@*;->%",
88 "S>;S{{{{^;..................;^{*;->%",
89 "S>;S{{{{{*S................S{{{^.->%",
90 "S>;S{{{{{{{@..............@{{{{^.->%",
91 "S>;S{{{{{{{{^;..........;^{{{{{^.->%",
92 "S>;;{{{{{{{{{*S........-*{{{{{{^.->%",
93 "S>;;***********^-S..S-^********@.->%",
94 "S>;.;;;;;;;;;;;;;;;;;;;;;;;;;;;;.->%",
95 "S>;..............................->%",
96 "S>;..............................@&~",
97 "%-@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%>~+",
98 " %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%S% ",
99 " %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% "};
103 die $! unless open LFILE
, ">$logofile";
104 print LFILE
$snatchxpm;
108 # load the config/history
110 die $! unless open CFILE
, $configfile;
112 /^\s*([^=]+)=([^\n]*)/;
119 die $! unless open HFILE
, $historyfile;
131 my $toplevel=new MainWindow
(-class=>'Snatch');
132 my $Xname=$toplevel->Class;
134 $toplevel->optionAdd("$Xname.background", "#8e3740",20);
135 $toplevel->optionAdd("$Xname*highlightBackground", "#d38080",20);
136 $toplevel->optionAdd("$Xname.Panel.background", "#8e3740",20);
137 $toplevel->optionAdd("$Xname.Panel.foreground", "#d0d0d0",20);
138 $toplevel->optionAdd("$Xname.Panel.font",
139 '-*-helvetica-bold-o-*-*-18-*-*-*-*-*-*-*',20);
140 $toplevel->optionAdd("$Xname*Statuslabel.font",
141 '-*-helvetica-bold-r-*-*-18-*-*-*-*-*-*-*',20);
142 $toplevel->optionAdd("$Xname*Statuslabel.foreground", "#606060");
143 $toplevel->optionAdd("$Xname*Status.font",
144 '-*-helvetica-bold-r-*-*-18-*-*-*-*-*-*-*',20);
146 $toplevel->optionAdd("$Xname*AlertDetail.font",
147 '-*-helvetica-medium-r-*-*-10-*-*-*-*-*-*-*',20);
150 $toplevel->optionAdd("$Xname*background", "#d0d0d0",20);
151 $toplevel->optionAdd("$Xname*foreground", '#000000',20);
153 $toplevel->optionAdd("$Xname*Tab*background", "#a0a0a0",20);
154 $toplevel->optionAdd("$Xname*Tab*disabledForeground", "#ffffff",20);
155 $toplevel->optionAdd("$Xname*Tab*relief", "raised",20);
156 $toplevel->optionAdd("$Xname*Tab*borderWidth", 1,20);
158 $toplevel->optionAdd("$Xname*Button*background", "#f0d0b0",20);
159 $toplevel->optionAdd("$Xname*Button*foreground", '#000000',20);
160 $toplevel->optionAdd("$Xname*Button*borderWidth", '2',20);
161 $toplevel->optionAdd("$Xname*Button*relief", 'groove',20);
163 $toplevel->optionAdd("$Xname*activeBackground", "#ffffff",20);
164 $toplevel->optionAdd("$Xname*activeForeground", '#0000a0',20);
165 $toplevel->optionAdd("$Xname*borderWidth", 0,20);
166 $toplevel->optionAdd("$Xname*relief", 'flat',20);
167 $toplevel->optionAdd("$Xname*activeBorderWidth", 1,20);
168 $toplevel->optionAdd("$Xname*highlightThickness", 0,20);
169 $toplevel->optionAdd("$Xname*padX", 2,20);
170 $toplevel->optionAdd("$Xname*padY", 2,20);
171 $toplevel->optionAdd("$Xname*font",
172 '-*-helvetica-bold-r-*-*-12-*-*-*-*-*-*-*',20);
173 $toplevel->optionAdd("$Xname*Entry.font",
174 '-*-helvetica-medium-r-*-*-12-*-*-*-*-*-*-*',20);
176 $toplevel->optionAdd("$Xname*Exit.font",
177 '-*-helvetica-bold-r-*-*-10-*-*-*-*-*-*-*',20);
178 $toplevel->optionAdd("$Xname*Exit.relief", 'groove',20);
179 $toplevel->optionAdd("$Xname*Exit.padX", 1,20);
180 $toplevel->optionAdd("$Xname*Exit.padY", 1,20);
181 $toplevel->optionAdd("$Xname*Exit.borderWidth", 2,20);
182 $toplevel->optionAdd("$Xname*Exit*background", "#a0a0a0",20);
183 $toplevel->optionAdd("$Xname*Exit*disabledForeground", "#ffffff",20);
185 $toplevel->optionAdd("$Xname*Entry.background", "#ffffff",20);
186 $toplevel->optionAdd("$Xname*Entry.disabledForeground", "#c0c0c0",20);
187 $toplevel->optionAdd("$Xname*Entry.relief", "sunken",20);
188 $toplevel->optionAdd("$Xname*Entry.borderWidth", 2,20);
190 $toplevel->optionAdd("$Xname*ListBox.background", "#ffffff",20);
191 $toplevel->optionAdd("$Xname*ListBox.relief", "sunken",20);
192 $toplevel->optionAdd("$Xname*ListBox.borderWidth", 1,20);
193 $toplevel->optionAdd("$Xname*ListFrame.background", "#ffffff",20);
195 $toplevel->optionAdd("$Xname*ListRowOdd.background", "#dfffe7",20);
196 $toplevel->optionAdd("$Xname*ListRowEven.background", "#ffffff",20);
197 $toplevel->optionAdd("$Xname*OldListRowOdd.background", "#dfffe7",20);
198 $toplevel->optionAdd("$Xname*OldListRowEven.background", "#ffffff",20);
199 $toplevel->optionAdd("$Xname*OldListRowOdd.foreground", "#aaa0a0",20);
200 $toplevel->optionAdd("$Xname*OldListRowEven.foreground", "#aaa0a0",20);
202 $toplevel->optionAdd("$Xname*Scrollbar*background", "#f0d0b0",20);
203 $toplevel->optionAdd("$Xname*Scrollbar*foreground", '#000000',20);
204 $toplevel->optionAdd("$Xname*Scrollbar*borderWidth", '2',20);
205 $toplevel->optionAdd("$Xname*Scrollbar*relief", 'sunken',20);
207 $toplevel->optionAdd("$Xname*ClickList*background", "#f0d0b0",20);
208 $toplevel->optionAdd("$Xname*ClickList*foreground", '#000000',20);
209 $toplevel->optionAdd("$Xname*ClickList*borderWidth", '1',20);
210 $toplevel->optionAdd("$Xname*ClickList*relief", 'raised',20);
212 $toplevel->optionAdd("$Xname*ClickListButton*background", "#f0d0b0",20);
213 $toplevel->optionAdd("$Xname*ClickListButton*foreground", '#000000',20);
214 $toplevel->optionAdd("$Xname*ClickListButton*borderWidth", '1',20);
215 $toplevel->optionAdd("$Xname*ClickListButton*relief", 'raised',20);
218 $toplevel->optionAdd("$Xname*ClickList.Item*background", "#f0d0b0",20);
219 $toplevel->optionAdd("$Xname*ClickList.Item*foreground", '#000000',20);
220 $toplevel->optionAdd("$Xname*ClickList.Item*borderWidth", '0',20);
221 $toplevel->optionAdd("$Xname*ClickList.Item*relief", 'flat',20);
225 $toplevel->configure(-background
=>$toplevel->optionGet("background",""));
227 #$toplevel->resizable(FALSE,FALSE);
228 my $xpm_snatch=$toplevel->Pixmap("_snatchlogo_xpm",-file
=>$logofile);
230 $window_shell=$toplevel->Label(Name
=>"shell",borderwidth
=>1,relief
=>raised
)->
231 place
(-x
=>10,-y
=>36,-relwidth
=>1.0,-relheight
=>1.0,
232 -width
=>-20,-height
=>-46,-anchor
=>'nw');
234 $window_setupbar=$toplevel->Button(-class=>Tab
,Name
=>"setup",text
=>"configuration")->
235 place
(-relx
=>1.0,-anchor
=>'se',-in=>$window_shell,-bordermode
=>outside
);
236 $window_timerbar=$toplevel->Button(-class=>Tab
,Name
=>"timer",text
=>"timer setup")->
237 place
(-bordermode
=>outside
,-anchor
=>'ne',-in=>$window_setupbar);
239 $window_quit=$window_shell->Button(-class=>"Exit",text
=>"quit")->
240 place
(-x
=>-1,-y
=>-1,-relx
=>1.0,-rely
=>1.0,-anchor
=>'se');
242 $window_logo=$toplevel->
243 Label
(Name
=>"logo",-class=>"Panel",image
=>$xpm_snatch)->
244 place
(-x
=>5,-y
=>5,-anchor
=>'nw');
246 $window_version=$toplevel->
247 Label
(Name
=>"logo text",-class=>"Panel",text
=>$version)->
248 place
(-x
=>5,-relx
=>1.0,-rely
=>1.0,-anchor
=>'sw',-in=>$window_logo);
251 $window_statuslabel=$window_shell->
252 Label
(Name
=>"statuslabel",-class=>"Statuslabel",text
=>"Status: ")->
253 place
(-x
=>5,-y
=>0,-rely
=>.2,-relheight
=>.4,-anchor
=>'w');
255 $window_status=$window_shell->
256 Label
(Name
=>"status",-class=>"Status",text
=>"Starting...",-anchor
=>'w')->
257 place
(-x
=>5+$window_statuslabel->reqwidth,-rely
=>.2,-anchor
=>'w',
258 -relheight
=>.4,-relwidth
=>1.0,-width
=>-10-$window_statuslabel->reqwidth);
260 $window_active=$window_shell->Button(Name
=>"active",text
=>"capture all",
262 place
(-x
=>5,-y
=>0,-relx
=>0.,-rely
=>.55,-relwidth
=>.33,
263 -width
=>-5,-anchor
=>'w',-in=>$window_shell);
265 $window_timer=$window_shell->Button(Name
=>"timer",text
=>"timed record",
267 place
(-x
=>0,-y
=>0,-relx
=>.333,-rely
=>.55,-relwidth
=>.33,
268 -width
=>-0,-anchor
=>'w',-in=>$window_shell);
270 $window_inactive=$window_shell->Button(Name
=>"inactive",text
=>"off",
272 place
(-x
=>0,-y
=>0,-relx
=>.667,-rely
=>.55,-relwidth
=>.33,
273 -width
=>-5,-anchor
=>'w',-in=>$window_shell);
276 $window_mute=$window_shell->Label(Name
=>"mute",text
=>"silent capture: ")->
277 place
(-x
=>5,-y
=>0,-relx
=>0.,-rely
=>.85,
278 -anchor
=>'w',-in=>$window_shell);
280 $window_amute=$window_shell->Button(Name
=>"audio",text
=>"audio",
282 place
(-x
=>2,-relx
=>1.0,-relheight
=>1.0,-anchor
=>'nw',-in=>$window_mute,
283 -bordermode
=>outside
);
285 $window_vmute=$window_shell->Button(Name
=>"video",text
=>"video",
287 place
(-x
=>2,-relx
=>1.0,-relheight
=>1.0,-anchor
=>'nw',-in=>$window_amute,
288 -bordermode
=>outside
);
291 $window_logo->reqwidth()+
292 $window_version->reqwidth()+
293 $window_setupbar->reqwidth()+
294 $window_timerbar->reqwidth()+
297 $window_logo->reqheight()+
298 $window_statuslabel->reqheight()+
299 $window_active->reqheight()+
300 max
($window_mute->reqheight(),$window_quit->reqheight())+
303 $toplevel->minsize($minwidth,$minheight);
305 my$geometry=$toplevel->optionGet("geometry","");
306 if(defined($geometry)){
307 $toplevel->geometry($geometry);
309 $toplevel->geometry(($minwidth+20).'x'.$minheight);
313 $window_quit->configure(-command
=>[sub{Shutdown
();}]);
314 $window_amute->configure(-command
=>[sub{Robot_Audio
();}]);
315 $window_vmute->configure(-command
=>[sub{Robot_Video
();}]);
316 $window_active->configure(-command
=>[sub{Robot_Active
();}]);
317 $window_timer->configure(-command
=>[sub{Robot_Timer
();}]);
318 $window_inactive->configure(-command
=>[sub{Robot_Inactive
();}]);
319 $window_setupbar->configure(-command
=>[sub{Setup
();}]);
320 $window_timerbar->configure(-command
=>[sub{Timer
();}]);
325 # throw a realplayer process and
332 # the bsd glob routine deals poorly with some whitespace...
339 $pattern=~s/^(\s+).*//;
340 $pattern=~s/(\s+)$//;
342 my@result=File
::Glob
::glob($pattern,GLOB_TILDE
|GLOB_BRACE
);
344 if(!defined($result[0])){
345 @result=File
::Glob
::glob($pattern,GLOB_TILDE
|GLOB_BRACE
|GLOB_NOCHECK
);
356 $recording_pending=0;
359 Status
("Starting RealPlayer...");
360 # set up the environment
361 my$glob=trim_glob
("$CONFIG{'LIBSNATCH'}");
363 if(GLOB_ERROR
|| !defined($glob)){
364 Status
("Failed to find libsnatch.so!");
365 Alert
("Failed to find libsnatch.so!",
366 "Please verify that libsnatch.so is built,".
367 " installed, and its location is set correctly ".
368 "on the configuration panel.\n");
372 $ENV{"SNATCH_DEBUG"}=1;
373 $ENV{"LD_PRELOAD"}=$glob;
374 $ENV{"SNATCH_COMM_SOCKET"}=$backchannel_socket;
376 $glob=trim_glob
("$CONFIG{'REALPLAYER'}");
378 if(GLOB_ERROR
|| !defined($glob)){
379 Status
("Failed to find RealPlayer!");
380 Alert
("Failed to find RealPlayer!",
381 "Please verify that RealPlayer is installed,".
382 " executable, and its location is set correctly".
383 "on the configuration panel.\n");
387 die "pipe call failed unexpectedly: $!" unless pipe REAL_STDERR
,WRITEH
;
388 $realpid=open3
("STDIN",">&STDOUT",">&WRITEH",$glob);
391 # a select loop until we have the socket accepted
392 my $rin = $win = $ein = '';
393 my $rout,$wout,$eout;
394 vec($rin,fileno(REAL_STDERR
),1)=1;
395 vec($rin,fileno(LISTEN_SOCK
),1)=1;
401 Status
("Waiting for rendevous... [$time]");
403 my($nfound,$timeleft)=select($rout=$rin, $wout=$win, $eout=$ein, 1);
406 Status
("Waiting for rendevous... [$time]");
409 if(vec($rout,fileno(REAL_STDERR
),1)){
410 $bytes=sysread REAL_STDERR
, my$scalar, 4096;
411 $stderr_output.=$scalar;
414 Status
("Rendevous failed.");
416 Alert
("RealPlayer didn't start successfully. ".
417 "Here's the complete debugging output of the ".
424 if(vec($rout,fileno(LISTEN_SOCK
),1)){
425 # socket has a request
426 $status=accept(COMM_SOCK
,LISTEN_SOCK
);
434 Alert
("Rendevous failed!",
435 "RealPlayer appears to have started, but the Snatch ".
436 "robot could not connect to it via libsnatch. Most likely,".
437 " this is a result of having a blank or mis-set ".
438 "'libsntach.so location' setting on the configuration ".
439 "menu. Please verify this setting before continuing.\n");
440 Status
("Rendevous failed!");
445 Status
("RealPlayer started...");
446 $toplevel->fileevent(REAL_STDERR
,'readable'=>[sub{ReadStderr
();}]);
449 Robot_Active
() if($mode eq 'active');
450 Robot_Timer
() if($mode eq 'timer');
451 Robot_Inactive
() if($mode eq 'inactive');
452 TestOutpath
($CONFIG{OUTPUT_PATH
});
457 send_string
("F",$CONFIG{'OUTPUT_PATH'});
458 send_string
("E",$CONFIG{'ESD_SOCK'});
459 send_string
("D",$CONFIG{'OSS_DEVICE'});
463 Status
("Binding socket..");
464 die $! unless socket(LISTEN_SOCK
, PF_UNIX
, SOCK_STREAM
,0);
465 unlink($backchannel_socket);
466 die $! unless bind(LISTEN_SOCK
,$uaddr);
467 die $! unless listen(LISTEN_SOCK
,SOMAXCONN
);
473 close COMM_SOCKET
if($comm_ready);
474 close REAL_STDERR
if($comm_ready);
480 unlink($backchannel_socket);
485 Status
("Waiting for rendevous...");
488 local $SIG{ALRM
} = sub { Status
("Failed to rendevous"); };
490 $status=accept(COMM_SOCK
,LISTEN_SOCK
);
494 Status
("RealPlayer contacted");
502 die $! unless open CFILE
, ">$configfile".".tmp";
503 foreach $key (keys %CONFIG){
504 print CFILE
"$key=$CONFIG{$key}\n";
507 die $! unless rename "$configfile".".tmp", $configfile;
511 die $! unless open HFILE
, ">$historyfile".".tmp";
512 foreach $line (@TIMER){
513 print HFILE
"$line\n";
516 die $! unless rename "$historyfile".".tmp", $historyfile;
520 # save the config/history
532 syswrite COMM_SOCK
,$op;
533 syswrite COMM_SOCK
, (pack 'S', length $code);
534 syswrite COMM_SOCK
, $code;
538 my($loc,$username,$password)=@_;
539 my $stopcode=join "",("Ks",pack ("S",4));
540 my $loccode=join "",("Kl",pack ("S",4));
542 syswrite COMM_SOCK
,$stopcode;
544 $recording_pending=1;
545 send_string
("P",$password);
546 send_string
("U",$username);
547 send_string
("L",$loc);
549 syswrite COMM_SOCK
,$loccode;
551 # watch for bad password
556 my $stopcode=join "",("Ks",pack ("S",4));
557 my $opencode=join "",("Ko",pack ("S",4));
559 syswrite COMM_SOCK
,$stopcode;
560 $recording_pending=1;
561 send_string
("O",$openfile);
562 syswrite COMM_SOCK
,$opencode;
566 my $stopcode=join "",("Ks",pack ("S",4));
567 syswrite COMM_SOCK
,$stopcode;
568 $recording_pending=0;
572 my $exitcode=join "",("Kx",pack ("S",4));
573 syswrite COMM_SOCK
,$playcode;
580 if(defined($timer_callback) && !recording_active
){
581 $timer_callback->cancel();
582 undef $timer_callback;
585 # clear out robot settings to avoid hopelessly confusing the user
590 send_string
("F",$CONFIG{'OUTPUT_PATH'});
591 syswrite COMM_SOCK
,'A';
592 Robot_Audio
($CONFIG{"AUDIO_MUTE"});
593 Robot_Video
($CONFIG{"VIDEO_MUTE"});
594 Status
("Ready/waiting to record") if (!$recording_active);
603 if(defined($timer_callback)){
604 $timer_callback->cancel();
605 undef $timer_callback;
612 send_string
("F",$CONFIG{'OUTPUT_PATH'});
613 syswrite COMM_SOCK
,'I';
614 Robot_Audio
($CONFIG{"AUDIO_MUTE"});
615 Robot_Video
($CONFIG{"VIDEO_MUTE"});
616 Status
("Recording off");
625 syswrite COMM_SOCK
,'T';
626 Status
("Timer wait");
629 SetupTimerDispatch
();
630 if(!defined($timer_callback)){
631 $timer_callback=$toplevel->repeat(1000,[main
::TimerWatch
]);
637 my($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
638 $password,$outfile,$url)=SplitTimerEntry
($line);
640 syswrite COMM_SOCK
,'A';
641 send_string
("F",$outfile);
644 if($url=~/^file:(.*)/){
645 #file, through the file dialog
648 #network stream/URL, through location dialog
649 Robot_PlayLoc
($url,$username,$password);
653 sub SetupTimerDispatch
{
656 my@TIMETEMP=@TIMER_TIMES;
657 my@ENDTIMETEMP=@TIMER_ENDTIMES;
661 foreach my$line (@TIMER){
662 my$start=shift @TIMETEMP;
663 my$end=shift @ENDTIMETEMP;
665 if($start<=$now && $end>$now){
667 $next_timer_start=$start;
668 $next_timer_end=$end;
669 DoTimedEntry
($start,$line);
672 $next_timer_start=$start if(($next_timer_start==0 ||
673 $start<$next_timer_start) && $start>$now);
676 # nothing happening now
678 syswrite COMM_SOCK
,'T';
685 if($TIMER_ENDTIMES[$TIMER_SORTED[$#TIMER]]<=$now){
693 if($recording_active || $recording_pending){
694 $next=$next_timer_end;
696 $next=$next_timer_start;
700 SetupTimerDispatch
();
703 my$waiting_seconds=$next-$now;
705 my$waiting_minutes=int($waiting_seconds/60);
706 $waiting_seconds-=$waiting_minutes*60;
708 my$waiting_hours=int($waiting_minutes/60);
709 $waiting_minutes-=$waiting_hours*60;
711 my$waiting_days=int($waiting_hours/24);
712 $waiting_hours-=$waiting_days*24;
716 $prompt=$waiting_days."d ".$waiting_hours."h ".
717 $waiting_minutes."m";
718 }elsif($waiting_hours){
719 $prompt=$waiting_hours."h ".$waiting_minutes."m";
721 $prompt=$waiting_minutes."m ".$waiting_seconds."s";
724 if($recording_active){
725 Status
("Timer recording [$prompt]");
727 if($recording_pending){
728 Status
("Starting record...");
730 Status
("Timer wait [$prompt]");
736 if($recording_active){
739 my$seconds=$now-$recording_active;
741 my$minutes=int($seconds/60);
742 $seconds-=$minutes*60;
744 my$hours=int($minutes/60);
750 $prompt=$hours."h ".$minutes."m";
752 $prompt=$minutes."m ".$seconds."s";
756 Status
("Recording [$prompt]");
758 if($recording_pending){
759 Status
("Starting record...");
761 Status
("Ready/waiting to record");
763 $timer_callback->cancel();
764 undef $timer_callback;
773 syswrite COMM_SOCK
,'s';
774 $CONFIG{"AUDIO_MUTE"}='yes';
775 }elsif($onoff=~m/no/){
776 syswrite COMM_SOCK
,'S';
777 $CONFIG{"AUDIO_MUTE"}='no';
779 if($CONFIG{"AUDIO_MUTE"}=~/yes/){
780 syswrite COMM_SOCK
,'S';
781 $CONFIG{"AUDIO_MUTE"}='no';
783 syswrite COMM_SOCK
,'s';
784 $CONFIG{"AUDIO_MUTE"}='yes';
795 syswrite COMM_SOCK
,'v';
796 $CONFIG{"VIDEO_MUTE"}='yes';
797 }elsif($onoff=~m/no/){
798 syswrite COMM_SOCK
,'V';
799 $CONFIG{"VIDEO_MUTE"}='no';
801 if($CONFIG{"VIDEO_MUTE"}=~/yes/){
802 syswrite COMM_SOCK
,'V';
803 $CONFIG{"VIDEO_MUTE"}='no';
805 syswrite COMM_SOCK
,'v';
806 $CONFIG{"VIDEO_MUTE"}='yes';
815 if($line=~/^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\d+):(\d+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(.*)/){
834 ($username,$fields)=LengthParse
($fields);
835 ($password,$fields)=LengthParse
($fields);
836 ($outfile,$fields)=LengthParse
($fields);
837 ($url,$fields)=LengthParse
($fields);
839 ($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
840 $password,$outfile,$url);
852 (substr($rest,0,$length),substr($rest,$length));
861 }elsif ($year % 400 == 0){
863 }elsif ($year % 100 == 0){
869 my @trans=(0,31,0,31,30,31,30,31,31,30,31,30,31);
875 my($try,$etry)=TimerWhen
(@_);
880 my($try,$etry,$year,$month,$day,$dayofweek,$hour,$minute,$duration)=@_;
883 if($minute ne '*'){while($minute>=60){$minute-=60;
884 $hour++if($hour ne '*');}};
885 if($hour ne '*'){while($hour>=24){$hour-=24;
886 $day++ if($day ne '*');}};
887 if($day ne '*' && $month ne '*' && $year ne '*'){
888 while($month>12){$month-=12;$year++;};
889 while($day>MonthDays
($month,$year)){
890 $day-=MonthDays
($month,$year);$month++;
891 while($month>12){$month-=12;$year++;};
894 if($month ne '*'){while($month>12){$month-=12;
895 $year++ if ($year ne '*')}};
898 my($nowsec,$nowmin,$nowhour,$nowday,$nowmonth,$nowyear)=localtime($now);
903 # boundary cases in each... rather than solving it exactly, we'll
904 # solve it empirically. Laziness as a virtue.
906 ($try,$etry)=TimerWhen
($try,$etry,$nowyear-1,$month,$day,$dayofweek,
907 $hour,$minute,$duration);
908 return ($try,$etry) if($try>$now);
909 ($try,$etry)=TimerWhen
($try,$etry,$nowyear,$month,$day,$dayofweek,
910 $hour,$minute,$duration);
911 return ($try,$etry) if($try>$now);
912 ($try,$etry)=TimerWhen
($try,$etry,$nowyear+1,$month,$day,$dayofweek,
913 $hour,$minute,$duration);
914 return ($try,$etry) if($try>$now);
915 }elsif($month eq '*'){
916 for(my$i=1;$i<13;$i++){
917 ($try,$etry)=TimerWhen
($try,$etry,$year,$i,$day,$dayofweek,
918 $hour,$minute,$duration);
919 return ($try,$etry) if($try>$now);
922 # important to go for a weekday match */
923 for(my$i=1;$i<32;$i++){
924 ($try,$etry)=TimerWhen
($try,$etry,$year,$month,$i,$dayofweek,
925 $hour,$minute,$duration);
926 return ($try,$etry) if($try>$now);
928 }elsif($hour eq "*"){
930 }elsif($minute eq "*"){
932 }elsif($duration eq "*"){
936 # oops; we got a bad line in the history file
940 my $start=timelocal
(0,$minute,$hour,$day,$month-1,$year);
941 my $end=$start+$duration;
943 # make sure day-of-month and day-of-week agree
944 if($dayofweek ne '*'){
945 my($tsec,$tmin,$thour,$tday,$tmon,$tyear,$twday)=localtime($start);
946 if($twday != $dayofweek){return ($try,$etry)};
953 if($try<$now && $etry>$now){
954 # current best guess straddles now
955 if($start<$now && $start>$try){
956 #shouldn't allow this case but eh
957 return ($start,$end);
962 # current guess entirely preceeds now; prefer any guess in the future
963 return ($start,$end) if($start>=$try);
967 # current guess in the future. prefer any guess earlier in time that is not entirely past.
968 return ($start,$end) if($start<$try && $end>$now);
977 while (defined(my$n=shift @_)){
984 $window_status->configure(text
=>shift @_);
989 my($message,$detail,$window)=@_;
991 $window=$toplevel if(!defined($window));
992 $modal->destroy() if(defined($modal));
994 $modal=new MainWindow
(-class=>"$Xname");
995 $modal->configure(-background
=>$modal->optionGet("background",""));
997 $modal_shell=$modal->Label(-class=>Alert
,Name
=>"shell",
998 borderwidth
=>1,relief
=>raised
)->
999 place
(-x
=>4,-y
=>4,-relwidth
=>1.0,-relheight
=>1.0,
1000 -width
=>-8,-height
=>-8,-anchor
=>'nw');
1002 $modal_exit=$modal_shell->
1003 Button
(-class=>"Exit",text
=>"X")->
1004 place
(-x
=>-1,-y
=>-1,-relx
=>1.0,-rely
=>1.0,-anchor
=>'se');
1006 $modal_message=$modal_shell->
1007 Label
(text
=>$message,-class=>"AlertText")->
1008 place
(-x
=>5,-y
=>10);
1010 $width=$modal_message->reqwidth();
1011 $width=300 if($width<300);
1013 $modal_detail=$modal_shell->
1014 Message
(text
=>$detail,-class=>"AlertDetail",
1015 -width
=>($width-$modal_exit->reqwidth()))->
1016 place
(-relx
=>0,-y
=>5,-rely
=>1.0,-anchor
=>'nw',
1017 -in=>$modal_message);
1020 $height=$modal_message->reqheight()+$modal_detail->reqheight()+30;
1022 my$xx=$window->rootx();
1023 my$yy=$window->rooty();
1024 my$ww=$window->width();
1025 my$hh=$window->height();
1027 $x=$xx+$ww/2-$width/2;
1028 $y=$yy+$hh/2-$height/2;
1030 $modal->geometry($width."x".$height."+".int($x)."+".int($y));
1031 $modal->resizable(FALSE
,FALSE
);
1032 $modal->transient($window);
1033 $modal_exit->configure(-command
=>[sub{$modal->destroy();undef $modal}]);
1039 $bytes=sysread REAL_STDERR
, my$scalar, 4096;
1042 Alert
("RealPlayer unexpectedly exited!","Attempting to start a new copy...\n");
1043 $toplevel->fileevent(REAL_STDERR
,'readable' => '');
1047 print STDERR
$scalar if($CONFIG{'DEBUG'} eq 'yes');
1049 push my@lines, split /\n/, $saved_stderr.$scalar;
1050 if((chomp $scalar)==0){
1051 $saved_stderr=$lines[$#lines];
1056 foreach my$line (@lines){
1058 if($line=~/X display closed/){
1060 $toplevel->fileevent(REAL_STDERR
,'readable' => '');
1064 if($line=~/ERROR: Could not stat[^\n]+\n\s+([^:]*): (.+)*/){
1065 Alert
("Unable to open output file!",
1066 "Libsnatch reported $1: $2\n");
1067 }elsif($line=~/Password not/){
1068 Alert
("Password not accepted!",
1069 "Hopefully self explanatory...\n");
1070 }elsif($line=~/\*\*ERROR: /){
1071 Alert
("Libsnatch reported an error!",
1072 $saved_stderr.$scalar."\n");
1076 if($line=~/bit ZPixmap/){
1077 Alert
("ERROR: This X server is not using 24/32 bit visuals!",
1078 "Right now, Snatch is still new ad as such only supports the highest".
1079 " bitdepth visuals. These visuals give the best quality and are thus".
1080 " recommended strongly for capture. Other visuals will eventually be".
1081 " supported as well, but they won't work for now.\n");
1084 if($line=~/Capture stopped/){
1085 $recording_active=0;
1086 $recording_pending=0;
1089 SetupTimerDispatch
();
1094 if($line=~/Capturing/){
1095 $recording_active=time();
1096 $recording_pending=0;
1097 if(!defined($timer_callback)){
1098 $timer_callback=$toplevel->repeat(1000,[sub{main
::TimerWatch
();}]);
1104 sub ButtonPressConfig
(){
1105 $window_timer->configure(-relief
=>'groove') if ($mode ne 'timer');
1106 $window_timer->configure(-relief
=>'sunken') if ($mode eq 'timer');
1107 $window_active->configure(-relief
=>'groove') if ($mode ne 'active');
1108 $window_active->configure(-relief
=>'sunken') if ($mode eq 'active');
1109 $window_inactive->configure(-relief
=>'groove') if ($mode ne 'inactive');
1110 $window_inactive->configure(-relief
=>'sunken') if ($mode eq 'inactive');
1112 $window_amute->configure(-relief
=>'groove') if ($CONFIG{AUDIO_MUTE
} eq 'no');
1113 $window_amute->configure(-relief
=>'sunken') if ($CONFIG{AUDIO_MUTE
} eq 'yes');
1114 $window_vmute->configure(-relief
=>'groove') if ($CONFIG{VIDEO_MUTE
} eq 'no');
1115 $window_vmute->configure(-relief
=>'sunken') if ($CONFIG{VIDEO_MUTE
} eq 'yes');
1117 if(defined($tentry)){
1119 if($mode=~/^active/ || ($mode=~/timer/ && ($recording_active ||
1120 $recording_pending))){
1121 $tentry_test->configure(-state=>disabled
);
1123 $tentry_test->configure(-state=>normal
);
1132 if ($#TIMER<0 || $TIMER_ENDTIMES[$TIMER_SORTED[$#TIMER]]<$now ||
1134 $window_timer->configure(state=>disabled
);
1136 $window_timer->configure(state=>normal
);
1139 $window_active->configure(state=>disabled
);
1140 $window_inactive->configure(state=>disabled
);
1141 $window_amute->configure(state=>disabled
);
1142 $window_vmute->configure(state=>disabled
);
1144 $window_active->configure(state=>normal
);
1145 $window_inactive->configure(state=>normal
);
1146 $window_amute->configure(state=>normal
);
1147 $window_vmute->configure(state=>normal
);
1149 ButtonPressConfig
();
1155 $window_setupbar->configure(-state=>'disabled');
1156 $window_setupbar->configure(-relief
=>'flat');
1157 $setup=new MainWindow
(-class=>'Snatch');
1159 $setup_title=$setup->
1160 Label
(Name
=>"setup text",-class=>"Panel",text
=>"Configuration")->
1161 place
(-x
=>10,-y
=>5);
1163 $setup_shell=$setup->Label(Name
=>"shell",borderwidth
=>1,relief
=>raised
)->
1164 place
(-x
=>10,-y
=>$setup_title->reqheight()+10,-relwidth
=>1.0,-relheight
=>1.0,
1165 -width
=>-20,-height
=>-$setup_title->reqheight()-20,-anchor
=>'nw');
1167 $setup_quit=$setup_shell->
1168 Button
(-class=>"Exit",text
=>"ok")->
1169 place
(-x
=>-1,-y
=>-1,-relx
=>1.0,-rely
=>1.0,-anchor
=>'se');
1170 $setup_apply=$setup_shell->
1171 Button
(-class=>"Exit",text
=>"apply")->
1172 place
(-x
=>0,-y
=>0,-anchor
=>'ne',-in=>$setup_quit,
1173 -bordermode
=>outside
);
1174 $setup_cancel=$setup_shell->
1175 Button
(-class=>"Exit",text
=>"cancel")->
1176 place
(-x
=>1,-y
=>-1,-rely
=>1.0,-anchor
=>'sw');
1181 $temp=$setup_shell->
1182 Label
(text
=>"RealPlayer location:")->
1183 place
(-x
=>5,-y
=>$nexty);
1185 Entry
(-textvariable
=>\
$TEMPCONF{'REALPLAYER'},-width
=>"256")->
1186 place
(-y
=>$nexty,-x
=>$temp->reqwidth()+10,
1187 -anchor
=>'nw',-relwidth
=>1.0,
1188 -height
=>$temp->reqheight(),
1189 -width
=>-$temp->reqwidth()-18);
1190 $nexty=8+$temp->reqheight();
1193 $temp=$setup_shell->
1194 Label
(text
=>"libsnatch.so location:")->
1195 place
(-x
=>5,-y
=>$nexty);
1197 Entry
(-textvariable
=>\
$TEMPCONF{'LIBSNATCH'},-width
=>"256")->
1198 place
(-y
=>$nexty,-x
=>$temp->reqwidth()+10,
1199 -anchor
=>'nw',-relwidth
=>1.0,
1200 -height
=>$temp->reqheight(),
1201 -width
=>-$temp->reqwidth()-18);
1202 $nexty+=8+$temp->reqheight();
1205 $temp=$setup_shell->
1206 Label
(text
=>"OSS audio device:")->
1207 place
(-x
=>5,-y
=>$nexty);
1209 Entry
(-textvariable
=>\
$TEMPCONF{'OSS_DEVICE'},-width
=>"256")->
1210 place
(-y
=>$nexty,-x
=>$temp->reqwidth()+10,
1211 -anchor
=>'nw',-relwidth
=>1.0,
1212 -height
=>$temp->reqheight(),
1213 -width
=>-$temp->reqwidth()-18);
1214 $nexty+=8+$temp->reqheight();
1217 $temp=$setup_shell->
1218 Label
(text
=>"EsounD server socket:")->
1219 place
(-x
=>5,-y
=>$nexty);
1221 Entry
(-textvariable
=>\
$TEMPCONF{'ESD_SOCK'},-width
=>"256")->
1222 place
(-y
=>$nexty,-x
=>$temp->reqwidth()+10,
1223 -anchor
=>'nw',-relwidth
=>1.0,
1224 -height
=>$temp->reqheight(),
1225 -width
=>-$temp->reqwidth()-18);
1226 $nexty+=15+$temp->reqheight();
1229 if($TEMPCONF{'DEBUG'} eq 'yes'){
1230 $temp=$setup_debug=$setup_shell->
1231 Button
(text
=>"full debug output",-relief
=>'sunken',-pady
=>1)->
1232 place
(-x
=>5,-y
=>$nexty);
1234 $temp=$setup_debug=$setup_shell->
1235 Button
(text
=>"full debug output",-pady
=>1)->
1236 place
(-x
=>5,-y
=>$nexty);
1238 $setup_debug->configure(-command
=>[sub{Setup_Debug
();}]);
1239 $nexty+=15+$temp->reqheight();
1242 $temp=$setup_shell->
1243 Label
(text
=>"capture output:")->
1244 place
(-x
=>5,-y
=>$nexty);
1246 $setup_path=$setup_shell->
1247 Entry
(-textvariable
=>\
$TEMPCONF{'OUTPUT_PATH'},-width
=>256)->
1248 place
(-x
=>$temp->reqwidth()+10,
1249 -y
=>$nexty,-height
=>$temp->reqheight(),
1250 -width
=>-$temp->reqwidth()-18,
1253 $nexty+=15+$temp->reqheight();
1257 $minheight=$nexty+28+$setup_title->reqheight()+$setup_cancel->reqheight();
1259 $setup->minsize($minwidth,$minheight);
1260 $setup->geometry(($minwidth+20)."x".$minheight);
1262 $setup_quit->configure(-command
=>[sub{
1263 my $temppath=$TEMPCONF{"OUTPUT_PATH"};
1264 if(TestOutpath
($temppath,$setup)){
1266 $setup->destroy();undef $setup;
1267 $CONFIG{OUTPUT_PATH
}=trim_glob
($temppath);
1268 $window_setupbar->configure(state=>'normal');
1269 $window_setupbar->configure(relief
=>'raised');
1272 ThrowRealPlayer
() if(!$comm_ready);
1273 Status
("Configuration successful");
1277 $setup_apply->configure(-command
=>[sub{
1278 my $temppath=$TEMPCONF{"OUTPUT_PATH"};
1280 if(TestOutpath
($temppath,$setup)){
1282 $CONFIG{OUTPUT_PATH
}=trim_glob
($temppath);
1285 ThrowRealPlayer
() if(!$comm_ready);
1286 Status
("Configuration successful");
1290 $setup_cancel->configure(-command
=>[sub{
1291 $setup->destroy();undef $setup;
1292 $window_setupbar->configure(state=>'normal');
1293 $window_setupbar->configure(relief
=>'raised');
1303 $path=trim_glob
($path);
1305 # in the event this is a file spec in a writable directory, try touching it
1306 if(open (TEST
,">$path")){
1313 Status
("Bad output path") if($window==$toplevel);
1314 Alert
("Selected output path isn't writable!",
1315 "The output path currently set on the configuration panel either does not exist,".
1316 " or is inaccessible due to permissions. Please set a usable path else ".
1317 "recording will fail.\n",$window);
1325 if($TEMPCONF{'DEBUG'} eq 'yes'){
1326 $TEMPCONF{'DEBUG'}='no';
1327 $setup_debug->configure(-relief
=>groove
);
1329 $TEMPCONF{'DEBUG'}='yes';
1330 $setup_debug->configure(-relief
=>sunken
);
1336 $window_timerbar->configure(-state=>'disabled');
1337 $window_timerbar->configure(-relief
=>'flat');
1338 $timerw=new MainWindow
(-class=>'Snatch');
1340 $timerw_title=$timerw->
1341 Label
(Name
=>"timer text",-class=>"Panel",text
=>"Timer Setup")->
1342 place
(-x
=>10,-y
=>5);
1344 $timerw_shell=$timerw->Label(Name
=>"shell",borderwidth
=>1,relief
=>raised
)->
1345 place
(-x
=>10,-y
=>$timerw_title->reqheight()+10,-relwidth
=>1.0,-relheight
=>1.0,
1346 -width
=>-20,-height
=>-$timerw_title->reqheight()-20,-anchor
=>'nw');
1348 $timerw_quit=$timerw_shell->
1349 Button
(-class=>"Exit",text
=>"X")->
1350 place
(-x
=>-1,-y
=>-1,-relx
=>1.0,-rely
=>1.0,-anchor
=>'se');
1352 $timerw_quit->configure(-command
=>[sub{
1356 $window_timerbar->configure(state=>'normal');
1357 $window_timerbar->configure(relief
=>'raised');
1360 $timerw_delete=$timerw_shell->
1361 Button
(Name
=>"delete",text
=>"delete",-state=>disabled
)->
1362 place
(-x
=>-5,-relx
=>1.0,-y
=>-$timerw_quit->reqheight()-25,
1363 -rely
=>1.0,-anchor
=>'se');
1365 $timerw_duplicate=$timerw_shell->
1366 Button
(Name
=>"edit",text
=>"copy",-state=>disabled
)->
1367 place
(-x
=>0,-y
=>-25,-relwidth
=>1.0,-anchor
=>'sw',
1368 -in=>$timerw_delete,-bordermode
=>outside
);
1369 $timerw_edit=$timerw_shell->
1370 Button
(Name
=>"edit",text
=>"edit",-state=>disabled
)->
1371 place
(-x
=>0,-y
=>-5,-relwidth
=>1.0,-anchor
=>'sw',
1372 -in=>$timerw_duplicate,-bordermode
=>outside
);
1373 $timerw_add=$timerw_shell->
1374 Button
(Name
=>"add",text
=>"add")->
1375 place
(-x
=>0,-y
=>-5,-relwidth
=>1.0,-anchor
=>'sw',
1376 -in=>$timerw_edit,-bordermode
=>outside
);
1379 $minheight=$timerw_add->reqheight()*4+$timerw_quit->reqheight()+$timerw_title->reqheight()+95;
1381 $timerw->minsize($minwidth,$minheight);
1382 $timerw->geometry(($minwidth+20)."x".$minheight);
1384 $timerw_add->configure(-command
,[sub{Timer_Add
();}]);
1385 $timerw_edit->configure(-command
,[sub{Timer_Edit
();}]);
1386 $timerw_delete->configure(-command
,[sub{Timer_Delete
();}]);
1387 $timerw_duplicate->configure(-command
,[sub{Timer_Copy
();}]);
1389 $listbox=BuildListBox
();
1394 $listbox->destroy() if(defined($listbox));
1396 # assemble the sorted timer elements we're actually interested into an array for listbox
1425 for(my$i=0;$i<=$n;$i++){
1426 my($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
1427 $password,$outfile,$url)=SplitTimerEntry
($TIMER[$TIMER_SORTED[$i]]);
1429 my$start=$TIMER_TIMES[$TIMER_SORTED[$i]];
1430 #also need the end...
1431 my$end=$TIMER_TIMES[$TIMER_SORTED[$i]]+$duration;
1438 my$dur_hours=int($duration/3600);
1439 $duration-=$dur_hours*3600;
1440 my$dur_minutes=int($duration/60);
1441 $duration-=$dur_minutes*60;
1449 $dur_minutes='0'.int($dur_minutes) if($dur_minutes <10);
1450 $minute='0'.int($minute) if($minute <10);
1452 push @listarray, "$emph","$year ",$monthtrans->{$month},"$day ",
1453 $daytrans->{$dayofweek},"$hour:$minute ","$dur_hours$dur_minutes ",$url;
1455 # bad entry; prevent death
1456 push @listarray, "Old","X ","X ","X ","X ","XXX ","XXX ","Bad Entry ";
1460 $listbox=Snatch
::ListBox
::new
($timerw_shell,7,@listarray)->
1461 place
(-x
=>5,-y
=>5,-relheight
=>1.0,-relwidth
=>1.0,
1462 -width
=>-$timerw_delete->reqwidth()-15,
1464 -bordermode
=>outside
);
1466 $listbox->callback(\
&Timer_Highlight
);
1470 CheckTimerOverlap
();
1478 if(defined($timerw)){
1481 $timerw_add->configure(-state=>normal
);
1482 if(defined($timer_row)){
1483 $timerw_edit->configure(-state=>normal
);
1484 $timerw_duplicate->configure(-state=>normal
);
1485 $timerw_delete->configure(-state=>normal
);
1490 sub CheckTimerOverlap
{
1491 my$rows=($#TIMER)+1;
1493 foreach my$line (@TIMER){
1497 for(my$i=0;$i<$rows;$i++){
1498 for(my$j=$i+1;$j<$rows;$j++){
1499 my $start1=$TIMER_TIMES[$i];
1500 my $end1=$TIMER_ENDTIMES[$i];
1501 my $start2=$TIMER_TIMES[$j];
1502 my $end2=$TIMER_ENDTIMES[$j];
1504 if($start1>0 && $start2>0){
1505 if(($start1>=$start2 && $start1<$end2)||
1506 ($start2>=$start1 && $start2<$end1)){
1507 Alert
("Some timer entries currently overlap!",
1508 "When multiple entries overlap, recording of one program will not be ".
1509 "interrupted to record the next; that is, if program B is scheduled to ".
1510 " begin during program A, recording B will wait until A ends.\n",
1521 my@TIMER_FULL=(map {TimerWhen
(-1,-1,(SplitTimerEntry
($_)))} @TIMER);
1523 undef @TIMER_ENDTIMES;
1525 my$temp=shift @TIMER_FULL;
1527 push @TIMER_TIMES, $temp;
1528 push @TIMER_ENDTIMES, shift @TIMER_FULL;
1533 @TIMER_SORTED=sort {$TIMER_TIMES[$a]-$TIMER_TIMES[$b]} (map {$count++} @TIMER);
1536 sub Timer_Highlight
{
1537 if(!defined($tentry)){
1538 if(defined($highlightnow) && $highlightnow+2>time){
1540 if($timer_row==$_[0]){
1541 # doubleclick hack. Edit this entry
1548 $timerw_edit->configure(-state=>normal
);
1549 $timerw_delete->configure(-state=>normal
);
1550 $timerw_duplicate->configure(-state=>normal
);
1558 # which real (not sorted) row of the timer array is this?
1559 my$actual_row=$TIMER_SORTED[$timer_row];
1561 splice @TIMER,$actual_row,1;
1565 $timerw_edit->configure(-state=>disabled
);
1566 $timerw_delete->configure(-state=>disabled
);
1567 $timerw_duplicate->configure(-state=>disabled
);
1572 my($nowsec,$nowmin,$nowhour,$nowday,$nowmonth,$nowyear)=localtime time;
1575 Timer_Entry
(-1,"$nowyear $nowmonth $nowday * $nowhour:$nowmin 3600 yes yes 0: 0: ".
1580 Timer_Entry
($TIMER_SORTED[$timer_row],$TIMER[$TIMER_SORTED[$timer_row]]);
1584 Timer_Entry
(-1,$TIMER[$TIMER_SORTED[$timer_row]]);
1590 my($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
1591 $password,$dummy,$url)=SplitTimerEntry
(shift);
1593 my$duration_hour=int($duration/3600);
1594 my$duration_minute=int(($duration-$duration_hour*3600+59)/60);
1595 $duration_minute='0'.int($duration_minute) if($duration_minute <10);
1596 $minute='0'.int($minute) if($minute <10);
1599 my($nowsec,$nowmin,$nowhour,$nowday,$nowmonth,$nowyear)=localtime time;
1604 $timerw_add->configure(-state=>disabled
);
1605 $timerw_edit->configure(-state=>disabled
);
1606 $timerw_duplicate->configure(-state=>disabled
);
1607 $timerw_delete->configure(-state=>disabled
);
1609 $tentry=new MainWindow
(-class=>'Snatch');
1611 $tentry_title=$tentry->
1612 Label
(Name
=>"timer text",-class=>"Panel",text
=>"Add/Edit Timer Entry")->
1613 place
(-x
=>10,-y
=>5);
1615 $tentry_shell=$tentry->Label(Name
=>"shell",borderwidth
=>1,relief
=>raised
)->
1616 place
(-x
=>10,-y
=>$timerw_title->reqheight()+10,-relwidth
=>1.0,-relheight
=>1.0,
1617 -width
=>-20,-height
=>-$timerw_title->reqheight()-20,-anchor
=>'nw');
1619 $tentry_quit=$tentry_shell->
1620 Button
(-class=>"Exit",text
=>"ok")->
1621 place
(-x
=>-1,-y
=>-1,-relx
=>1.0,-rely
=>1.0,-anchor
=>'se');
1622 $tentry_cancel=$tentry_shell->
1623 Button
(-class=>"Exit",text
=>"cancel")->
1624 place
(-x
=>1,-y
=>-1,-rely
=>1.0,-anchor
=>'sw');
1626 $tentry_quit->configure(-command
=>[sub{
1628 # check the entry out
1629 $duration=$duration_hour*3600+$duration_minute*60;
1630 my$time=TimerStart
(-1,-1,$year,$month,$day,$dayofweek,$hour,$minute,$duration);
1632 Alert
("Impossible date setting!",
1633 "The date checking routines believe the entered date doesn't exist (or is".
1634 " far enough in the past it will never trigger anyway). Please correct the".
1635 ' date specification before proceeding, or file a bug report'.
1636 " if the date is correct and the code is wrong.\n",$tentry);
1638 $outfile=trim_glob
($outfile);
1639 my$entry="$year $month $day $dayofweek $hour:$minute $duration $audio $video ".
1640 length($username).":$username ".length($password).":$password ".
1641 "0: ".length($url).":$url";
1644 push @TIMER, $entry;
1648 splice @TIMER,$row,1,$entry;
1655 if(defined($timerw)){
1658 $timerw_add->configure(-state=>normal
);
1659 if(defined($timer_row)){
1660 $timerw_edit->configure(-state=>normal
);
1661 $timerw_duplicate->configure(-state=>normal
);
1662 $timerw_delete->configure(-state=>normal
);
1670 $tentry_cancel->configure(-command
=>[sub{
1671 if(defined($timerw)){
1672 $timerw_add->configure(-state=>normal
);
1673 if(defined($timer_row)){
1674 $timerw_edit->configure(-state=>normal
);
1675 $timerw_duplicate->configure(-state=>normal
);
1676 $timerw_delete->configure(-state=>normal
);
1683 # bwah ha ha. The bitter end.
1688 my$t=$tentry_shell->Label(-text
=>"Date:")->
1689 place
(-x
=>$x, -y
=>$y, -bordermode
=>outside
);
1690 $x+=$t->reqwidth()+5;
1693 my$tt=Snatch
::ClickList
::new
($tentry_shell,\
$year,
1695 "$nowyear",$nowyear,
1696 $nowyear+1,$nowyear+1,
1697 $nowyear+2,$nowyear+2)->
1698 place
(-x
=>$x,-y
=>$y,-bordermode
=>outside
);
1699 $x+=$tt->reqwidth+5;
1700 $reqheight=$tt->maxheight()if($tt->maxheight()>$reqheight);
1702 $t->place(-height
=>$tt->reqheight());
1705 my$t=Snatch
::ClickList
::new
($tentry_shell,\
$month,
1719 place
(-x
=>$x,-y
=>$y,-bordermode
=>outside
);
1721 $reqheight=$t->maxheight()if($t->maxheight()>$reqheight);
1724 my$t=$tentry_shell->Entry(-width
=>2,-textvariable
=>\
$day,-justify
=>right
)->
1725 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1729 my$t=Snatch
::ClickList
::new
($tentry_shell,\
$dayofweek,
1738 place
(-x
=>$x,-y
=>$y,-bordermode
=>outside
);
1739 $x+=$t->reqwidth+15;
1740 $reqheight=$t->maxheight()if($t->maxheight()>$reqheight);
1742 my$t=$tentry_shell->Label(-text
=>"Time:")->
1743 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1744 $x+=$t->reqwidth()+5;
1747 my$t=$tentry_shell->Entry(-width
=>2,-textvariable
=>\
$hour,-justify
=>right
)->
1748 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1751 my$t=$tentry_shell->Label(-text
=>":")->
1752 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1756 my$t=$tentry_shell->Entry(-width
=>2,-textvariable
=>\
$minute,-justify
=>right
)->
1757 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1758 $x+=$t->reqwidth+15;
1760 my$t=$tentry_shell->Label(-text
=>"Duration:")->
1761 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1762 $x+=$t->reqwidth()+5;
1765 my$t=$tentry_shell->Entry(-width
=>2,-textvariable
=>\
$duration_hour,-justify
=>right
)->
1766 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1769 my$t=$tentry_shell->Label(-text
=>":")->
1770 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1774 my$t=$tentry_shell->Entry(-width
=>2,-textvariable
=>\
$duration_minute,-justify
=>right
)->
1775 place
(-x
=>$x, -y
=>$y, -height
=>$tt->reqheight(),-bordermode
=>outside
);
1779 $reqheight+=$tentry_title->reqheight()+35; # this is just for the pulldown menus
1780 $y+=$tt->reqheight()+20;
1783 my$t=$tentry_urllabel=$tentry_shell->Label(-text
=>"URL:")->place(-y
=>$y,-x
=>5,-bordermode
=>outside
);
1784 my$tentry_url=$tentry_shell->Entry(-textvariable
=>\
$url,-width
=>2048)->
1785 place
(-y
=>$y,-x
=>10+$t->reqwidth,-height
=>$t->reqheight,-bordermode
=>outside
,
1786 -relwidth
=>1.0,-width
=>-20-$t->reqwidth());
1787 $y+=$t->reqheight()+5;
1788 $t=$tentry_usernamelabel=$tentry_shell->Label(-text
=>"username:")->place(-y
=>$y,-x
=>5);
1789 my$tentry_username=$tentry_shell->Entry(-textvariable
=>\
$username,-width
=>2048)->
1790 place
(-y
=>$y,-x
=>10+$t->reqwidth,-height
=>$t->reqheight,-bordermode
=>outside
,
1791 -relwidth
=>1.0,-width
=>-20-$t->reqwidth());
1792 $y+=$t->reqheight()+5;
1793 $t=$tentry_passwordlabel=$tentry_shell->Label(-text
=>"password:")->place(-y
=>$y,-x
=>5);
1794 my$tentry_password=$tentry_shell->Entry(-textvariable
=>\
$password,-width
=>2048)->
1795 place
(-y
=>$y,-x
=>10+$t->reqwidth,-height
=>$t->reqheight,-bordermode
=>outside
,
1796 -relwidth
=>1.0,-width
=>-20-$t->reqwidth());
1797 $y+=$tentry_passwordlabel->reqheight()+10;
1800 my$tentry_silent=$tentry_shell->Label(-text
=>"silent record:")->place(-y
=>$y,-x
=>5,-bordermode
=>outside
);
1801 my$tentry_audio=$tentry_shell->Button(-text
=>"audio")->
1802 place
(-in=>$tentry_silent,-relx
=>1.0,-x
=>5,-relheight
=>1.0,-bordermode
=>outside
);
1803 $tentry_audio->configure(-command
=>[main
::nonmomentary
,\
$tentry_audio,\
$audio]);
1804 my$tentry_video=$tentry_shell->Button(-text
=>"video")->
1805 place
(-in=>$tentry_audio,-relx
=>1.0,-x
=>5,-relheight
=>1.0,-bordermode
=>outside
);
1806 $tentry_video->configure(-command
=>[main
::nonmomentary
,\
$tentry_video,\
$video]);
1808 $tentry_test=$tentry_shell->Button(-text
=>"test connect now")->
1809 place
(-relx
=>1.0,-x
=>-10,-y
=>$y,-height
=>$tentry_silent->reqheight,-anchor
=>'ne',
1810 -bordermode
=>outside
);
1812 if($mode=~/^active/ || ($mode=~/timer/ && ($recording_active || $recording_pending))){
1813 $tentry_test->configure(-state=>disabled
);
1816 $tentry_test->configure(-command
=>[sub{
1818 Robot_Audio
($audio);
1819 Robot_Video
($video);
1820 if($url=~/^file:(.*)/){
1821 #file, through the file dialog
1824 #network stream/URL, through location dialog
1825 Robot_PlayLoc
($url,$username,$password);
1830 nonmomentary
(\
$tentry_audio,\
$audio);
1831 nonmomentary
(\
$tentry_audio,\
$audio);
1832 nonmomentary
(\
$tentry_video,\
$video);
1833 nonmomentary
(\
$tentry_video,\
$video);
1834 $y+=$tentry_video->reqheight()+10;
1836 $tentry_message=$tentry_shell->
1837 Message
(-text
=>"Any field in the date specification may be set to the wildcard * (asterisk); ".
1838 "recording will happen on all dates in the future matching the provided ".
1839 "fields. Time and ".
1840 "duration are specified in hours and minutes, time uses a 24 hour clock.".
1841 "\n\n\'Silent record\' indicates that ".
1842 "during the record operation, no attempt should be made to open the audio device, ".
1844 "or display video. This is useful both to increase performance and eliminate ".
1845 "the possibility timed record will fail due to audio device conflicts with other ".
1847 -width
=>$reqwidth-30-$tentry_shell->cget(borderwidth
)*2,
1848 -anchor
=>w
,-class=>AlertDetail
)->
1849 place
(-x
=>5,-y
=>$y,-relwidth
=>1.0,-width
=>-10,-bordermode
=>outside
);
1850 $y+=$tentry_message->reqheight()+5;
1853 $reqheight=max
($reqheight,$y+$tentry_quit->reqheight+$tentry_title->reqheight()+35);
1855 $tentry->minsize($reqwidth,$reqheight);
1856 $tentry->geometry($reqwidth."x".$reqheight);
1861 my($buttonref,$valref)=@_;
1863 if($$valref eq 'yes'){
1865 $$buttonref->configure(-relief
=>groove
);
1868 $$buttonref->configure(-relief
=>sunken
);
1871 package Snatch
::ListBox
;
1875 my$this=bless \
%listbox;
1878 my$cols=$listbox{cols
}=shift @_;
1883 $listbox{textrows
}=\
@textrows;
1884 $listbox{widgetrows
}=\
@widgetrows;
1886 my$frame=$listbox{frame
}=$parent->Frame(-class=>'ListBoxFrame');
1887 my$scrollbar=$listbox{scrollbar
}=$frame->Scrollbar(-orient
=>"vertical")->
1888 place
(-relx
=>1.0,-relheight
=>1.0,-anchor
=>'ne',-bordermode
=>outside
);
1889 my$pane=$listbox{pane
}=$frame->Frame(-class=>'ListBox')->
1890 place
(-relwidth
=>1.0,-relheight
=>1.0,-width
=>-$scrollbar->reqwidth());
1892 $listbox{window
}=$pane->Frame(-class=>'ListFrame')->place(-relwidth
=>1.0);
1898 for($listbox{rows
}=0;!$done;$listbox{rows
}++){
1901 $textrows[$listbox{rows
}]=\
@textrow;
1902 $widgetrows[$listbox{rows
}]=\
@widgetrow;
1905 for(my$j=0;$j<$cols;$j++){
1909 if($listbox{rows
} % 2){
1910 my$w=$widgetrow[$j]=$listbox{window
}->
1911 Label
(-class=>$emphasis.'ListRowEven',text
=>$temp);
1912 $w->bind('<ButtonPress>',[$this=>highlight
,$listbox{rows
}]);
1914 my$w=$widgetrow[$j]=$listbox{window
}->
1915 Label
(-class=>$emphasis.'ListRowOdd',text
=>$temp);
1916 $w->bind('<ButtonPress>',[$this=>highlight
,$listbox{rows
}]);
1930 # find widths col by col
1931 for(my$j=0;$j<$listbox{cols
};$j++){
1934 for(my$i=0;$i<$listbox{rows
};$i++){
1935 my$width=$widgetrows[$i][$j]->reqwidth();
1936 my$height=$widgetrows[$i][$j]->reqheight();
1937 $maxwidth[$j]=$width if($width>$maxwidth[$j]);
1938 $maxheight=$height if($height>$maxheight);
1941 if($j+1<$listbox{cols
}){
1942 for(my$i=0;$i<$listbox{rows
};$i++){
1943 $widgetrows[$i][$j]->
1944 place
(-height
=>$maxheight,-width
=>$maxwidth[$j],
1950 for(my$i=0;$i<$listbox{rows
};$i++){
1951 $widgetrows[$i][$j]->configure(-anchor
=>w
);
1952 $widgetrows[$i][$j]->
1953 place
(-height
=>$maxheight,-relwidth
=>1.0,
1954 -width
=>-$x,-x
=>$x,-y
=>$y);
1961 $pane->bind('<Configure>',[sub{$this->resize();}]);
1962 $listbox{window
}->configure(-height
=>$y);
1963 $scrollbar->configure(-command
=>[yview
=>$this]);
1970 $this->{frame
}->place(@_);
1976 $this->{frame
}->destroy();
1984 my$paneheight=$this->{pane
}->height();
1985 my$listheight=$this->{window
}->height();
1987 if($moveto_p=~/moveto/){
1988 my$y=int($moveto*$listheight);
1989 $y=$listheight-$paneheight if($y+$paneheight>$listheight);
1992 $this->{window
}->place(-y
=>-$y);
1993 $this->{scrollbar
}->set($this->yview());
1995 my$first=-$this->{window
}->y()/$listheight;
1996 my$second=(-$this->{window
}->y()+$paneheight)/$listheight;
2004 $this->{scrollbar
}->set($this->yview());
2011 if(defined($this->{'highlight'})){
2012 for(my$i=0;$i<$this->{'cols'};$i++){
2013 my$b=$this->{'widgetrows'}[$this->{'highlight'}][$i]->optionGet("background","");
2014 $this->{'widgetrows'}[$this->{'highlight'}][$i]->configure(-background
=>$b);
2018 $this->{'highlight'}=$row;
2019 for(my$i=0;$i<$this->{'cols'};$i++){
2020 my$b=$this->{'widgetrows'}[$row][$i]->optionGet("highlightBackground","");
2021 $this->{'widgetrows'}[$row][$i]->configure(-background
=>$b);
2024 if(defined($this->{'callback'})){
2025 $this->{'callback'}($row);
2032 $this->{'callback'}=shift;
2035 # these are a hack that doesn't quite work because Tk doesn't give
2036 # arbitrary control over toplevel, and I don't want to use menu
2037 # widgets for various reasons.
2039 package Snatch
::ClickList
;
2043 my$this=bless \
%clicklist;
2045 my$parent=$clicklist{parent
}=shift @_;
2046 my$var=$clicklist{variable
}=shift @_;
2052 $clicklist{textrows
}=\
@textrows;
2053 $clicklist{valrows
}=\
@valrows;
2054 $clicklist{widgetrows
}=\
@widgetrows;
2056 my$button=$clicklist{button
}=$parent->Button(-command
=>[$this=>poplist
],-class=>'ClickListButton');
2057 my$list=$clicklist{list
}=$parent->Frame(-class=>'ClickList');
2063 for($rows=0;;$rows++){
2066 if(defined($value)){
2067 $textrows[$rows]=$text;
2068 $valrows[$rows]=$value;
2070 my$w=$widgetrows[$rows]=$list->Button(-class=>'Item',-text
=>$text,
2071 -command
=>[$this=>setrow
,$rows]);
2072 $maxheight=$w->reqheight() if($w->reqheight()>$maxheight);
2073 $maxwidth=$w->reqwidth() if($w->reqwidth()>$maxwidth);
2082 $clicklist{rows
}=$rows;
2083 $clicklist{reqwidth
}=$maxwidth+=$list->optionGet(borderWidth
,"")*2;
2084 $clicklist{reqheight
}=$maxheight+=$list->optionGet(borderWidth
,"")*2;
2087 for(my$i=0;$i<$rows;$i++){
2088 $widgetrows[$i]->place(-y
=>$y,-relwidth
=>1.0,-height
=>$maxheight);
2091 $y+=$list->optionGet(borderWidth
,"")*2;
2094 $button->place(-height
=>$maxheight,-width
=>$maxwidth);
2095 $list->configure(-width
=>$maxwidth,-height
=>$y);
2096 $clicklist{maxheight
}=$y+$list->optionGet(borderWidth
,"")*2;
2099 $this->setval($$var);
2109 $this->{maxheight
}+$this->{reqheight
};
2119 $this->{button
}->place(@_);
2127 my$val=$this->{valrows
}[$row];
2129 $this->{'set'}=$row;
2130 ${$this->{'variable'}}=$val;
2131 $this->{'list'}->placeForget;
2132 $this->{'button'}->configure(-text
=>$this->{textrows
}[$this->{'set'}]);
2140 my$rows=$this->{rows
};
2141 for(my$i;$i<$rows;$i++){
2142 if("$this->{valrows}[$i]" eq "$val"){
2152 my$row=$this->{'set'};
2153 my$list=$this->{'list'};
2154 my$button=$this->{'button'};
2156 if(defined($this->{pop})){
2157 $list->placeForget();
2158 delete $this->{pop};
2161 $list->place(-in=>$button,-relwidth
=>1.0,-rely
=>1.0,-bordermode
=>outside
);