Mercurial > ~darius > hgwebdir.cgi > mservtk
view mservtk.tcl @ 6:b370e0bbe050
Remove the check every second, since it breaks stuff :-/
author | darius |
---|---|
date | Thu, 12 Oct 2000 11:41:22 +0000 |
parents | b6c495b5eeda |
children | abe05fb9c2a6 |
line wrap: on
line source
#!/usr/bin/env wish8.2 # # This software is copyright Daniel O'Connor (darius@dons.net.au) 2000 # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions # are met: # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # 3. Neither the name Daniel O'Connor nor the names of its contributors # may be used to endorse or promote products derived from this software # without specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY DANIEL O'CONNOR AND CONTRIBUTORS ``AS IS'' AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF # SUCH DAMAGE. # proc main {} { global argv0 argv state albums songs tcl_platform; if {[string first "Windows" $tcl_platform(os)] == -1} { set state(conffile) "~/.mservtk"; set state(windows) 0; } else { package require registry 1.0; set state(windows) 1; } set state(port) "4444"; set state(exit) 0; set state(tmpphrase) ""; set state(sortmode) "Title"; set state(rtlist) ""; wm withdraw .; f_readconf; gui_conf; if {$state(host) == "NONE"} { log "%s" "Login cancelled"; exit; } else { log "%s" "Login OK'd"; } f_writeconf; wm deiconify .; con_mserv; con_getalbums albums; con_getsongs songs albums; gui_build; focus -force .; gui_updatesongs; gui_updatequeue; gui_updateinfo; update_timer; while {1} { vwait state; if {$state(rtlist) != ""} { # Copy it so we don't stomp any new additions set tmp $state(rtlist); set state(rtlist) ""; foreach t $tmp { # log "%s" "Handle $t"; n_rthandler [lindex $t 0] [lindex $t 1]; } } if {$state(exit) == 1} { exit; } } } proc f_readconf {} { global state; set state(host) "NONE"; set state(user) "NONE"; set state(pass) ""; if {$state(windows) == 1} { if {[catch { set state(host) [registry get {HKEY_CURRENT_USER\Software\MServTk} host]; set state(user) [registry get {HKEY_CURRENT_USER\Software\MServTk} user]; set state(pass) [registry get {HKEY_CURRENT_USER\Software\MServTk} pass]; } msg]} { log "%s" "Failed to read registry keys - $msg"; } } else { if {![catch { set fh [open $state(conffile)]; } msg]} { if {[gets $fh] != "mservtk-0.1"} { log "%s" "Conf file has the wrong version"; } else { set state(host) [gets $fh]; set state(user) [gets $fh]; set state(pass) [gets $fh]; close $fh; } } else { log "%s" "Failed to open $state(conffile) - $msg"; } } } proc f_writeconf {} { global state; if {$state(windows) == 1} { if {[catch { registry set {HKEY_CURRENT_USER\Software\MServTk} host $state(host); registry set {HKEY_CURRENT_USER\Software\MServTk} user $state(user); registry set {HKEY_CURRENT_USER\Software\MServTk} pass $state(pass); } msg]} { log "%s" "Failed to set registry keys - $msg"; } } else { if {![catch { set fh [open $state(conffile) w]; } msg]} { puts $fh "mservtk-0.1"; puts $fh $state(host); puts $fh $state(user); puts $fh $state(pass); close $fh; } else { log "%s" "Failed to open $state(conffile) - $msg"; } } } proc gui_conf {} { global state; catch {destroy .conf}; toplevel .conf -class Dialog; wm title .conf "Authentication"; wm iconname .conf "Authentication"; frame .conf.host; pack .conf.host -side top -pady 2m -fill x; label .conf.host.label -text "Host:" -width 10 -anchor e; entry .conf.host.entry -relief sunken -width 30 -textvariable state(host) pack .conf.host.label .conf.host.entry -side left -padx 1m frame .conf.user pack .conf.user -side top -pady 2m -fill x label .conf.user.label -text "User:" -width 10 -anchor e entry .conf.user.entry -relief sunken -width 8 -textvariable state(user) pack .conf.user.label .conf.user.entry -side left -padx 1m frame .conf.password pack .conf.password -side top -pady 2m -fill x label .conf.password.label -text "Password:" -width 10 -anchor e entry .conf.password.entry -relief sunken -width 8 -textvariable state(pass) -show *; bind .conf.password.entry <Return> ".conf.buttons.ok invoke"; pack .conf.password.label .conf.password.entry -side left -padx 1m frame .conf.buttons pack .conf.buttons -side top -pady 1m -fill x button .conf.buttons.ok -text OK -width 6 -command { destroy .conf; } button .conf.buttons.cancel -text Cancel -width 6 -command { set state(host) "NONE"; set state(user) "NONE"; set state(pass) "NONE"; destroy .conf; } pack .conf.buttons.ok -side left -padx 1m; pack .conf.buttons.cancel -side right -padx 1m; # Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display and de-iconify it. wm withdraw .conf update idletasks set x [expr [winfo screenwidth .conf]/2 - [winfo reqwidth .conf]/2 \ - [winfo vrootx [winfo parent .conf]]] set y [expr [winfo screenheight .conf]/2 - [winfo reqheight .conf]/2 \ - [winfo vrooty [winfo parent .conf]]] wm geom .conf +$x+$y wm deiconify .conf # Set a grab and claim the focus too. set oldFocus [focus] set oldGrab [grab current .conf] if {$oldGrab != ""} { set grabStatus [grab status $oldGrab] } grab .conf tkwait visibility .conf if {$state(host) == "NONE"} { focus .conf.host.entry; } else { focus .conf.password.entry; } tkwait window .conf; if {$oldGrab != ""} { if {$grabStatus == "global"} { grab -global $oldGrab } else { grab $oldGrab } } log "%s" "Host $state(host)"; } proc quit_now {} { global state; set state(exit) 1; } proc gui_build {} { # create the toplevel eval destroy [winfo child .]; wm title . "MServ-Tk"; wm minsize . 600 500; wm geometry . 600x500; # Let's have a menubar frame .menubar -relief raised -bd 2; pack .menubar -side top -fill x; # Add the File menu menubutton .menubar.file -text "File" -menu .menubar.file.m -underline 0; menu .menubar.file.m -tearoff 0; .menubar.file.m add command -label " Top" -command "gui_top" .menubar.file.m add command -label " Update Queue" -command "gui_updatequeue" .menubar.file.m add separator; .menubar.file.m add command -label " Quit" -command "quit_now" \ -underline 2 -accelerator "Alt-q"; pack .menubar.file -side left; # Add the Rate menu menubutton .menubar.rate -text "Rate" -menu .menubar.rate.m -underline 0; menu .menubar.rate.m -tearoff 0; .menubar.rate.m add command -label " Superb" -command "rate_song SUPERB"; .menubar.rate.m add command -label " Good" -command "rate_song GOOD"; .menubar.rate.m add command -label " Neutral" -command "rate_song NEUTRAL"; .menubar.rate.m add command -label " Bad" -command "rate_song BAD"; .menubar.rate.m add command -label " Awful" -command "rate_song AWFUL"; pack .menubar.rate -side left; # Add the Control menu menubutton .menubar.control -text "Control" -menu .menubar.control.m -underline 0; menu .menubar.control.m -tearoff 0; .menubar.control.m add command -label " Next" -command "control_player NEXT"; .menubar.control.m add command -label " Pause" -command "control_player PAUSE"; .menubar.control.m add command -label " Stop" -command "control_player STOP" .menubar.control.m add command -label " Play" -command "control_player PLAY"; pack .menubar.control -side left; # Add the Volume menu menubutton .menubar.vol -text "Volume" -menu .menubar.vol.m -underline 0; menu .menubar.vol.m -tearoff 0; .menubar.vol.m add command -label " Increase" -command "set_vol +3" \ -accelerator "+"; .menubar.vol.m add command -label " Decrease" -command "set_vol -3" \ -accelerator "-"; .menubar.vol.m add separator; .menubar.vol.m add command -label " 100%" -command "set_vol 100"; .menubar.vol.m add command -label " 90%" -command "set_vol 90"; .menubar.vol.m add command -label " 80%" -command "set_vol 80"; .menubar.vol.m add command -label " 70%" -command "set_vol 70"; .menubar.vol.m add command -label " 60%" -command "set_vol 60"; .menubar.vol.m add command -label " 50%" -command "set_vol 50"; .menubar.vol.m add command -label " 40%" -command "set_vol 40"; .menubar.vol.m add command -label " 30%" -command "set_vol 30"; .menubar.vol.m add command -label " 20%" -command "set_vol 20"; .menubar.vol.m add command -label " 10%" -command "set_vol 10"; .menubar.vol.m add command -label " 0%" -command "set_vol 0"; pack .menubar.vol -side left; # Add the Sort menu menubutton .menubar.sort -text "Sort" -menu .menubar.sort.m -underline 0; menu .menubar.sort.m -tearoff 0; .menubar.sort.m add command -label " Artist" \ -command "global state; set state(sortmode) Artist; gui_updatesongs"; .menubar.sort.m add command -label " Title" \ -command "global state; set state(sortmode) Title; gui_updatesongs"; .menubar.sort.m add command -label " Album" \ -command "global state; set state(sortmode) Album; gui_updatesongs"; pack .menubar.sort -side left; # Add the Help menu menubutton .menubar.help -text "Help" -menu .menubar.help.m -underline 0; menu .menubar.help.m -tearoff 0; .menubar.help.m add command -label " About" -command "about_box" \ -underline 2; pack .menubar.help -side right; # Top frame holding tracklist and trackinfo frames frame .top -relief raised -bd 1; pack .top -fill both -expand 1; # Tracklist frame .top.tlist -relief raised -bd 1; pack .top.tlist -side left -fill both -expand 1; label .top.tlist.label -text "Track List"; pack .top.tlist.label -side top -expand 0; listbox .top.tlist.list -relief raised -borderwidth 2 \ -yscrollcommand ".top.tlist.scr set"; pack .top.tlist.list -side left -fill both -expand 1; scrollbar .top.tlist.scr -command ".top.tlist.list yview"; pack .top.tlist.scr -side right -fill y; bind .top.tlist.list <Double-Button-1> { queue_song [.top.tlist.list curselection]; gui_updatequeue; } # Trackinfo frame .top.tinfo -relief raised -bd 1; pack .top.tinfo -side right -fill both -expand 0; label .top.tinfo.label -text "Track Info"; pack .top.tinfo.label -side top -expand 0; frame .top.tinfo.sub -relief raised -bd 1; pack .top.tinfo.sub -side right -fill both -expand 0; label .top.tinfo.sub.author -text "Author:"; pack .top.tinfo.sub.author -side top -expand 0; label .top.tinfo.sub.title -text "Title:"; pack .top.tinfo.sub.title -side top -expand 0; label .top.tinfo.sub.length -text "Length:"; pack .top.tinfo.sub.length -side top -expand 0; # label .top.tinfo.sub.time -text "Time:"; # pack .top.tinfo.sub.time -side top -expand 0; label .top.tinfo.sub.album -text "Album:"; pack .top.tinfo.sub.album -side top -expand 0; label .top.tinfo.sub.misc -text "Misc:"; pack .top.tinfo.sub.misc -side top -expand 0; label .top.tinfo.sub.rate1 -text "Rating:"; pack .top.tinfo.sub.rate1 -side top -expand 0; label .top.tinfo.sub.rate2 -text "Temporally Adjusted:"; pack .top.tinfo.sub.rate2 -side top -expand 0; label .top.tinfo.sub.vol -text "Volume:"; pack .top.tinfo.sub.vol -side top -expand 0; # Queue (and the frame holding it) frame .bot -relief raised -bd 1; pack .bot -fill both -expand 1; label .bot.qlabel -text "Queue"; pack .bot.qlabel -side top -expand 0; frame .bot.queue; pack .bot.queue -fill both -expand 1; listbox .bot.queue.list -relief raised -borderwidth 2 \ -yscrollcommand ".bot.queue.scr set"; pack .bot.queue.list -side left -fill both -expand 1; scrollbar .bot.queue.scr -command ".bot.queue.list yview"; pack .bot.queue.scr -side right -fill y; bind .bot.queue.list <Double-Button-1> { gui_delqueue [.bot.queue.list curselection]; } bind . <Destroy> {quit_now}; bind all <Alt-q> {quit_now}; bind all <KP_Add> {set_vol +3}; bind all <KP_Subtract> {set_vol -3}; bind all <plus> {set_vol +3}; bind all <equal> {set_vol +3}; bind all <minus> {set_vol -3}; bind all <F1> {set_vol 10}; bind all <F2> {set_vol 20}; bind all <F3> {set_vol 30}; bind all <F4> {set_vol 40}; bind all <F5> {set_vol 50}; bind all <F6> {set_vol 60}; bind all <F7> {set_vol 70}; bind all <F8> {set_vol 80}; bind all <F9> {set_vol 90}; bind all <F10> {set_vol 100}; bind all <Pause> {control_player PAUSE}; bind all <End> {control_player NEXT}; bind all <Delete> {control_player STOP}; bind all <Home> {control_player PLAY}; update; } proc queue_song {id} { global songs state; set tmp [lindex [lindex [array get songs *:listid:$id] 1] 0]; log "%s" "Queue - '$songs($tmp:name)' by '$songs($tmp:author)' ($tmp)"; set cookie [acquire_lock]; n_write "QUEUE [split $tmp {:}]"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 247} { if {$rtn(code) == 510} { msg_box "Queue" "You can't have the same\nsong in the queue twice!"; } else { log "%s" "Failed to queue track ($rtn(code) $rtn(data))"; } } } proc msg_box {title msg} { global state; catch {destroy .msg}; toplevel .msg -class Dialog; wm title .msg $title; wm iconname .msg $title; # text region frame .msg.frame; pack .msg.frame -side top -fill both -expand yes; text .msg.frame.text -font fixed -yscroll ".msg.frame.scroll set" -wrap none; scrollbar .msg.frame.scroll -command ".msg.frame.text yview"; pack .msg.frame.text -side left -expand y -fill both; pack .msg.frame.scroll -side right -fill y; # close button button .msg.close -text "Close" -command "destroy .msg"; pack .msg.close -side bottom -fill x; # read text into the text widget .msg.frame.text insert end $msg; } proc about_box {} { global state; catch {destroy .about}; toplevel .about -class Dialog; wm title .about "About..."; wm iconname .about "About"; # text region frame .about.frame; pack .about.frame -side top -fill both -expand yes; text .about.frame.text -font fixed -height 10 -width 40 -yscroll ".about.frame.scroll set" \ -wrap none; scrollbar .about.frame.scroll -command ".about.frame.text yview"; pack .about.frame.text -side left -expand y; pack .about.frame.scroll -side right -fill y; # close button button .about.close -text "Close" -command "destroy .about"; pack .about.close -side bottom -fill x; # read text into the text widget .about.frame.text insert end "Mserv Client\n"; .about.frame.text insert end "Copyright Daniel O'Connor 2000\n"; .about.frame.text insert end "\n"; .about.frame.text insert end "http://www.dons.net.au/~darius/\n"; } proc set_vol {vol} { global state; set cookie [acquire_lock]; n_write "VOLUME $vol" n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 255} { log "%s" "Couldn't set volume ($rtn(code) $rtn(data))"; } } proc rate_song {rate} { global state; set cookie [acquire_lock]; n_write "RATE $rate"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 270} { log "%s" "Failed to get rate song ($rtn(code) $rtn(data))"; } } proc control_player {cmd} { global state; set cookie [acquire_lock]; log "%s" "Writing $cmd"; n_write "$cmd"; n_getrtn rtn; release_lock $cookie; # log "%s" "Control Got $rtn(code) $rtn(data)"; } proc gui_top {} { global state; set cookie [acquire_lock]; n_write "TOP" n_getrtn rtn; release_lock $cookie; set msg "List of songs most likely to be played next\n\n"; foreach t $rtn(lines) { set tmp [split $t \011]; append msg "[lindex $tmp 0]%\t[lindex $tmp 4] by [lindex $tmp 3]\n"; } msg_box "Top Listing" $msg; } proc gui_updatesongs {} { global state songs; .top.tlist.list delete 0 end; set tmp ""; foreach tag [array names songs "*:id"] { set a $songs($tag); lappend tmp [list $a $songs($a:name) $songs($a:author) $songs($a:albumname)]; } switch -- $state(sortmode) { "Title" { set idx 1; } "Artist" { set idx 2; } "Album" { set idx 3; } default { set idx 1; } } set tmp [lsort -dictionary -index $idx $tmp]; foreach a [array names songs *:listid:*] { unset songs($a); } set i 0; foreach a $tmp { .top.tlist.list insert end "'[lindex $a 1]' by '[lindex $a 2]' on '[lindex $a 3]'" set songs([lindex $a 0]:listid:$i) $a; incr i; } } proc gui_updatequeue {} { global state songs queue; # log "%s" "Updating queue"; .bot.queue.list delete 0 end; con_getqueue queue; foreach tag [lsort [array names queue]] { .bot.queue.list insert end "'$songs($queue($tag):name)' by '$songs($queue($tag):author)' on '$songs($queue($tag):albumname)'"; } } proc gui_delqueue {id} { global queue; if {$id == ""} { return; } set cookie [acquire_lock]; n_write "UNQUEUE [split $queue($id) {:}]"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 254} { log "%s" "Failed to remove $id ($queue($id))"; msg_box "Queue" "Failed to dequeue the song"; } } proc gui_updateinfo {} { global state; set cookie [acquire_lock]; n_write "VOLUME"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 235} { set vol "??"; } else { set vol "[lindex [lindex $rtn(lines) 0] 0]"; } set cookie [acquire_lock]; n_write "INFO"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) == 246} { set data [split [lindex $rtn(lines) 0] "\t"]; set author [lindex $data 4]; set title [lindex $data 5]; set length [lindex $data 14]; set album [lindex $data 3]; set rate1 [lindex $data 9]; set rate2 [lindex $data 10]; set misc [lindex $data 15]; } else { set author "N/A"; set title "N/A"; set length "N/A"; set album "N/A"; set rate1 "N/A"; set rate2 "N/A"; set misc "N/A"; if {$rtn(code) != 401} { log "%s" "Failed to get track info ($rtn(code) $rtn(data))"; } } set cookie [acquire_lock]; n_write "STATUS"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 222} { set played "x:xx"; } else { set played [lindex [split [lindex $rtn(lines) 0] "\t"] 8]; } .top.tinfo.sub.author configure -text "Author: $author"; .top.tinfo.sub.title configure -text "Title: $title"; .top.tinfo.sub.length configure -text "Length: $length"; # .top.tinfo.sub.time configure -text "Time: $played"; .top.tinfo.sub.album configure -text "Album: $album"; .top.tinfo.sub.misc configure -text "Misc: $misc"; .top.tinfo.sub.rate1 configure -text "Rating: $rate1"; .top.tinfo.sub.rate2 configure -text "Temporally Adjusted: $rate2"; .top.tinfo.sub.vol configure -text "Volume: $vol"; } proc con_getqueue {queuevar} { upvar $queuevar queue; global state; catch {unset queue}; set cookie [acquire_lock]; n_write "QUEUE" n_getrtn rtn; release_lock $cookie; if {$rtn(code) == 225} { set i 0; foreach line $rtn(lines) { set foo [split $line \011]; set id "[lindex $foo 1]:[lindex $foo 2]"; set queue($i) $id; incr i; } } elseif {$rtn(code) == 404} { # log "%s" "Queue empty"; } else { log "%s" "Failed to get queue ($rtn(code) $rtn(data))"; } } proc con_getsongs {songsvar albumsvar} { upvar $songsvar songs; upvar $albumsvar albums; global state; catch { unset songs }; foreach i [array names albums "*:"] { set cookie [acquire_lock]; n_write "TRACKS $albums($i)"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != "228"} { error "Got bogus response to track request ($rtn(code) $rtn(data))"; } foreach trk $rtn(lines) { set foo [split $trk \011]; if {[llength $foo] != 6} { continue; } set albid [lindex $foo 0]; set num [lindex $foo 1] set songs($albid:$num:id) "$albid:$num"; set songs($albid:$num:author) [lindex $foo 2]; set songs($albid:$num:name) [lindex $foo 3]; set songs($albid:$num:rating) [lindex $foo 4]; set songs($albid:$num:length) [lindex $foo 5]; set songs($albid:$num:albumname) $albums($albid:name); } } } proc con_getalbums {albumsvar} { upvar $albumsvar albums; global state; catch {unset albums}; set cookie [acquire_lock]; n_write "ALBUMS"; n_getrtn rtn; release_lock $cookie; if {$rtn(code) != 227} { error "Server gave bogus response to album request ($rtn(code) $rtn(data))"; } foreach alb $rtn(lines) { set foo [split $alb \011]; set id [lindex $foo 0]; if {$id == ""} { continue; } set albums($id:) $id; set albums($id:author) [lindex $foo 1]; set albums($id:name) [lindex $foo 2]; # log "%s" "Album $id, ID '$albums($id:)' called '$albums($id:name)' by '$albums($id:author)'"; } } proc update_timer {} { # gui_updateinfo; after 900 update_timer; } proc con_mserv {} { global state; # Close old FD catch {close state(serv_fd)}; catch {unset state(serv_fd)}; catch {fileevent $state(serv_fd) readable ""}; set state(serv_fd) [ socket $state(host) $state(port) ]; set state(pushbuf) ""; fileevent $state(serv_fd) readable n_rtinput; fconfigure $state(serv_fd) -blocking 0; # Greeting from server n_getrtn rtn; log "%s" $rtn(data); if {$rtn(code) != "200"} { error "Server failed to send greeting"; } # Login n_write "USER $state(user)" n_getrtn rtn; if {$rtn(code) != "201"} { error "Server failed to send password request"; } n_write "PASS $state(pass) RTCOMPUTER"; n_getrtn rtn; if {$rtn(code) == "507"} { error "Server rejected our credentials"; } if {$rtn(code) != "202"} { error "Unknown response to PASS command - $rtn(code) $rtn(data)" } set state(lock) ""; # trace variable state(lock) rw foobar; log "%s" "Logged in"; } proc n_write {text} { global state; puts $state(serv_fd) $text; flush $state(serv_fd); if {[eof $state(serv_fd)]} { log "%s" "Server went away on write"; exit 1; } # log "%s" "Wrote - $text"; } proc n_rthandler {code data} { global songs; # log "%s" "Got RT - $code $data"; switch -- $code { 600 { log "%s" "User '$data' connected"; } 601 { log "%s" "User '$data' disconnected"; } 240 - 602 - 615 - 618 - 619 - 620 - 622 - 623 - 627 - 628 - 629 { # log "%s" "Updating queue on idle"; gui_updateinfo; gui_updatequeue; } default { log "%s" "Got unhandled RT event $code $data"; } } } proc n_rtinput {} { global state; set rth ""; while {1} { set line [gets $state(serv_fd)]; if {[eof $state(serv_fd)]} { log "%s" "Server went away on read"; exit 1; } # log "%s" "Read - $line"; if {$line == ""} { return; } # Check for RT text set foo [split $line "\t"]; if {[string index $line 0] == "="} { lappend state(rtlist) [list [string range [lindex $foo 0] 1 3] [lrange $foo 1 end]]; # log "%s" "RT event"; } else { lappend state(tmpphrase) $line if {$line == "."} { set state(pushbuf) [linsert $state(pushbuf) 0 $state(tmpphrase)]; # log "%s" "push buffer - '$state(tmpphrase)'"; set state(tmpphrase) ""; } } } } proc n_getrtn {var} { upvar $var rtn; global state; set gotcode 0; catch {unset rtn(code)}; catch {unset rtn(data)}; catch {unset rtn(lines)} while {[llength $state(pushbuf)] == 0} { # log "%s" "Sleeping for data"; vwait state(pushbuf); } # log "%s" "Waking up, got $state(pushbuf)"; set buf [lindex $state(pushbuf) 0]; set state(pushbuf) [lrange $state(pushbuf) 1 end]; while {1} { if {[llength $buf] == 0} { break; } set line [lindex $buf 0]; set buf [lrange $buf 1 end]; if {[string index $line 0] == "."} { break; } if {$gotcode == 0} { set rtn(code) [string range $line 0 2]; set rtn(data) [string range $line 4 end]; set gotcode 1; continue; } lappend rtn(lines) $line; } if {$gotcode == 0} { log "%s" "Failed to parse phrase (got . before server response)"; } } ################################################################## # Log a message to stderr # proc log {format args} { # Extract the calling function's name if {[catch {set fname [lindex [info level -1] 0]}]} { set fname "unknown"; } # Evaluate the supplied format string and arguments if {[catch {set csm [eval format {$format} $args]} msg]} { set csm "bad log message. format='$format' args='$args'"; } # Emit the message catch { puts stderr "[clock format [clock seconds] -format {%y/%m/%d %H:%M:%S} -gmt yes]:$fname: $csm"; flush stderr; } } proc acquire_lock {} { global state; # Extract the calling function's name if {[catch {set fname [lindex [info level -1] 0]}]} { set fname "unknown"; } # log "%s" "Acquiring lock for $fname"; set foo 0; if {[info exists state(lock)]} { while {$state(lock) != ""} { set foo 1; log "%s" "$fname waiting for lock (held by [lindex $state(lock) 1])"; vwait state(lock); } if {$foo == 1} { log "%s" "Lock released"; } } set cookie [clock clicks]; set state(lock) [list $cookie $fname]; # log "%s" "Lock acquired"; return $cookie; } proc release_lock {cookie} { global state; # Extract the calling function's name if {[catch {set fname [lindex [info level -1] 0]}]} { set fname "unknown"; } if {$cookie == ""} { log "%s" "$fname trying to unlock without being locked"; exit 1; } if {$cookie != [lindex $state(lock) 0]} { log "%s" "Lock cookie not matched!"; exit 1; } if {$fname != [lindex $state(lock) 1]} { log "%s" "$fname tried to free [lindex $state(lock) 1]'s lock!"; exit 1; } set state(lock) ""; # log "%s" "Lock for $fname now free"; } proc foobar {n1 n2 op} { global state; log "%s" "$op, now $state(lock)"; } if {[catch {main} msg]} { catch {tk_dialog .dummy "Error!" [format "%s\n%s" $msg $errorInfo] error 0 "OK"}; exit 1; }