snatch/Snatch

   1 #!/usr/bin/perl
   2
   3 use Socket;
   4 use Sys::Hostname;
   5 use Time::Local;
   6 use IPC::Open3;
   7 use File::Glob ':glob';
   8 use Tk;
   9 use Tk::Xrm;
  10 use Tk qw(exit);
  11
  12 my $HOME=$ENV{"HOME"};
  13 if(!defined($HOME)){
  14     print "HOME environment variable not set.  Exiting.\n";
  15     exit 1;
  16 }
  17
  18 $version="Snatch 20020510";
  19 $configdir=$HOME."/.snatch";
  20 $configfile=$configdir."/config.txt";
  21 $historyfile=$configdir."/history.txt";
  22 $logofile=$configdir."/logo.xpm";
  23
  24 my $backchannel_socket="/tmp/snatch.$$";
  25 my $uaddr=sockaddr_un($backchannel_socket);
  26 my $proto=getprotobyname('tcp');
  27 my $comm_ready=0;
  28 my $mode='active';
  29
  30 # default config
  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';
  39
  40 if(! -e $configdir){
  41     die $! unless mkdir $configdir, 0770;
  42 }
  43
  44 $snatchxpm= <<'EOF';
  45 /* XPM */
  46 static char * snatch_xpm[] = {
  47 "36 27 25 1",
  48 "       c None",
  49 ".      c #060405",
  50 "+      c #8A8787",
  51 "@      c #8D1D27",
  52 "#      c #515052",
  53 "S      c #4F1314",
  54 "%      c #69272B",
  55 "&      c #AE5664",
  56 "*      c #D73138",
  57 "=      c #252524",
  58 "-      c #761922",
  59 ";      c #2D0505",
  60 ">      c #A53149",
  61 ",      c #C8C8C8",
  62 "'      c #676768",
  63 ")      c #F3F3F3",
  64 "!      c #A9A9A9",
  65 "~      c #7C5254",
  66 "{      c #F62F36",
  67 "]      c #9A9A99",
  68 "^      c #B32225",
  69 "/      c #261E24",
  70 "(      c #373736",
  71 "_      c #D7D7D7",
  72 ":      c #797978",
  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 "   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%   "};
 100 EOF
 101
 102 if(! -e $logofile){
 103     die $! unless open LFILE, ">$logofile";
 104     print LFILE $snatchxpm;
 105     close LFILE;
 106 }
 107
 108 # load the config/history
 109 if(-e $configfile){
 110     die $! unless open CFILE, $configfile;
 111     while(<CFILE>){
 112         /^\s*([^=]+)=([^\n]*)/;
 113         $CONFIG{$1}=$2;
 114     }
 115     close CFILE;
 116 }
 117
 118 if(-e $historyfile){
 119     die $! unless open HFILE, $historyfile;
 120     while(<HFILE>){
 121         chomp;
 122         if(length){
 123             push @TIMER, $_;
 124         }
 125     }
 126     close HFILE;
 127 }
 128 TimerSort();
 129
 130 # build the UI
 131 my $toplevel=new MainWindow(-class=>'Snatch');
 132 my $Xname=$toplevel->Class;
 133
 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);
 145
 146 $toplevel->optionAdd("$Xname*AlertDetail.font",
 147                      '-*-helvetica-medium-r-*-*-10-*-*-*-*-*-*-*',20);
 148
 149
 150 $toplevel->optionAdd("$Xname*background",  "#d0d0d0",20);
 151 $toplevel->optionAdd("$Xname*foreground",  '#000000',20);
 152
 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);
 157
 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);
 162
 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);
 175
 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);
 184
 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);
 189
 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);
 194
 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);
 201
 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);
 206
 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);
 211
 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);
 216
 217
 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);
 222
 223
 224
 225 $toplevel->configure(-background=>$toplevel->optionGet("background",""));
 226
 227 #$toplevel->resizable(FALSE,FALSE);
 228 my $xpm_snatch=$toplevel->Pixmap("_snatchlogo_xpm",-file=>$logofile);
 229
 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');
 233
 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);
 238
 239 $window_quit=$window_shell->Button(-class=>"Exit",text=>"quit")->
 240     place(-x=>-1,-y=>-1,-relx=>1.0,-rely=>1.0,-anchor=>'se');
 241
 242 $window_logo=$toplevel->
 243     Label(Name=>"logo",-class=>"Panel",image=>$xpm_snatch)->
 244     place(-x=>5,-y=>5,-anchor=>'nw');
 245
 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);
 249
 250
 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');
 254
 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);
 259
 260 $window_active=$window_shell->Button(Name=>"active",text=>"capture all",
 261                                     state=>disabled)->
 262     place(-x=>5,-y=>0,-relx=>0.,-rely=>.55,-relwidth=>.33,
 263           -width=>-5,-anchor=>'w',-in=>$window_shell);
 264
 265 $window_timer=$window_shell->Button(Name=>"timer",text=>"timed record",
 266                                     state=>disabled)->
 267     place(-x=>0,-y=>0,-relx=>.333,-rely=>.55,-relwidth=>.33,
 268           -width=>-0,-anchor=>'w',-in=>$window_shell);
 269
 270 $window_inactive=$window_shell->Button(Name=>"inactive",text=>"off",
 271                                     state=>disabled)->
 272     place(-x=>0,-y=>0,-relx=>.667,-rely=>.55,-relwidth=>.33,
 273           -width=>-5,-anchor=>'w',-in=>$window_shell);
 274
 275
 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);
 279
 280 $window_amute=$window_shell->Button(Name=>"audio",text=>"audio",
 281                                     state=>disabled)->
 282     place(-x=>2,-relx=>1.0,-relheight=>1.0,-anchor=>'nw',-in=>$window_mute,
 283           -bordermode=>outside);
 284
 285 $window_vmute=$window_shell->Button(Name=>"video",text=>"video",
 286                                     state=>disabled)->
 287     place(-x=>2,-relx=>1.0,-relheight=>1.0,-anchor=>'nw',-in=>$window_amute,
 288           -bordermode=>outside);
 289
 290 $minwidth=
 291     $window_logo->reqwidth()+
 292     $window_version->reqwidth()+
 293     $window_setupbar->reqwidth()+
 294     $window_timerbar->reqwidth()+
 295     30;
 296 $minheight=
 297     $window_logo->reqheight()+
 298     $window_statuslabel->reqheight()+
 299     $window_active->reqheight()+
 300     max($window_mute->reqheight(),$window_quit->reqheight())+
 301     30;
 302
 303 $toplevel->minsize($minwidth,$minheight);
 304
 305 my$geometry=$toplevel->optionGet("geometry","");
 306 if(defined($geometry)){
 307     $toplevel->geometry($geometry);
 308 }else{
 309     $toplevel->geometry(($minwidth+20).'x'.$minheight);
 310 }
 311 $toplevel->update();
 312
 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();}]);
 321
 322 # bind socket
 323 BindSocket();
 324
 325 # throw a realplayer process and
 326 ThrowRealPlayer();
 327
 328 # main loop
 329 Tk::MainLoop();
 330
 331 sub trim_glob{
 332     # the bsd glob routine deals poorly with some whitespace...
 333     my$pattern=shift;
 334     if($pattern eq ""){
 335         $pattern=".";
 336     }
 337     if($pattern ne '-'){
 338
 339         $pattern=~s/^(\s+).*//;
 340         $pattern=~s/(\s+)$//;
 341
 342         my@result=File::Glob::glob($pattern,GLOB_TILDE|GLOB_BRACE);
 343
 344         if(!defined($result[0])){
 345             @result=File::Glob::glob($pattern,GLOB_TILDE|GLOB_BRACE|GLOB_NOCHECK);
 346         }
 347         $result[0];
 348
 349     }else{
 350         '-';
 351     }
 352 }
 353
 354 sub ThrowRealPlayer{
 355     $recording_active=0;
 356     $recording_pending=0;
 357     $SIG{CHLD}='IGNORE';
 358
 359     Status("Starting RealPlayer...");
 360     # set up the environment
 361     my$glob=trim_glob("$CONFIG{'LIBSNATCH'}");
 362
 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");
 369         return;
 370     }
 371
 372     $ENV{"SNATCH_DEBUG"}=1;
 373     $ENV{"LD_PRELOAD"}=$glob;
 374     $ENV{"SNATCH_COMM_SOCKET"}=$backchannel_socket;
 375
 376     $glob=trim_glob("$CONFIG{'REALPLAYER'}");
 377
 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");
 384         return;
 385     }
 386
 387     die "pipe call failed unexpectedly: $!" unless pipe REAL_STDERR,WRITEH;
 388     $realpid=open3("STDIN",">&STDOUT",">&WRITEH",$glob);
 389     close WRITEH;
 390
 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;
 396     $ein=$rin | $win;
 397
 398     my $time=20;
 399     my $stderr_output;
 400
 401     Status("Waiting for rendevous... [$time]");
 402     while($time>0){
 403         my($nfound,$timeleft)=select($rout=$rin, $wout=$win, $eout=$ein, 1);
 404         if($nfound==0){
 405             $time--;
 406             Status("Waiting for rendevous... [$time]");
 407         }else{
 408             $toplevel->update();
 409             if(vec($rout,fileno(REAL_STDERR),1)){
 410                 $bytes=sysread REAL_STDERR, my$scalar, 4096;
 411                 $stderr_output.=$scalar;
 412
 413                 if($bytes==0){
 414                     Status("Rendevous failed.");
 415
 416                     Alert("RealPlayer didn't start successfully.  ".
 417                           "Here's the complete debugging output of the ".
 418                           "attempt:",
 419                           $stderr_output);
 420
 421                     return;
 422                 }
 423             }
 424             if(vec($rout,fileno(LISTEN_SOCK),1)){
 425                 # socket has a request
 426                 $status=accept(COMM_SOCK,LISTEN_SOCK);
 427                 $comm_ready=1;
 428                 $time=-1;
 429             }
 430         }
 431     }
 432
 433     if($time==0){
 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!");
 441         return;
 442     }
 443
 444     # configure
 445     Status("RealPlayer started...");
 446     $toplevel->fileevent(REAL_STDERR,'readable'=>[sub{ReadStderr();}]);
 447     ButtonConfig();
 448     SendConfig();
 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});
 453
 454 }
 455
 456 sub SendConfig{
 457     send_string("F",$CONFIG{'OUTPUT_PATH'});
 458     send_string("E",$CONFIG{'ESD_SOCK'});
 459     send_string("D",$CONFIG{'OSS_DEVICE'});
 460 }
 461
 462 sub BindSocket{
 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);
 468 }
 469
 470 sub Disconnect{
 471     $comm_ready=0;
 472     ButtonConfig();
 473     close COMM_SOCKET if($comm_ready);
 474     close REAL_STDERR if($comm_ready);
 475 }
 476
 477
 478 sub ReleaseSocket{
 479     $comm_ready=0;
 480     unlink($backchannel_socket);
 481     close(LISTEN_SOCK);
 482 }
 483
 484 sub AcceptSocket{
 485     Status("Waiting for rendevous...");
 486
 487     eval{
 488         local $SIG{ALRM} = sub { Status("Failed to rendevous"); };
 489         alarm 15;
 490         $status=accept(COMM_SOCK,LISTEN_SOCK);
 491         alarm 0;
 492         if($status){
 493             #enable the panel
 494             Status("RealPlayer contacted");
 495             $comm_ready=1;
 496             ButtonConfig();
 497         }
 498     }
 499 }
 500
 501 sub SaveConfig{
 502     die $! unless open CFILE, ">$configfile".".tmp";
 503     foreach $key (keys %CONFIG){
 504         print CFILE "$key=$CONFIG{$key}\n";
 505     }
 506     close CFILE;
 507     die $! unless rename "$configfile".".tmp", $configfile;
 508 }
 509
 510 sub SaveHistory{
 511     die $! unless open HFILE, ">$historyfile".".tmp";
 512     foreach $line (@TIMER){
 513         print HFILE "$line\n";
 514     }
 515     close HFILE;
 516     die $! unless rename "$historyfile".".tmp", $historyfile;
 517 }
 518
 519 sub Shutdown{
 520 # save the config/history
 521     Robot_Exit();
 522     ReleaseSocket();
 523     SaveConfig();
 524     SaveHistory();
 525
 526   Tk::exit(0);
 527 }
 528
 529
 530 sub send_string{
 531     my($op,$code)=@_;
 532     syswrite COMM_SOCK,$op;
 533     syswrite COMM_SOCK, (pack 'S', length $code);
 534     syswrite COMM_SOCK, $code;
 535 }
 536
 537 sub Robot_PlayLoc{
 538     my($loc,$username,$password)=@_;
 539     my $stopcode=join "",("Ks",pack ("S",4));
 540     my $loccode=join "",("Kl",pack ("S",4));
 541
 542     syswrite COMM_SOCK,$stopcode;
 543
 544     $recording_pending=1;
 545     send_string("P",$password);
 546     send_string("U",$username);
 547     send_string("L",$loc);
 548
 549     syswrite COMM_SOCK,$loccode;
 550
 551     # watch for bad password
 552 }
 553
 554 sub Robot_PlayFile{
 555     my($openfile)=@_;
 556     my $stopcode=join "",("Ks",pack ("S",4));
 557     my $opencode=join "",("Ko",pack ("S",4));
 558
 559     syswrite COMM_SOCK,$stopcode;
 560     $recording_pending=1;
 561     send_string("O",$openfile);
 562     syswrite COMM_SOCK,$opencode;
 563 }
 564
 565 sub Robot_Stop{
 566     my $stopcode=join "",("Ks",pack ("S",4));
 567     syswrite COMM_SOCK,$stopcode;
 568     $recording_pending=0;
 569 }
 570
 571 sub Robot_Exit{
 572     my $exitcode=join "",("Kx",pack ("S",4));
 573     syswrite COMM_SOCK,$playcode;
 574     Disconnect();
 575 }
 576
 577 sub Robot_Active{
 578     $next_timer_start=0;
 579     $next_timer_end=0;
 580     if(defined($timer_callback) && !recording_active){
 581         $timer_callback->cancel();
 582         undef $timer_callback;
 583     }
 584
 585     # clear out robot settings to avoid hopelessly confusing the user
 586     send_string("U","");
 587     send_string("P","");
 588     send_string("O","");
 589     send_string("L","");
 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);
 595     $mode='active';
 596     ButtonPressConfig();
 597 }
 598
 599 sub Robot_Inactive{
 600     $next_timer_start=0;
 601     $next_timer_end=0;
 602     $mode='inactive';
 603     if(defined($timer_callback)){
 604         $timer_callback->cancel();
 605         undef $timer_callback;
 606     }
 607
 608     send_string("U","");
 609     send_string("P","");
 610     send_string("O","");
 611     send_string("L","");
 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");
 617     ButtonPressConfig();
 618 }
 619
 620 sub Robot_Timer{
 621     $next_timer_start=0;
 622     $next_timer_end=0;
 623     send_string("O","");
 624     send_string("L","");
 625     syswrite COMM_SOCK,'T';
 626     Status("Timer wait");
 627     $mode='timer';
 628     ButtonPressConfig();
 629     SetupTimerDispatch();
 630     if(!defined($timer_callback)){
 631         $timer_callback=$toplevel->repeat(1000,[main::TimerWatch]);
 632     }
 633 }
 634
 635 sub DoTimedEntry{
 636     my($start,$line)=@_;
 637     my($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
 638        $password,$outfile,$url)=SplitTimerEntry($line);
 639
 640     syswrite COMM_SOCK,'A';
 641     send_string("F",$outfile);
 642     Robot_Audio($audio);
 643     Robot_Video($video);
 644     if($url=~/^file:(.*)/){
 645         #file, through the file dialog
 646         Robot_PlayFile($1);
 647     }else{
 648         #network stream/URL, through location dialog
 649         Robot_PlayLoc($url,$username,$password);
 650     }
 651 }
 652
 653 sub SetupTimerDispatch{
 654     ListBoxUpdate();
 655     my$now=time();
 656     my@TIMETEMP=@TIMER_TIMES;
 657     my@ENDTIMETEMP=@TIMER_ENDTIMES;
 658     $next_timer_start=0;
 659     $next_timer_end=0;
 660
 661     foreach my$line (@TIMER){
 662         my$start=shift @TIMETEMP;
 663         my$end=shift @ENDTIMETEMP;
 664
 665         if($start<=$now && $end>$now){
 666             Robot_Stop();
 667             $next_timer_start=$start;
 668             $next_timer_end=$end;
 669             DoTimedEntry($start,$line);
 670             return;
 671         }else{
 672             $next_timer_start=$start if(($next_timer_start==0 ||
 673                                         $start<$next_timer_start) && $start>$now);
 674         }
 675     }
 676     # nothing happening now
 677     Robot_Stop();
 678     syswrite COMM_SOCK,'T';
 679 }
 680
 681 sub TimerWatch{
 682     if($mode=~/timer/){
 683         my$now=time();
 684
 685         if($TIMER_ENDTIMES[$TIMER_SORTED[$#TIMER]]<=$now){
 686             Robot_Inactive();
 687             Robot_Stop();
 688             ListBoxUpdate();
 689             ButtonConfig();
 690         }else{
 691
 692             my $next;
 693             if($recording_active || $recording_pending){
 694                 $next=$next_timer_end;
 695             }else{
 696                 $next=$next_timer_start;
 697             }
 698
 699             if($now>=$next){
 700                 SetupTimerDispatch();
 701             }else{
 702
 703                 my$waiting_seconds=$next-$now;
 704
 705                 my$waiting_minutes=int($waiting_seconds/60);
 706                 $waiting_seconds-=$waiting_minutes*60;
 707
 708                 my$waiting_hours=int($waiting_minutes/60);
 709                 $waiting_minutes-=$waiting_hours*60;
 710
 711                 my$waiting_days=int($waiting_hours/24);
 712                 $waiting_hours-=$waiting_days*24;
 713                 my$prompt;
 714
 715                 if($waiting_days){
 716                     $prompt=$waiting_days."d ".$waiting_hours."h ".
 717                         $waiting_minutes."m";
 718                 }elsif($waiting_hours){
 719                     $prompt=$waiting_hours."h ".$waiting_minutes."m";
 720                 }else{
 721                     $prompt=$waiting_minutes."m ".$waiting_seconds."s";
 722                 }
 723
 724                 if($recording_active){
 725                     Status("Timer recording [$prompt]");
 726                 }else{
 727                     if($recording_pending){
 728                         Status("Starting record...");
 729                     }else{
 730                         Status("Timer wait [$prompt]");
 731                     }
 732                 }
 733             }
 734         }
 735     }else{
 736         if($recording_active){
 737
 738             my$now=time();
 739             my$seconds=$now-$recording_active;
 740
 741             my$minutes=int($seconds/60);
 742             $seconds-=$minutes*60;
 743
 744             my$hours=int($minutes/60);
 745             $minutes-=$hours*60;
 746
 747             my$prompt;
 748
 749             if($hours){
 750                 $prompt=$hours."h ".$minutes."m";
 751             }else{
 752                 $prompt=$minutes."m ".$seconds."s";
 753             }
 754
 755
 756             Status("Recording [$prompt]");
 757         }else{
 758             if($recording_pending){
 759                 Status("Starting record...");
 760             }else{
 761                 Status("Ready/waiting to record");
 762             }
 763             $timer_callback->cancel();
 764             undef $timer_callback;
 765         }
 766     }
 767 }
 768
 769 sub Robot_Audio{
 770     my($onoff)=@_;
 771
 772     if($onoff=~m/yes/){
 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';
 778     }else{
 779         if($CONFIG{"AUDIO_MUTE"}=~/yes/){
 780             syswrite COMM_SOCK,'S';
 781             $CONFIG{"AUDIO_MUTE"}='no';
 782         }else{
 783             syswrite COMM_SOCK,'s';
 784             $CONFIG{"AUDIO_MUTE"}='yes';
 785         }
 786     }
 787     ButtonPressConfig();
 788
 789 }
 790
 791 sub Robot_Video{
 792     my($onoff)=@_;
 793
 794     if($onoff=~m/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';
 800     }else{
 801         if($CONFIG{"VIDEO_MUTE"}=~/yes/){
 802             syswrite COMM_SOCK,'V';
 803             $CONFIG{"VIDEO_MUTE"}='no';
 804         }else{
 805             syswrite COMM_SOCK,'v';
 806             $CONFIG{"VIDEO_MUTE"}='yes';
 807         }
 808     }
 809     ButtonPressConfig();
 810 }
 811
 812 sub SplitTimerEntry{
 813     my($line)=@_;
 814
 815     if($line=~/^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\d+):(\d+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(.*)/){
 816         my $year=$1;
 817         my $month=$2;
 818         my $day=$3;
 819         my $dayofweek=$4;
 820         my $hour=$5;
 821         my $minute=$6;
 822         my $duration=$7;
 823
 824         my $audio=$8;
 825         my $video=$9;
 826
 827         my $fields=$10;
 828
 829         my $username;
 830         my $password;
 831         my $outfile;
 832         my $url;
 833
 834         ($username,$fields)=LengthParse($fields);
 835         ($password,$fields)=LengthParse($fields);
 836         ($outfile,$fields)=LengthParse($fields);
 837         ($url,$fields)=LengthParse($fields);
 838
 839         ($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
 840          $password,$outfile,$url);
 841     }else{
 842         undef;
 843     }
 844 }
 845
 846 sub LengthParse{
 847     my($line)=@_;
 848     $line=~/(\d+):(.*)/;
 849     $length=$1;
 850     $rest=$2;
 851
 852     (substr($rest,0,$length),substr($rest,$length));
 853 }
 854
 855 sub MonthDays{
 856     my($month,$year)=@_;
 857
 858     if($month==2){
 859         if($year % 4 !=0){
 860             28;
 861         }elsif ($year % 400 == 0){
 862             29;
 863         }elsif ($year % 100 == 0){
 864             28;
 865         }else{
 866             29;
 867         }
 868     }else{
 869         my @trans=(0,31,0,31,30,31,30,31,31,30,31,30,31);
 870         $trans[$month];
 871     }
 872 }
 873
 874 sub TimerStart{
 875     my($try,$etry)=TimerWhen(@_);
 876     $try;
 877 }
 878
 879 sub TimerWhen{
 880     my($try,$etry,$year,$month,$day,$dayofweek,$hour,$minute,$duration)=@_;
 881
 882     #overguard
 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++;};
 892         }
 893     }
 894     if($month ne '*'){while($month>12){$month-=12;
 895                                        $year++ if ($year ne '*')}};
 896
 897     my $now=time();
 898     my($nowsec,$nowmin,$nowhour,$nowday,$nowmonth,$nowyear)=localtime($now);
 899     $nowmon++;
 900     $nowyear+=1900;
 901
 902
 903     # boundary cases in each...  rather than solving it exactly, we'll
 904     # solve it empirically. Laziness as a virtue.
 905     if($year eq '*'){
 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);
 920         }
 921     }elsif($day eq '*'){
 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);
 927         }
 928     }elsif($hour eq "*"){
 929         return ($try,$etry);
 930     }elsif($minute eq "*"){
 931         return ($try,$etry);
 932     }elsif($duration eq "*"){
 933         return ($try,$etry);
 934     }else{
 935         if($month==0){
 936             # oops; we got a bad line in the history file
 937             return ($try,$etry);
 938         }
 939
 940         my $start=timelocal(0,$minute,$hour,$day,$month-1,$year);
 941         my $end=$start+$duration;
 942
 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)};
 947         }
 948
 949         if($try==-1){
 950             return($start,$end);
 951         }
 952
 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);
 958             }
 959         }
 960
 961         if($etry<=$now){
 962             # current guess entirely preceeds now; prefer any guess in the future
 963             return ($start,$end) if($start>=$try);
 964         }
 965
 966         if($try>$now){
 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);
 969         }
 970
 971     }
 972     ($try,$etry);
 973 }
 974
 975 sub max{
 976     my$val=shift @_;
 977     while (defined(my$n=shift @_)){
 978         $val=$n if($n>$val);
 979     }
 980     $val;
 981 }
 982
 983 sub Status{
 984     $window_status->configure(text=>shift @_);
 985     $toplevel->update();
 986 }
 987
 988 sub Alert{
 989     my($message,$detail,$window)=@_;
 990
 991     $window=$toplevel if(!defined($window));
 992     $modal->destroy() if(defined($modal));
 993
 994     $modal=new MainWindow(-class=>"$Xname");
 995     $modal->configure(-background=>$modal->optionGet("background",""));
 996
 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');
1001
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');
1005
1006     $modal_message=$modal_shell->
1007         Label(text=>$message,-class=>"AlertText")->
1008             place(-x=>5,-y=>10);
1009
1010     $width=$modal_message->reqwidth();
1011     $width=300 if($width<300);
1012
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);
1018
1019     $width+=20;
1020     $height=$modal_message->reqheight()+$modal_detail->reqheight()+30;
1021
1022     my$xx=$window->rootx();
1023     my$yy=$window->rooty();
1024     my$ww=$window->width();
1025     my$hh=$window->height();
1026
1027     $x=$xx+$ww/2-$width/2;
1028     $y=$yy+$hh/2-$height/2;
1029
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}]);
1034 }
1035
1036 sub ReadStderr{
1037     my$saveflag=0;
1038
1039     $bytes=sysread REAL_STDERR, my$scalar, 4096;
1040     if($bytes==0){
1041         Disconnect();
1042         Alert("RealPlayer unexpectedly exited!","Attempting to start a new copy...\n");
1043         $toplevel->fileevent(REAL_STDERR,'readable' => '');
1044         ThrowRealPlayer();
1045     }
1046
1047     print STDERR $scalar if($CONFIG{'DEBUG'} eq 'yes');
1048
1049     push my@lines, split /\n/, $saved_stderr.$scalar;
1050     if((chomp $scalar)==0){
1051         $saved_stderr=$lines[$#lines];
1052     }else{
1053         $saved_stderr="";
1054     }
1055
1056     foreach my$line (@lines){
1057
1058         if($line=~/X display closed/){
1059             Disconnect();
1060             $toplevel->fileevent(REAL_STDERR,'readable' => '');
1061           Tk::exit(0);
1062         }
1063
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");
1073         }
1074
1075
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");
1082         }
1083
1084         if($line=~/Capture stopped/){
1085             $recording_active=0;
1086             $recording_pending=0;
1087
1088             if($mode=~/timer/){
1089                 SetupTimerDispatch();
1090             }
1091
1092         }
1093
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();}]);
1099             }
1100         }
1101     }
1102 }
1103
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');
1111
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');
1116
1117     if(defined($tentry)){
1118
1119         if($mode=~/^active/ || ($mode=~/timer/ && ($recording_active ||
1120                                                    $recording_pending))){
1121             $tentry_test->configure(-state=>disabled);
1122         }else{
1123             $tentry_test->configure(-state=>normal);
1124         }
1125
1126     }
1127
1128 }
1129
1130 sub ButtonConfig{
1131     my$now=time();
1132     if ($#TIMER<0 || $TIMER_ENDTIMES[$TIMER_SORTED[$#TIMER]]<$now ||
1133         !$comm_ready){
1134         $window_timer->configure(state=>disabled);
1135     }else{
1136         $window_timer->configure(state=>normal);
1137     }
1138     if (!$comm_ready){
1139         $window_active->configure(state=>disabled);
1140         $window_inactive->configure(state=>disabled);
1141         $window_amute->configure(state=>disabled);
1142         $window_vmute->configure(state=>disabled);
1143     }else{
1144         $window_active->configure(state=>normal);
1145         $window_inactive->configure(state=>normal);
1146         $window_amute->configure(state=>normal);
1147         $window_vmute->configure(state=>normal);
1148     }
1149     ButtonPressConfig();
1150 }
1151
1152 sub Setup{
1153     %TEMPCONF=%CONFIG;
1154
1155     $window_setupbar->configure(-state=>'disabled');
1156     $window_setupbar->configure(-relief=>'flat');
1157     $setup=new MainWindow(-class=>'Snatch');
1158
1159     $setup_title=$setup->
1160         Label(Name=>"setup text",-class=>"Panel",text=>"Configuration")->
1161                   place(-x=>10,-y=>5);
1162
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');
1166
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');
1177
1178
1179     # Real location
1180     $nexty=5;
1181     $temp=$setup_shell->
1182         Label(text=>"RealPlayer location:")->
1183             place(-x=>5,-y=>$nexty);
1184     $setup_shell->
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();
1191
1192     #libsnatch location
1193     $temp=$setup_shell->
1194         Label(text=>"libsnatch.so location:")->
1195             place(-x=>5,-y=>$nexty);
1196     $setup_shell->
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();
1203
1204     #audio device
1205     $temp=$setup_shell->
1206         Label(text=>"OSS audio device:")->
1207             place(-x=>5,-y=>$nexty);
1208     $setup_shell->
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();
1215
1216     #esd port
1217     $temp=$setup_shell->
1218         Label(text=>"EsounD server socket:")->
1219             place(-x=>5,-y=>$nexty);
1220     $setup_shell->
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();
1227
1228     #debug
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);
1233     }else{
1234         $temp=$setup_debug=$setup_shell->
1235             Button(text=>"full debug output",-pady=>1)->
1236                    place(-x=>5,-y=>$nexty);
1237     }
1238     $setup_debug->configure(-command=>[sub{Setup_Debug();}]);
1239     $nexty+=15+$temp->reqheight();
1240
1241     #output path
1242     $temp=$setup_shell->
1243         Label(text=>"capture output:")->
1244             place(-x=>5,-y=>$nexty);
1245
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,
1251                   -relwidth=>1.0);
1252
1253     $nexty+=15+$temp->reqheight();
1254
1255
1256     $minwidth=400;
1257     $minheight=$nexty+28+$setup_title->reqheight()+$setup_cancel->reqheight();
1258
1259     $setup->minsize($minwidth,$minheight);
1260     $setup->geometry(($minwidth+20)."x".$minheight);
1261
1262     $setup_quit->configure(-command=>[sub{
1263         my $temppath=$TEMPCONF{"OUTPUT_PATH"};
1264         if(TestOutpath($temppath,$setup)){
1265             %CONFIG=%TEMPCONF;
1266             $setup->destroy();undef $setup;
1267             $CONFIG{OUTPUT_PATH}=trim_glob($temppath);
1268             $window_setupbar->configure(state=>'normal');
1269             $window_setupbar->configure(relief=>'raised');
1270             SaveConfig();
1271             SendConfig();
1272             ThrowRealPlayer() if(!$comm_ready);
1273             Status("Configuration successful");
1274         }
1275     }]);
1276
1277     $setup_apply->configure(-command=>[sub{
1278         my $temppath=$TEMPCONF{"OUTPUT_PATH"};
1279
1280         if(TestOutpath($temppath,$setup)){
1281             %CONFIG=%TEMPCONF;
1282             $CONFIG{OUTPUT_PATH}=trim_glob($temppath);
1283             SaveConfig();
1284             SendConfig();
1285             ThrowRealPlayer() if(!$comm_ready);
1286             Status("Configuration successful");
1287         }
1288     }]);
1289
1290     $setup_cancel->configure(-command=>[sub{
1291         $setup->destroy();undef $setup;
1292         $window_setupbar->configure(state=>'normal');
1293         $window_setupbar->configure(relief=>'raised');
1294     }]);
1295
1296 }
1297
1298 sub TestOutpath{
1299     my $path=shift;
1300     my $window=shift;
1301
1302     if($path ne '-'){
1303         $path=trim_glob($path);
1304         if(!-W $path){
1305             # in the event this is a file spec in a writable directory, try touching it
1306             if(open (TEST,">$path")){
1307                 # oh, ok...
1308                 close(TEST);
1309                 unlink($path);
1310                 return 1;
1311             }
1312
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);
1318             return 0;
1319         }
1320     }
1321     1;
1322 }
1323
1324 sub Setup_Debug{
1325     if($TEMPCONF{'DEBUG'} eq 'yes'){
1326         $TEMPCONF{'DEBUG'}='no';
1327         $setup_debug->configure(-relief=>groove);
1328     }else{
1329         $TEMPCONF{'DEBUG'}='yes';
1330         $setup_debug->configure(-relief=>sunken);
1331     }
1332 }
1333
1334 sub Timer{
1335
1336     $window_timerbar->configure(-state=>'disabled');
1337     $window_timerbar->configure(-relief=>'flat');
1338     $timerw=new MainWindow(-class=>'Snatch');
1339
1340     $timerw_title=$timerw->
1341         Label(Name=>"timer text",-class=>"Panel",text=>"Timer Setup")->
1342             place(-x=>10,-y=>5);
1343
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');
1347
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');
1351
1352     $timerw_quit->configure(-command=>[sub{
1353         $timerw->destroy();
1354         undef $listbox;
1355         undef $timerw;
1356         $window_timerbar->configure(state=>'normal');
1357         $window_timerbar->configure(relief=>'raised');
1358     }]);
1359
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');
1364
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);
1377
1378     $minwidth=500;
1379     $minheight=$timerw_add->reqheight()*4+$timerw_quit->reqheight()+$timerw_title->reqheight()+95;
1380
1381     $timerw->minsize($minwidth,$minheight);
1382     $timerw->geometry(($minwidth+20)."x".$minheight);
1383
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();}]);
1388
1389     $listbox=BuildListBox();
1390
1391 }
1392
1393 sub BuildListBox(){
1394     $listbox->destroy() if(defined($listbox));
1395
1396     # assemble the sorted timer elements we're actually interested into an array for listbox
1397     my$n=$#TIMER;
1398     my@listarray;
1399
1400     $daytrans={
1401         '*','*',
1402         '0',"Sunday ",
1403         '1',"Monday ",
1404         '2',"Tuesday ",
1405         '3',"Wednesday ",
1406         '4',"Thursday ",
1407         '5',"Friday ",
1408         '6',"Saturday "};
1409
1410     $monthtrans={
1411         '*','*',
1412         '1',"January ",
1413         '2',"February ",
1414         '3',"March ",
1415         '4',"April ",
1416         '5',"May ",
1417         '6',"June ",
1418         '7',"July ",
1419         '8',"August ",
1420         '9',"September ",
1421         '10',"October ",
1422         "11","November ",
1423         "12","December "};
1424
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]]);
1428         if(defined($url)){
1429             my$start=$TIMER_TIMES[$TIMER_SORTED[$i]];
1430             #also need the end...
1431             my$end=$TIMER_TIMES[$TIMER_SORTED[$i]]+$duration;
1432             my$now=time();
1433             my$emph='';
1434             if($end<$now){
1435                 $emph='Old';
1436             }
1437
1438             my$dur_hours=int($duration/3600);
1439             $duration-=$dur_hours*3600;
1440             my$dur_minutes=int($duration/60);
1441             $duration-=$dur_minutes*60;
1442
1443             if($dur_hours==0){
1444                 $dur_hours='00:';
1445             }else{
1446                 $dur_hours.=":";
1447             }
1448
1449             $dur_minutes='0'.int($dur_minutes) if($dur_minutes <10);
1450             $minute='0'.int($minute) if($minute <10);
1451
1452             push @listarray, "$emph","$year ",$monthtrans->{$month},"$day ",
1453             $daytrans->{$dayofweek},"$hour:$minute ","$dur_hours$dur_minutes ",$url;
1454         }else{
1455             # bad entry; prevent death
1456             push @listarray, "Old","X ","X ","X ","X ","XXX ","XXX ","Bad Entry ";
1457
1458         }
1459     }
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,
1463               -height=>-10,
1464               -bordermode=>outside);
1465
1466     $listbox->callback(\&Timer_Highlight);
1467     undef $timer_row;
1468
1469     $timerw->update();
1470     CheckTimerOverlap();
1471
1472     $listbox;
1473 }
1474
1475 sub ListBoxUpdate{
1476     TimerSort();
1477     ButtonConfig();
1478     if(defined($timerw)){
1479         BuildListBox();
1480
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);
1486         }
1487     }
1488 }
1489
1490 sub CheckTimerOverlap{
1491     my$rows=($#TIMER)+1;
1492
1493     foreach my$line (@TIMER){
1494         $rows++;
1495     }
1496
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];
1503
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",
1511                           $timerw);
1512                     return;
1513                 }
1514             }
1515         }
1516     }
1517 }
1518
1519 sub TimerSort{
1520     $count=0;
1521     my@TIMER_FULL=(map {TimerWhen(-1,-1,(SplitTimerEntry($_)))} @TIMER);
1522     undef @TIMER_TIMES;
1523     undef @TIMER_ENDTIMES;
1524     while(1){
1525         my$temp=shift @TIMER_FULL;
1526         if(defined($temp)){
1527             push @TIMER_TIMES, $temp;
1528             push @TIMER_ENDTIMES, shift @TIMER_FULL;
1529         }else{
1530             last;
1531         }
1532     }
1533     @TIMER_SORTED=sort {$TIMER_TIMES[$a]-$TIMER_TIMES[$b]} (map {$count++} @TIMER);
1534 }
1535
1536 sub Timer_Highlight{
1537     if(!defined($tentry)){
1538         if(defined($highlightnow) && $highlightnow+2>time){
1539
1540             if($timer_row==$_[0]){
1541                 # doubleclick hack.  Edit this entry
1542                 Timer_Edit();
1543                 return;
1544             }
1545         }
1546
1547
1548         $timerw_edit->configure(-state=>normal);
1549         $timerw_delete->configure(-state=>normal);
1550         $timerw_duplicate->configure(-state=>normal);
1551         $timer_row=shift;
1552
1553         $highlightnow=time;
1554     }
1555 }
1556
1557 sub Timer_Delete{
1558     # which real (not sorted) row of the timer array is this?
1559     my$actual_row=$TIMER_SORTED[$timer_row];
1560
1561     splice @TIMER,$actual_row,1;
1562     TimerSort();
1563     SaveHistory();
1564     ButtonConfig();
1565     $timerw_edit->configure(-state=>disabled);
1566     $timerw_delete->configure(-state=>disabled);
1567     $timerw_duplicate->configure(-state=>disabled);
1568     BuildListBox();
1569 }
1570
1571 sub Timer_Add{
1572     my($nowsec,$nowmin,$nowhour,$nowday,$nowmonth,$nowyear)=localtime time;
1573     $nowmonth+=1;
1574     $nowyear+=1900;
1575     Timer_Entry(-1,"$nowyear $nowmonth $nowday * $nowhour:$nowmin 3600 yes yes 0: 0: ".
1576                "0: 0:");
1577 }
1578
1579 sub Timer_Edit{
1580     Timer_Entry($TIMER_SORTED[$timer_row],$TIMER[$TIMER_SORTED[$timer_row]]);
1581 }
1582
1583 sub Timer_Copy{
1584     Timer_Entry(-1,$TIMER[$TIMER_SORTED[$timer_row]]);
1585 }
1586
1587 sub Timer_Entry{
1588     my$row=shift;
1589
1590     my($year,$month,$day,$dayofweek,$hour,$minute,$duration,$audio,$video,$username,
1591        $password,$dummy,$url)=SplitTimerEntry(shift);
1592
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);
1597
1598
1599     my($nowsec,$nowmin,$nowhour,$nowday,$nowmonth,$nowyear)=localtime time;
1600
1601     $nowmonth++;
1602     $nowyear+=1900;
1603
1604     $timerw_add->configure(-state=>disabled);
1605     $timerw_edit->configure(-state=>disabled);
1606     $timerw_duplicate->configure(-state=>disabled);
1607     $timerw_delete->configure(-state=>disabled);
1608
1609     $tentry=new MainWindow(-class=>'Snatch');
1610
1611     $tentry_title=$tentry->
1612         Label(Name=>"timer text",-class=>"Panel",text=>"Add/Edit Timer Entry")->
1613             place(-x=>10,-y=>5);
1614
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');
1618
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');
1625
1626     $tentry_quit->configure(-command=>[sub{
1627
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);
1631         if($time<0){
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);
1637         }else{
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";
1642
1643             if($row<0){
1644                 push @TIMER, $entry;
1645                 TimerSort();
1646                 ButtonConfig();
1647             }else{
1648                 splice @TIMER,$row,1,$entry;
1649                 TimerSort();
1650                 ButtonConfig();
1651             }
1652
1653             SaveHistory();
1654
1655             if(defined($timerw)){
1656                 BuildListBox();
1657
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);
1663                 }
1664             }
1665
1666             $tentry->destroy();
1667             undef $tentry;
1668         }
1669     }]);
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);
1677             }
1678         }
1679         $tentry->destroy();
1680         undef $tentry;
1681     }]);
1682
1683     # bwah ha ha.  The bitter end.
1684     my $x=5;
1685     my $y=10;
1686     my$reqheight=0;
1687
1688     my$t=$tentry_shell->Label(-text=>"Date:")->
1689         place(-x=>$x, -y=>$y, -bordermode=>outside);
1690     $x+=$t->reqwidth()+5;
1691
1692     # Year
1693     my$tt=Snatch::ClickList::new($tentry_shell,\$year,
1694                                  "* (any)",'*',
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);
1701
1702     $t->place(-height=>$tt->reqheight());
1703
1704     # month
1705     my$t=Snatch::ClickList::new($tentry_shell,\$month,
1706                                  "* (any)",'*',
1707                                  "January","1",
1708                                  "February","2",
1709                                  "March","3",
1710                                  "April","4",
1711                                  "May","5",
1712                                  "June","6",
1713                                  "July","7",
1714                                  "August","8",
1715                                  "September","9",
1716                                  "October","10",
1717                                  "November","11",
1718                                  "December","12")->
1719                                      place(-x=>$x,-y=>$y,-bordermode=>outside);
1720     $x+=$t->reqwidth+5;
1721     $reqheight=$t->maxheight()if($t->maxheight()>$reqheight);
1722
1723     # day
1724     my$t=$tentry_shell->Entry(-width=>2,-textvariable=>\$day,-justify=>right)->
1725         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1726     $x+=$t->reqwidth+5;
1727
1728     # day of week
1729     my$t=Snatch::ClickList::new($tentry_shell,\$dayofweek,
1730                                  "* (any)",'*',
1731                                  "Sunday","0",
1732                                  "Monday","1",
1733                                  "Tuesday","2",
1734                                  "Wednesday","3",
1735                                  "Thursday","4",
1736                                  "Friday","5",
1737                                  "Saturday","6")->
1738                                      place(-x=>$x,-y=>$y,-bordermode=>outside);
1739     $x+=$t->reqwidth+15;
1740     $reqheight=$t->maxheight()if($t->maxheight()>$reqheight);
1741
1742     my$t=$tentry_shell->Label(-text=>"Time:")->
1743         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1744     $x+=$t->reqwidth()+5;
1745
1746     # hour
1747     my$t=$tentry_shell->Entry(-width=>2,-textvariable=>\$hour,-justify=>right)->
1748         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1749     $x+=$t->reqwidth();
1750
1751     my$t=$tentry_shell->Label(-text=>":")->
1752         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1753     $x+=$t->reqwidth();
1754
1755     # minute
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;
1759
1760     my$t=$tentry_shell->Label(-text=>"Duration:")->
1761         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1762     $x+=$t->reqwidth()+5;
1763
1764     # duration hour
1765     my$t=$tentry_shell->Entry(-width=>2,-textvariable=>\$duration_hour,-justify=>right)->
1766         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1767     $x+=$t->reqwidth();
1768
1769     my$t=$tentry_shell->Label(-text=>":")->
1770         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1771     $x+=$t->reqwidth();
1772
1773     # duration minute
1774     my$t=$tentry_shell->Entry(-width=>2,-textvariable=>\$duration_minute,-justify=>right)->
1775         place(-x=>$x, -y=>$y, -height=>$tt->reqheight(),-bordermode=>outside);
1776     $x+=$t->reqwidth+5;
1777
1778     my$reqwidth=$x+25;
1779     $reqheight+=$tentry_title->reqheight()+35;  # this is just for the pulldown menus
1780     $y+=$tt->reqheight()+20;
1781
1782
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;
1798
1799
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]);
1807
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);
1811
1812     if($mode=~/^active/ || ($mode=~/timer/ && ($recording_active || $recording_pending))){
1813         $tentry_test->configure(-state=>disabled);
1814     }
1815
1816     $tentry_test->configure(-command=>[sub{
1817
1818         Robot_Audio($audio);
1819         Robot_Video($video);
1820         if($url=~/^file:(.*)/){
1821             #file, through the file dialog
1822             Robot_PlayFile($1);
1823         }else{
1824             #network stream/URL, through location dialog
1825             Robot_PlayLoc($url,$username,$password);
1826         }
1827     }]);
1828
1829     #laziness
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;
1835
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, ".
1843                 "play audio ".
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 ".
1846                 "applications.",
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;
1851
1852
1853     $reqheight=max($reqheight,$y+$tentry_quit->reqheight+$tentry_title->reqheight()+35);
1854
1855     $tentry->minsize($reqwidth,$reqheight);
1856     $tentry->geometry($reqwidth."x".$reqheight);
1857
1858 }
1859
1860 sub nonmomentary{
1861     my($buttonref,$valref)=@_;
1862
1863     if($$valref eq 'yes'){
1864         $$valref='no';
1865         $$buttonref->configure(-relief=>groove);
1866     }else{
1867         $$valref='yes';
1868         $$buttonref->configure(-relief=>sunken);
1869     }
1870 }
1871 package Snatch::ListBox;
1872
1873 sub new{
1874     my%listbox;
1875     my$this=bless \%listbox;
1876
1877     my$parent=shift @_;
1878     my$cols=$listbox{cols}=shift @_;
1879     $listbox{rows}=0;
1880     my@textrows;
1881     my@widgetrows;
1882
1883     $listbox{textrows}=\@textrows;
1884     $listbox{widgetrows}=\@widgetrows;
1885
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());
1891
1892     $listbox{window}=$pane->Frame(-class=>'ListFrame')->place(-relwidth=>1.0);
1893
1894     my$maxheight=0;
1895
1896     # row by row
1897     my$done=0;
1898     for($listbox{rows}=0;!$done;$listbox{rows}++){
1899         my @textrow=();
1900         my @widgetrow=();
1901         $textrows[$listbox{rows}]=\@textrow;
1902         $widgetrows[$listbox{rows}]=\@widgetrow;
1903         my$emphasis=shift;
1904
1905         for(my$j=0;$j<$cols;$j++){
1906             my$temp=shift;
1907             if(defined($temp)){
1908                 $textrow[$j]=$temp;
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}]);
1913                 }else{
1914                     my$w=$widgetrow[$j]=$listbox{window}->
1915                         Label(-class=>$emphasis.'ListRowOdd',text=>$temp);
1916                     $w->bind('<ButtonPress>',[$this=>highlight,$listbox{rows}]);
1917                 }
1918             }else{
1919                 $done=1;
1920                 last;
1921             }
1922         }
1923     }
1924     $listbox{rows}--;
1925
1926     my@maxwidth;
1927     my$x=0;
1928     my$y=0;
1929
1930     # find widths col by col
1931     for(my$j=0;$j<$listbox{cols};$j++){
1932         $y=0;
1933         $maxwidth[$j]=0;
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);
1939         }
1940
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],
1945                           -x=>$x,-y=>$y);
1946                 $y+=$maxheight+3;
1947             }
1948             $x+=$maxwidth[$j];
1949         }else{
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);
1955                 $y+=$maxheight+3;
1956             }
1957             $x+=$maxwidth[$j];
1958         }
1959     }
1960
1961     $pane->bind('<Configure>',[sub{$this->resize();}]);
1962     $listbox{window}->configure(-height=>$y);
1963     $scrollbar->configure(-command=>[yview=>$this]);
1964
1965     $this;
1966 }
1967
1968 sub place{
1969     my$this=shift;
1970     $this->{frame}->place(@_);
1971     $this;
1972 }
1973
1974 sub destroy{
1975     my$this=shift;
1976     $this->{frame}->destroy();
1977 }
1978
1979 sub yview{
1980     my$this=shift;
1981     my$moveto_p=shift;
1982     my$moveto=shift;
1983
1984     my$paneheight=$this->{pane}->height();
1985     my$listheight=$this->{window}->height();
1986
1987     if($moveto_p=~/moveto/){
1988         my$y=int($moveto*$listheight);
1989         $y=$listheight-$paneheight if($y+$paneheight>$listheight);
1990         $y=0 if($y<0);
1991
1992         $this->{window}->place(-y=>-$y);
1993         $this->{scrollbar}->set($this->yview());
1994     }else{
1995         my$first=-$this->{window}->y()/$listheight;
1996         my$second=(-$this->{window}->y()+$paneheight)/$listheight;
1997
1998         ($first,$second);
1999     }
2000 }
2001
2002 sub resize{
2003     my$this=shift;
2004     $this->{scrollbar}->set($this->yview());
2005 }
2006
2007 sub highlight{
2008     my$this=shift;
2009     my$row=shift;
2010
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);
2015         }
2016     }
2017
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);
2022     }
2023
2024     if(defined($this->{'callback'})){
2025         $this->{'callback'}($row);
2026     }
2027
2028 }
2029
2030 sub callback{
2031     $this=shift;
2032     $this->{'callback'}=shift;
2033 }
2034
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.
2038
2039 package Snatch::ClickList;
2040
2041 sub new{
2042     my%clicklist;
2043     my$this=bless \%clicklist;
2044
2045     my$parent=$clicklist{parent}=shift @_;
2046     my$var=$clicklist{variable}=shift @_;
2047     my$rows=00;
2048     my@textrows;
2049     my@valrows;
2050     my@widgetrows;
2051
2052     $clicklist{textrows}=\@textrows;
2053     $clicklist{valrows}=\@valrows;
2054     $clicklist{widgetrows}=\@widgetrows;
2055
2056     my$button=$clicklist{button}=$parent->Button(-command=>[$this=>poplist],-class=>'ClickListButton');
2057     my$list=$clicklist{list}=$parent->Frame(-class=>'ClickList');
2058
2059     my$maxheight=0;
2060     my$maxwidth=0;
2061
2062     # row by row
2063     for($rows=0;;$rows++){
2064         my $text=shift;
2065         my $value=shift;
2066         if(defined($value)){
2067             $textrows[$rows]=$text;
2068             $valrows[$rows]=$value;
2069
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);
2074
2075         }else{
2076             last;
2077         }
2078     }
2079
2080
2081
2082     $clicklist{rows}=$rows;
2083     $clicklist{reqwidth}=$maxwidth+=$list->optionGet(borderWidth,"")*2;
2084     $clicklist{reqheight}=$maxheight+=$list->optionGet(borderWidth,"")*2;
2085
2086     my$y=0;
2087     for(my$i=0;$i<$rows;$i++){
2088         $widgetrows[$i]->place(-y=>$y,-relwidth=>1.0,-height=>$maxheight);
2089         $y+=$maxheight;
2090     }
2091     $y+=$list->optionGet(borderWidth,"")*2;
2092
2093
2094     $button->place(-height=>$maxheight,-width=>$maxwidth);
2095     $list->configure(-width=>$maxwidth,-height=>$y);
2096     $clicklist{maxheight}=$y+$list->optionGet(borderWidth,"")*2;
2097
2098
2099     $this->setval($$var);
2100     $this;
2101 }
2102
2103 sub reqheight{
2104     my$this=shift;
2105     $this->{reqheight};
2106 }
2107 sub maxheight{
2108     my$this=shift;
2109     $this->{maxheight}+$this->{reqheight};
2110 }
2111
2112 sub reqwidth{
2113     my$this=shift;
2114     $this->{reqwidth};
2115 }
2116
2117 sub place{
2118     my$this=shift;
2119     $this->{button}->place(@_);
2120     $this;
2121 }
2122
2123
2124 sub setrow{
2125     my$this=shift;
2126     my$row=shift;
2127     my$val=$this->{valrows}[$row];
2128
2129     $this->{'set'}=$row;
2130     ${$this->{'variable'}}=$val;
2131     $this->{'list'}->placeForget;
2132     $this->{'button'}->configure(-text=>$this->{textrows}[$this->{'set'}]);
2133     $this;
2134 }
2135
2136 sub setval{
2137     my$this=shift;
2138     my$val=shift;
2139
2140     my$rows=$this->{rows};
2141     for(my$i;$i<$rows;$i++){
2142         if("$this->{valrows}[$i]" eq "$val"){
2143             $this->setrow($i);
2144             last;
2145         }
2146     }
2147     $this;
2148 }
2149
2150 sub poplist{
2151     my$this=shift;
2152     my$row=$this->{'set'};
2153     my$list=$this->{'list'};
2154     my$button=$this->{'button'};
2155
2156     if(defined($this->{pop})){
2157         $list->placeForget();
2158         delete $this->{pop};
2159     }else{
2160         $list->raise();
2161         $list->place(-in=>$button,-relwidth=>1.0,-rely=>1.0,-bordermode=>outside);
2162         $this->{'pop'}='';
2163     }
2164     $this;
2165 }
2166
2167 sub button{
2168     my$this=shift;
2169     $this->{'button'};
2170 }
2171
2172