Mercurial > ~darius > hgwebdir.cgi > mservtk
annotate 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 |
| rev | line source |
|---|---|
| 5 | 1 #!/usr/bin/env wish8.2 |
| 1 | 2 |
| 3 # | |
| 4 # This software is copyright Daniel O'Connor (darius@dons.net.au) 2000 | |
| 5 # | |
| 6 # Redistribution and use in source and binary forms, with or without | |
| 7 # modification, are permitted provided that the following conditions | |
| 8 # are met: | |
| 9 # 1. Redistributions of source code must retain the above copyright | |
| 10 # notice, this list of conditions and the following disclaimer. | |
| 11 # 2. Redistributions in binary form must reproduce the above copyright | |
| 12 # notice, this list of conditions and the following disclaimer in the | |
| 13 # documentation and/or other materials provided with the distribution. | |
| 14 # 3. Neither the name Daniel O'Connor nor the names of its contributors | |
| 15 # may be used to endorse or promote products derived from this software | |
| 16 # without specific prior written permission. | |
| 17 # | |
| 18 # THIS SOFTWARE IS PROVIDED BY DANIEL O'CONNOR AND CONTRIBUTORS ``AS IS'' AND | |
| 19 # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | |
| 20 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | |
| 21 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE | |
| 22 # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | |
| 23 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS | |
| 24 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) | |
| 25 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | |
| 26 # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | |
| 27 # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF | |
| 28 # SUCH DAMAGE. | |
| 29 # | |
| 30 | |
| 31 proc main {} { | |
| 3 | 32 global argv0 argv state albums songs tcl_platform; |
| 1 | 33 |
| 3 | 34 if {[string first "Windows" $tcl_platform(os)] == -1} { |
| 35 set state(conffile) "~/.mservtk"; | |
| 36 set state(windows) 0; | |
| 37 } else { | |
| 38 package require registry 1.0; | |
| 39 set state(windows) 1; | |
| 40 } | |
| 41 | |
| 1 | 42 set state(port) "4444"; |
| 3 | 43 set state(exit) 0; |
| 1 | 44 set state(tmpphrase) ""; |
| 3 | 45 set state(sortmode) "Title"; |
| 1 | 46 |
| 4 | 47 set state(rtlist) ""; |
| 48 | |
| 3 | 49 wm withdraw .; |
| 50 | |
| 51 f_readconf; | |
| 52 gui_conf; | |
| 1 | 53 |
| 3 | 54 if {$state(host) == "NONE"} { |
| 55 log "%s" "Login cancelled"; | |
| 56 exit; | |
| 57 } else { | |
| 58 log "%s" "Login OK'd"; | |
| 59 } | |
| 60 | |
| 61 f_writeconf; | |
| 62 | |
| 63 wm deiconify .; | |
| 1 | 64 con_mserv; |
| 65 | |
| 66 con_getalbums albums; | |
| 67 con_getsongs songs albums; | |
| 68 | |
| 3 | 69 gui_build; |
| 70 focus -force .; | |
| 71 | |
| 1 | 72 gui_updatesongs; |
| 73 gui_updatequeue; | |
| 74 | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
75 gui_updateinfo; |
| 1 | 76 update_timer; |
| 77 | |
| 78 while {1} { | |
| 4 | 79 vwait state; |
| 80 | |
| 81 if {$state(rtlist) != ""} { | |
| 82 # Copy it so we don't stomp any new additions | |
| 83 set tmp $state(rtlist); | |
| 84 set state(rtlist) ""; | |
| 85 | |
| 5 | 86 foreach t $tmp { |
| 87 # log "%s" "Handle $t"; | |
| 4 | 88 n_rthandler [lindex $t 0] [lindex $t 1]; |
| 89 } | |
| 90 } | |
| 1 | 91 |
| 92 if {$state(exit) == 1} { | |
| 93 exit; | |
| 94 } | |
| 95 } | |
| 96 } | |
| 97 | |
| 3 | 98 proc f_readconf {} { |
| 99 global state; | |
| 100 | |
| 101 set state(host) "NONE"; | |
| 102 set state(user) "NONE"; | |
| 103 set state(pass) ""; | |
| 104 | |
| 105 if {$state(windows) == 1} { | |
| 106 if {[catch { | |
| 107 set state(host) [registry get {HKEY_CURRENT_USER\Software\MServTk} host]; | |
| 108 set state(user) [registry get {HKEY_CURRENT_USER\Software\MServTk} user]; | |
| 109 set state(pass) [registry get {HKEY_CURRENT_USER\Software\MServTk} pass]; | |
| 110 } msg]} { | |
| 111 log "%s" "Failed to read registry keys - $msg"; | |
| 112 } | |
| 113 } else { | |
| 114 if {![catch { | |
| 115 set fh [open $state(conffile)]; | |
| 116 } msg]} { | |
| 117 if {[gets $fh] != "mservtk-0.1"} { | |
| 118 log "%s" "Conf file has the wrong version"; | |
| 119 } else { | |
| 120 set state(host) [gets $fh]; | |
| 121 set state(user) [gets $fh]; | |
| 122 set state(pass) [gets $fh]; | |
| 123 close $fh; | |
| 124 } | |
| 125 } else { | |
| 126 log "%s" "Failed to open $state(conffile) - $msg"; | |
| 127 } | |
| 128 } | |
| 129 } | |
| 130 | |
| 131 proc f_writeconf {} { | |
| 132 global state; | |
| 133 | |
| 134 if {$state(windows) == 1} { | |
| 135 if {[catch { | |
| 136 registry set {HKEY_CURRENT_USER\Software\MServTk} host $state(host); | |
| 137 registry set {HKEY_CURRENT_USER\Software\MServTk} user $state(user); | |
| 138 registry set {HKEY_CURRENT_USER\Software\MServTk} pass $state(pass); | |
| 139 } msg]} { | |
| 140 log "%s" "Failed to set registry keys - $msg"; | |
| 141 } | |
| 142 } else { | |
| 143 if {![catch { | |
| 144 set fh [open $state(conffile) w]; | |
| 145 } msg]} { | |
| 146 puts $fh "mservtk-0.1"; | |
| 147 puts $fh $state(host); | |
| 148 puts $fh $state(user); | |
| 149 puts $fh $state(pass); | |
| 150 | |
| 151 close $fh; | |
| 152 } else { | |
| 153 log "%s" "Failed to open $state(conffile) - $msg"; | |
| 154 } | |
| 155 } | |
| 156 } | |
| 157 | |
| 158 proc gui_conf {} { | |
| 159 global state; | |
| 160 | |
| 161 catch {destroy .conf}; | |
| 162 | |
| 163 toplevel .conf -class Dialog; | |
| 164 wm title .conf "Authentication"; | |
| 165 wm iconname .conf "Authentication"; | |
| 166 | |
| 167 frame .conf.host; | |
| 168 pack .conf.host -side top -pady 2m -fill x; | |
| 169 label .conf.host.label -text "Host:" -width 10 -anchor e; | |
| 170 | |
| 171 entry .conf.host.entry -relief sunken -width 30 -textvariable state(host) | |
| 172 pack .conf.host.label .conf.host.entry -side left -padx 1m | |
| 173 | |
| 174 frame .conf.user | |
| 175 pack .conf.user -side top -pady 2m -fill x | |
| 176 label .conf.user.label -text "User:" -width 10 -anchor e | |
| 177 entry .conf.user.entry -relief sunken -width 8 -textvariable state(user) | |
| 178 pack .conf.user.label .conf.user.entry -side left -padx 1m | |
| 179 | |
| 180 frame .conf.password | |
| 181 pack .conf.password -side top -pady 2m -fill x | |
| 182 label .conf.password.label -text "Password:" -width 10 -anchor e | |
| 183 entry .conf.password.entry -relief sunken -width 8 -textvariable state(pass) -show *; | |
| 184 bind .conf.password.entry <Return> ".conf.buttons.ok invoke"; | |
| 185 pack .conf.password.label .conf.password.entry -side left -padx 1m | |
| 186 | |
| 187 frame .conf.buttons | |
| 188 pack .conf.buttons -side top -pady 1m -fill x | |
| 189 button .conf.buttons.ok -text OK -width 6 -command { | |
| 190 destroy .conf; | |
| 191 } | |
| 192 button .conf.buttons.cancel -text Cancel -width 6 -command { | |
| 193 set state(host) "NONE"; | |
| 194 set state(user) "NONE"; | |
| 195 set state(pass) "NONE"; | |
| 196 destroy .conf; | |
| 197 } | |
| 198 pack .conf.buttons.ok -side left -padx 1m; | |
| 199 pack .conf.buttons.cancel -side right -padx 1m; | |
| 200 | |
| 201 | |
| 202 # Withdraw the window, then update all the geometry information | |
| 203 # so we know how big it wants to be, then center the window in the | |
| 204 # display and de-iconify it. | |
| 205 | |
| 206 wm withdraw .conf | |
| 207 update idletasks | |
| 208 set x [expr [winfo screenwidth .conf]/2 - [winfo reqwidth .conf]/2 \ | |
| 209 - [winfo vrootx [winfo parent .conf]]] | |
| 210 set y [expr [winfo screenheight .conf]/2 - [winfo reqheight .conf]/2 \ | |
| 211 - [winfo vrooty [winfo parent .conf]]] | |
| 212 wm geom .conf +$x+$y | |
| 213 wm deiconify .conf | |
| 214 | |
| 215 # Set a grab and claim the focus too. | |
| 216 | |
| 217 set oldFocus [focus] | |
| 218 set oldGrab [grab current .conf] | |
| 219 if {$oldGrab != ""} { | |
| 220 set grabStatus [grab status $oldGrab] | |
| 221 } | |
| 222 grab .conf | |
| 223 tkwait visibility .conf | |
| 224 if {$state(host) == "NONE"} { | |
| 225 focus .conf.host.entry; | |
| 226 } else { | |
| 227 focus .conf.password.entry; | |
| 228 } | |
| 229 tkwait window .conf; | |
| 230 if {$oldGrab != ""} { | |
| 231 if {$grabStatus == "global"} { | |
| 232 grab -global $oldGrab | |
| 233 } else { | |
| 234 grab $oldGrab | |
| 235 } | |
| 236 } | |
| 237 | |
| 238 log "%s" "Host $state(host)"; | |
| 239 } | |
| 240 | |
| 1 | 241 proc quit_now {} { |
| 242 global state; | |
| 243 | |
| 244 set state(exit) 1; | |
| 245 } | |
| 246 | |
| 247 proc gui_build {} { | |
| 248 # create the toplevel | |
| 249 eval destroy [winfo child .]; | |
| 250 wm title . "MServ-Tk"; | |
| 251 wm minsize . 600 500; | |
| 252 wm geometry . 600x500; | |
| 253 | |
| 254 # Let's have a menubar | |
| 255 frame .menubar -relief raised -bd 2; | |
| 256 pack .menubar -side top -fill x; | |
| 257 | |
| 258 # Add the File menu | |
| 259 menubutton .menubar.file -text "File" -menu .menubar.file.m -underline 0; | |
| 260 menu .menubar.file.m -tearoff 0; | |
| 3 | 261 .menubar.file.m add command -label " Top" -command "gui_top" |
| 5 | 262 .menubar.file.m add command -label " Update Queue" -command "gui_updatequeue" |
| 3 | 263 .menubar.file.m add separator; |
| 1 | 264 .menubar.file.m add command -label " Quit" -command "quit_now" \ |
| 265 -underline 2 -accelerator "Alt-q"; | |
| 266 pack .menubar.file -side left; | |
| 267 | |
| 268 # Add the Rate menu | |
| 269 menubutton .menubar.rate -text "Rate" -menu .menubar.rate.m -underline 0; | |
| 270 menu .menubar.rate.m -tearoff 0; | |
| 271 .menubar.rate.m add command -label " Superb" -command "rate_song SUPERB"; | |
| 272 .menubar.rate.m add command -label " Good" -command "rate_song GOOD"; | |
| 273 .menubar.rate.m add command -label " Neutral" -command "rate_song NEUTRAL"; | |
| 274 .menubar.rate.m add command -label " Bad" -command "rate_song BAD"; | |
| 275 .menubar.rate.m add command -label " Awful" -command "rate_song AWFUL"; | |
| 276 | |
| 277 pack .menubar.rate -side left; | |
| 278 | |
| 279 # Add the Control menu | |
| 280 menubutton .menubar.control -text "Control" -menu .menubar.control.m -underline 0; | |
| 281 menu .menubar.control.m -tearoff 0; | |
| 282 .menubar.control.m add command -label " Next" -command "control_player NEXT"; | |
| 283 .menubar.control.m add command -label " Pause" -command "control_player PAUSE"; | |
| 284 .menubar.control.m add command -label " Stop" -command "control_player STOP" | |
| 285 .menubar.control.m add command -label " Play" -command "control_player PLAY"; | |
| 286 | |
| 287 pack .menubar.control -side left; | |
| 288 | |
| 289 # Add the Volume menu | |
| 290 menubutton .menubar.vol -text "Volume" -menu .menubar.vol.m -underline 0; | |
| 291 menu .menubar.vol.m -tearoff 0; | |
| 292 .menubar.vol.m add command -label " Increase" -command "set_vol +3" \ | |
| 293 -accelerator "+"; | |
| 294 .menubar.vol.m add command -label " Decrease" -command "set_vol -3" \ | |
| 295 -accelerator "-"; | |
| 296 .menubar.vol.m add separator; | |
| 297 .menubar.vol.m add command -label " 100%" -command "set_vol 100"; | |
| 298 .menubar.vol.m add command -label " 90%" -command "set_vol 90"; | |
| 299 .menubar.vol.m add command -label " 80%" -command "set_vol 80"; | |
| 300 .menubar.vol.m add command -label " 70%" -command "set_vol 70"; | |
| 301 .menubar.vol.m add command -label " 60%" -command "set_vol 60"; | |
| 302 .menubar.vol.m add command -label " 50%" -command "set_vol 50"; | |
| 303 .menubar.vol.m add command -label " 40%" -command "set_vol 40"; | |
| 304 .menubar.vol.m add command -label " 30%" -command "set_vol 30"; | |
| 305 .menubar.vol.m add command -label " 20%" -command "set_vol 20"; | |
| 306 .menubar.vol.m add command -label " 10%" -command "set_vol 10"; | |
| 307 .menubar.vol.m add command -label " 0%" -command "set_vol 0"; | |
| 308 | |
| 309 pack .menubar.vol -side left; | |
| 310 | |
| 311 # Add the Sort menu | |
| 312 menubutton .menubar.sort -text "Sort" -menu .menubar.sort.m -underline 0; | |
| 313 menu .menubar.sort.m -tearoff 0; | |
| 314 .menubar.sort.m add command -label " Artist" \ | |
| 315 -command "global state; set state(sortmode) Artist; gui_updatesongs"; | |
| 316 .menubar.sort.m add command -label " Title" \ | |
| 317 -command "global state; set state(sortmode) Title; gui_updatesongs"; | |
| 318 .menubar.sort.m add command -label " Album" \ | |
| 319 -command "global state; set state(sortmode) Album; gui_updatesongs"; | |
| 320 | |
| 321 pack .menubar.sort -side left; | |
| 322 | |
| 323 # Add the Help menu | |
| 324 menubutton .menubar.help -text "Help" -menu .menubar.help.m -underline 0; | |
| 325 menu .menubar.help.m -tearoff 0; | |
| 326 .menubar.help.m add command -label " About" -command "about_box" \ | |
| 327 -underline 2; | |
| 328 pack .menubar.help -side right; | |
| 329 | |
| 330 # Top frame holding tracklist and trackinfo frames | |
| 331 frame .top -relief raised -bd 1; | |
| 332 pack .top -fill both -expand 1; | |
| 333 | |
| 334 # Tracklist | |
| 335 frame .top.tlist -relief raised -bd 1; | |
| 336 pack .top.tlist -side left -fill both -expand 1; | |
| 337 label .top.tlist.label -text "Track List"; | |
| 338 pack .top.tlist.label -side top -expand 0; | |
| 339 listbox .top.tlist.list -relief raised -borderwidth 2 \ | |
| 340 -yscrollcommand ".top.tlist.scr set"; | |
| 341 pack .top.tlist.list -side left -fill both -expand 1; | |
| 342 scrollbar .top.tlist.scr -command ".top.tlist.list yview"; | |
| 343 pack .top.tlist.scr -side right -fill y; | |
| 344 bind .top.tlist.list <Double-Button-1> { | |
| 345 queue_song [.top.tlist.list curselection]; | |
| 5 | 346 gui_updatequeue; |
| 1 | 347 } |
| 348 | |
| 349 # Trackinfo | |
| 350 frame .top.tinfo -relief raised -bd 1; | |
| 351 pack .top.tinfo -side right -fill both -expand 0; | |
| 352 label .top.tinfo.label -text "Track Info"; | |
| 353 pack .top.tinfo.label -side top -expand 0; | |
| 354 frame .top.tinfo.sub -relief raised -bd 1; | |
| 355 pack .top.tinfo.sub -side right -fill both -expand 0; | |
| 356 label .top.tinfo.sub.author -text "Author:"; | |
| 357 pack .top.tinfo.sub.author -side top -expand 0; | |
| 358 label .top.tinfo.sub.title -text "Title:"; | |
| 359 pack .top.tinfo.sub.title -side top -expand 0; | |
| 360 label .top.tinfo.sub.length -text "Length:"; | |
| 361 pack .top.tinfo.sub.length -side top -expand 0; | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
362 # label .top.tinfo.sub.time -text "Time:"; |
|
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
363 # pack .top.tinfo.sub.time -side top -expand 0; |
| 1 | 364 label .top.tinfo.sub.album -text "Album:"; |
| 365 pack .top.tinfo.sub.album -side top -expand 0; | |
| 3 | 366 label .top.tinfo.sub.misc -text "Misc:"; |
| 367 pack .top.tinfo.sub.misc -side top -expand 0; | |
| 368 label .top.tinfo.sub.rate1 -text "Rating:"; | |
| 369 pack .top.tinfo.sub.rate1 -side top -expand 0; | |
| 370 label .top.tinfo.sub.rate2 -text "Temporally Adjusted:"; | |
| 371 pack .top.tinfo.sub.rate2 -side top -expand 0; | |
| 1 | 372 label .top.tinfo.sub.vol -text "Volume:"; |
| 373 pack .top.tinfo.sub.vol -side top -expand 0; | |
| 374 | |
| 375 # Queue (and the frame holding it) | |
| 376 frame .bot -relief raised -bd 1; | |
| 377 pack .bot -fill both -expand 1; | |
| 378 label .bot.qlabel -text "Queue"; | |
| 379 pack .bot.qlabel -side top -expand 0; | |
| 380 frame .bot.queue; | |
| 381 pack .bot.queue -fill both -expand 1; | |
| 382 listbox .bot.queue.list -relief raised -borderwidth 2 \ | |
| 383 -yscrollcommand ".bot.queue.scr set"; | |
| 384 pack .bot.queue.list -side left -fill both -expand 1; | |
| 385 scrollbar .bot.queue.scr -command ".bot.queue.list yview"; | |
| 386 pack .bot.queue.scr -side right -fill y; | |
| 387 bind .bot.queue.list <Double-Button-1> { | |
| 388 gui_delqueue [.bot.queue.list curselection]; | |
| 389 } | |
| 390 | |
| 391 bind . <Destroy> {quit_now}; | |
| 392 bind all <Alt-q> {quit_now}; | |
| 393 | |
| 394 bind all <KP_Add> {set_vol +3}; | |
| 395 bind all <KP_Subtract> {set_vol -3}; | |
| 396 bind all <plus> {set_vol +3}; | |
| 397 bind all <equal> {set_vol +3}; | |
| 398 bind all <minus> {set_vol -3}; | |
| 399 bind all <F1> {set_vol 10}; | |
| 400 bind all <F2> {set_vol 20}; | |
| 401 bind all <F3> {set_vol 30}; | |
| 402 bind all <F4> {set_vol 40}; | |
| 403 bind all <F5> {set_vol 50}; | |
| 404 bind all <F6> {set_vol 60}; | |
| 405 bind all <F7> {set_vol 70}; | |
| 406 bind all <F8> {set_vol 80}; | |
| 407 bind all <F9> {set_vol 90}; | |
| 408 bind all <F10> {set_vol 100}; | |
| 409 | |
| 410 bind all <Pause> {control_player PAUSE}; | |
| 411 bind all <End> {control_player NEXT}; | |
| 412 bind all <Delete> {control_player STOP}; | |
| 413 bind all <Home> {control_player PLAY}; | |
| 414 | |
| 415 update; | |
| 416 } | |
| 417 | |
| 418 proc queue_song {id} { | |
| 419 global songs state; | |
| 420 | |
| 421 set tmp [lindex [lindex [array get songs *:listid:$id] 1] 0]; | |
| 422 log "%s" "Queue - '$songs($tmp:name)' by '$songs($tmp:author)' ($tmp)"; | |
| 423 | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
424 set cookie [acquire_lock]; |
| 1 | 425 n_write "QUEUE [split $tmp {:}]"; |
| 426 n_getrtn rtn; | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
427 release_lock $cookie; |
|
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
428 |
| 1 | 429 if {$rtn(code) != 247} { |
| 430 if {$rtn(code) == 510} { | |
| 431 msg_box "Queue" "You can't have the same\nsong in the queue twice!"; | |
| 432 } else { | |
| 5 | 433 log "%s" "Failed to queue track ($rtn(code) $rtn(data))"; |
| 1 | 434 } |
| 435 } | |
| 436 } | |
| 437 | |
| 438 proc msg_box {title msg} { | |
| 439 global state; | |
| 440 | |
| 441 catch {destroy .msg}; | |
| 442 | |
| 443 toplevel .msg -class Dialog; | |
| 444 wm title .msg $title; | |
| 445 wm iconname .msg $title; | |
| 446 | |
| 447 # text region | |
| 448 frame .msg.frame; | |
| 449 pack .msg.frame -side top -fill both -expand yes; | |
| 3 | 450 text .msg.frame.text -font fixed -yscroll ".msg.frame.scroll set" -wrap none; |
| 1 | 451 scrollbar .msg.frame.scroll -command ".msg.frame.text yview"; |
| 452 pack .msg.frame.text -side left -expand y -fill both; | |
| 453 pack .msg.frame.scroll -side right -fill y; | |
| 454 | |
| 455 # close button | |
| 456 button .msg.close -text "Close" -command "destroy .msg"; | |
| 457 pack .msg.close -side bottom -fill x; | |
| 458 | |
| 459 # read text into the text widget | |
| 460 .msg.frame.text insert end $msg; | |
| 461 } | |
| 462 | |
| 463 proc about_box {} { | |
| 464 global state; | |
| 465 | |
| 466 catch {destroy .about}; | |
| 467 | |
| 468 toplevel .about -class Dialog; | |
| 469 wm title .about "About..."; | |
| 470 wm iconname .about "About"; | |
| 471 | |
| 472 # text region | |
| 473 frame .about.frame; | |
| 474 pack .about.frame -side top -fill both -expand yes; | |
| 475 text .about.frame.text -font fixed -height 10 -width 40 -yscroll ".about.frame.scroll set" \ | |
| 476 -wrap none; | |
| 477 scrollbar .about.frame.scroll -command ".about.frame.text yview"; | |
| 478 pack .about.frame.text -side left -expand y; | |
| 479 pack .about.frame.scroll -side right -fill y; | |
| 480 | |
| 481 # close button | |
| 482 button .about.close -text "Close" -command "destroy .about"; | |
| 483 pack .about.close -side bottom -fill x; | |
| 484 | |
| 485 # read text into the text widget | |
| 486 .about.frame.text insert end "Mserv Client\n"; | |
| 487 .about.frame.text insert end "Copyright Daniel O'Connor 2000\n"; | |
| 488 .about.frame.text insert end "\n"; | |
| 489 .about.frame.text insert end "http://www.dons.net.au/~darius/\n"; | |
| 490 } | |
| 491 | |
| 492 proc set_vol {vol} { | |
| 493 global state; | |
| 494 | |
| 5 | 495 set cookie [acquire_lock]; |
| 1 | 496 n_write "VOLUME $vol" |
| 497 n_getrtn rtn; | |
| 5 | 498 release_lock $cookie; |
| 499 | |
| 1 | 500 if {$rtn(code) != 255} { |
| 501 log "%s" "Couldn't set volume ($rtn(code) $rtn(data))"; | |
| 502 } | |
| 503 } | |
| 504 | |
| 505 proc rate_song {rate} { | |
| 506 global state; | |
| 507 | |
| 5 | 508 set cookie [acquire_lock]; |
| 1 | 509 n_write "RATE $rate"; |
| 510 n_getrtn rtn; | |
| 5 | 511 release_lock $cookie; |
| 1 | 512 |
| 513 if {$rtn(code) != 270} { | |
| 514 log "%s" "Failed to get rate song ($rtn(code) $rtn(data))"; | |
| 515 } | |
| 516 | |
| 517 } | |
| 518 | |
| 519 proc control_player {cmd} { | |
| 520 global state; | |
| 521 | |
| 5 | 522 set cookie [acquire_lock]; |
| 523 log "%s" "Writing $cmd"; | |
| 1 | 524 n_write "$cmd"; |
| 525 n_getrtn rtn; | |
| 5 | 526 release_lock $cookie; |
| 1 | 527 |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
528 # log "%s" "Control Got $rtn(code) $rtn(data)"; |
| 1 | 529 } |
| 530 | |
| 3 | 531 proc gui_top {} { |
| 532 global state; | |
| 533 | |
| 5 | 534 set cookie [acquire_lock]; |
| 3 | 535 n_write "TOP" |
| 536 n_getrtn rtn; | |
| 5 | 537 release_lock $cookie; |
| 3 | 538 |
| 539 set msg "List of songs most likely to be played next\n\n"; | |
| 540 | |
| 541 foreach t $rtn(lines) { | |
| 542 set tmp [split $t \011]; | |
| 543 append msg "[lindex $tmp 0]%\t[lindex $tmp 4] by [lindex $tmp 3]\n"; | |
| 544 } | |
| 545 | |
| 546 msg_box "Top Listing" $msg; | |
| 547 } | |
| 548 | |
| 1 | 549 proc gui_updatesongs {} { |
| 550 global state songs; | |
| 551 | |
| 552 .top.tlist.list delete 0 end; | |
| 553 | |
| 554 set tmp ""; | |
| 555 | |
| 556 foreach tag [array names songs "*:id"] { | |
| 557 set a $songs($tag); | |
| 558 lappend tmp [list $a $songs($a:name) $songs($a:author) $songs($a:albumname)]; | |
| 559 } | |
| 560 | |
| 561 switch -- $state(sortmode) { | |
| 562 "Title" { | |
| 563 set idx 1; | |
| 564 } | |
| 565 | |
| 566 "Artist" { | |
| 567 set idx 2; | |
| 568 } | |
| 569 | |
| 570 "Album" { | |
| 571 set idx 3; | |
| 572 } | |
| 573 | |
| 574 default { | |
| 575 set idx 1; | |
| 576 } | |
| 577 } | |
| 578 set tmp [lsort -dictionary -index $idx $tmp]; | |
| 579 | |
| 580 foreach a [array names songs *:listid:*] { | |
| 581 unset songs($a); | |
| 582 } | |
| 583 | |
| 584 set i 0; | |
| 585 foreach a $tmp { | |
| 586 .top.tlist.list insert end "'[lindex $a 1]' by '[lindex $a 2]' on '[lindex $a 3]'" | |
| 587 set songs([lindex $a 0]:listid:$i) $a; | |
| 588 incr i; | |
| 589 } | |
| 590 } | |
| 591 | |
| 592 proc gui_updatequeue {} { | |
| 593 global state songs queue; | |
| 594 | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
595 # log "%s" "Updating queue"; |
| 1 | 596 |
| 597 .bot.queue.list delete 0 end; | |
| 598 | |
| 599 con_getqueue queue; | |
| 600 | |
| 601 foreach tag [lsort [array names queue]] { | |
| 602 .bot.queue.list insert end "'$songs($queue($tag):name)' by '$songs($queue($tag):author)' on '$songs($queue($tag):albumname)'"; | |
| 603 } | |
| 604 } | |
| 605 | |
| 606 proc gui_delqueue {id} { | |
| 607 global queue; | |
| 608 | |
| 609 if {$id == ""} { | |
| 610 return; | |
| 611 } | |
| 612 | |
| 5 | 613 set cookie [acquire_lock]; |
| 1 | 614 n_write "UNQUEUE [split $queue($id) {:}]"; |
| 615 n_getrtn rtn; | |
| 5 | 616 release_lock $cookie; |
| 617 | |
| 1 | 618 if {$rtn(code) != 254} { |
| 619 log "%s" "Failed to remove $id ($queue($id))"; | |
| 620 msg_box "Queue" "Failed to dequeue the song"; | |
| 621 } | |
| 622 } | |
| 623 | |
| 624 proc gui_updateinfo {} { | |
| 625 global state; | |
| 626 | |
| 5 | 627 set cookie [acquire_lock]; |
| 1 | 628 n_write "VOLUME"; |
| 629 n_getrtn rtn; | |
| 5 | 630 release_lock $cookie; |
| 1 | 631 |
| 632 if {$rtn(code) != 235} { | |
| 633 set vol "??"; | |
| 634 } else { | |
| 635 set vol "[lindex [lindex $rtn(lines) 0] 0]"; | |
| 636 } | |
| 637 | |
| 5 | 638 set cookie [acquire_lock]; |
| 1 | 639 n_write "INFO"; |
| 640 n_getrtn rtn; | |
| 5 | 641 release_lock $cookie; |
| 1 | 642 |
| 643 if {$rtn(code) == 246} { | |
| 644 set data [split [lindex $rtn(lines) 0] "\t"]; | |
| 645 set author [lindex $data 4]; | |
| 646 set title [lindex $data 5]; | |
| 647 set length [lindex $data 14]; | |
| 648 set album [lindex $data 3]; | |
| 3 | 649 set rate1 [lindex $data 9]; |
| 650 set rate2 [lindex $data 10]; | |
| 651 set misc [lindex $data 15]; | |
| 1 | 652 } else { |
| 653 set author "N/A"; | |
| 654 set title "N/A"; | |
| 655 set length "N/A"; | |
| 656 set album "N/A"; | |
| 3 | 657 set rate1 "N/A"; |
| 658 set rate2 "N/A"; | |
| 659 set misc "N/A"; | |
| 1 | 660 if {$rtn(code) != 401} { |
| 661 log "%s" "Failed to get track info ($rtn(code) $rtn(data))"; | |
| 662 } | |
| 663 } | |
| 664 | |
| 5 | 665 set cookie [acquire_lock]; |
| 1 | 666 n_write "STATUS"; |
| 667 n_getrtn rtn; | |
| 5 | 668 release_lock $cookie; |
| 1 | 669 |
| 670 if {$rtn(code) != 222} { | |
| 671 set played "x:xx"; | |
| 672 } else { | |
| 673 set played [lindex [split [lindex $rtn(lines) 0] "\t"] 8]; | |
| 674 } | |
| 675 | |
| 676 .top.tinfo.sub.author configure -text "Author: $author"; | |
| 677 .top.tinfo.sub.title configure -text "Title: $title"; | |
| 678 .top.tinfo.sub.length configure -text "Length: $length"; | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
679 # .top.tinfo.sub.time configure -text "Time: $played"; |
| 1 | 680 .top.tinfo.sub.album configure -text "Album: $album"; |
| 3 | 681 .top.tinfo.sub.misc configure -text "Misc: $misc"; |
| 682 .top.tinfo.sub.rate1 configure -text "Rating: $rate1"; | |
| 683 .top.tinfo.sub.rate2 configure -text "Temporally Adjusted: $rate2"; | |
| 1 | 684 .top.tinfo.sub.vol configure -text "Volume: $vol"; |
| 5 | 685 |
| 1 | 686 } |
| 687 | |
| 688 proc con_getqueue {queuevar} { | |
| 689 upvar $queuevar queue; | |
| 690 | |
| 691 global state; | |
| 692 | |
| 693 catch {unset queue}; | |
| 694 | |
| 5 | 695 set cookie [acquire_lock]; |
| 1 | 696 n_write "QUEUE" |
| 697 n_getrtn rtn; | |
| 5 | 698 release_lock $cookie; |
| 699 | |
| 1 | 700 if {$rtn(code) == 225} { |
| 701 set i 0; | |
| 702 foreach line $rtn(lines) { | |
| 703 set foo [split $line \011]; | |
| 704 set id "[lindex $foo 1]:[lindex $foo 2]"; | |
| 705 | |
| 706 set queue($i) $id; | |
| 707 incr i; | |
| 708 } | |
| 709 } elseif {$rtn(code) == 404} { | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
710 # log "%s" "Queue empty"; |
| 1 | 711 } else { |
| 712 log "%s" "Failed to get queue ($rtn(code) $rtn(data))"; | |
| 713 } | |
| 714 } | |
| 715 | |
| 716 proc con_getsongs {songsvar albumsvar} { | |
| 717 upvar $songsvar songs; | |
| 718 upvar $albumsvar albums; | |
| 719 | |
| 720 global state; | |
| 721 | |
| 722 catch { unset songs }; | |
| 723 | |
| 724 foreach i [array names albums "*:"] { | |
| 5 | 725 set cookie [acquire_lock]; |
| 1 | 726 n_write "TRACKS $albums($i)"; |
| 727 n_getrtn rtn; | |
| 5 | 728 release_lock $cookie; |
| 729 | |
| 1 | 730 if {$rtn(code) != "228"} { |
| 731 error "Got bogus response to track request ($rtn(code) $rtn(data))"; | |
| 732 } | |
| 733 | |
| 734 foreach trk $rtn(lines) { | |
| 735 set foo [split $trk \011]; | |
| 736 if {[llength $foo] != 6} { | |
| 737 continue; | |
| 738 } | |
| 739 | |
| 740 set albid [lindex $foo 0]; | |
| 741 set num [lindex $foo 1] | |
| 742 set songs($albid:$num:id) "$albid:$num"; | |
| 743 set songs($albid:$num:author) [lindex $foo 2]; | |
| 744 set songs($albid:$num:name) [lindex $foo 3]; | |
| 745 set songs($albid:$num:rating) [lindex $foo 4]; | |
| 746 set songs($albid:$num:length) [lindex $foo 5]; | |
| 747 set songs($albid:$num:albumname) $albums($albid:name); | |
| 748 } | |
| 749 } | |
| 750 | |
| 751 } | |
| 752 | |
| 753 proc con_getalbums {albumsvar} { | |
| 754 upvar $albumsvar albums; | |
| 755 | |
| 756 global state; | |
| 757 | |
| 758 catch {unset albums}; | |
| 759 | |
| 5 | 760 set cookie [acquire_lock]; |
| 1 | 761 n_write "ALBUMS"; |
| 762 n_getrtn rtn; | |
| 5 | 763 release_lock $cookie; |
| 764 | |
| 1 | 765 if {$rtn(code) != 227} { |
| 766 error "Server gave bogus response to album request ($rtn(code) $rtn(data))"; | |
| 767 } | |
| 768 | |
| 769 foreach alb $rtn(lines) { | |
| 770 set foo [split $alb \011]; | |
| 771 set id [lindex $foo 0]; | |
| 5 | 772 if {$id == ""} { |
| 773 continue; | |
| 774 } | |
| 775 set albums($id:) $id; | |
| 1 | 776 set albums($id:author) [lindex $foo 1]; |
| 777 set albums($id:name) [lindex $foo 2]; | |
| 778 | |
| 5 | 779 # log "%s" "Album $id, ID '$albums($id:)' called '$albums($id:name)' by '$albums($id:author)'"; |
| 1 | 780 } |
| 781 } | |
| 782 | |
| 783 proc update_timer {} { | |
| 784 | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
785 # gui_updateinfo; |
| 1 | 786 |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
787 |
| 1 | 788 after 900 update_timer; |
| 789 } | |
| 790 | |
| 791 proc con_mserv {} { | |
| 792 global state; | |
| 793 | |
| 794 # Close old FD | |
| 795 catch {close state(serv_fd)}; | |
| 796 catch {unset state(serv_fd)}; | |
| 797 | |
| 798 catch {fileevent $state(serv_fd) readable ""}; | |
| 799 set state(serv_fd) [ socket $state(host) $state(port) ]; | |
| 800 set state(pushbuf) ""; | |
| 801 fileevent $state(serv_fd) readable n_rtinput; | |
| 802 fconfigure $state(serv_fd) -blocking 0; | |
| 803 | |
| 804 # Greeting from server | |
| 805 n_getrtn rtn; | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
806 log "%s" $rtn(data); |
| 1 | 807 if {$rtn(code) != "200"} { |
| 808 error "Server failed to send greeting"; | |
| 809 } | |
| 810 | |
| 811 # Login | |
| 812 n_write "USER $state(user)" | |
| 813 n_getrtn rtn; | |
| 814 if {$rtn(code) != "201"} { | |
| 815 error "Server failed to send password request"; | |
| 816 } | |
| 817 | |
| 818 n_write "PASS $state(pass) RTCOMPUTER"; | |
| 819 n_getrtn rtn; | |
| 820 if {$rtn(code) == "507"} { | |
| 821 error "Server rejected our credentials"; | |
| 822 } | |
| 823 | |
| 824 if {$rtn(code) != "202"} { | |
| 825 error "Unknown response to PASS command - $rtn(code) $rtn(data)" | |
| 826 } | |
| 5 | 827 |
| 828 set state(lock) ""; | |
| 829 # trace variable state(lock) rw foobar; | |
| 830 | |
| 1 | 831 log "%s" "Logged in"; |
| 832 } | |
| 833 | |
| 834 proc n_write {text} { | |
| 835 global state; | |
| 836 | |
| 837 puts $state(serv_fd) $text; | |
| 5 | 838 flush $state(serv_fd); |
| 1 | 839 |
| 5 | 840 if {[eof $state(serv_fd)]} { |
| 841 log "%s" "Server went away on write"; | |
| 842 exit 1; | |
| 843 } | |
| 844 # log "%s" "Wrote - $text"; | |
| 1 | 845 } |
| 846 | |
| 847 proc n_rthandler {code data} { | |
| 848 global songs; | |
| 849 | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
850 # log "%s" "Got RT - $code $data"; |
| 1 | 851 |
| 852 switch -- $code { | |
| 853 600 { | |
| 854 log "%s" "User '$data' connected"; | |
| 855 } | |
| 856 | |
| 857 601 { | |
| 858 log "%s" "User '$data' disconnected"; | |
| 859 } | |
| 860 | |
| 5 | 861 240 - |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
862 602 - |
|
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
863 615 - |
| 1 | 864 618 - |
| 865 619 - | |
| 5 | 866 620 - |
| 1 | 867 622 - |
| 5 | 868 623 - |
| 1 | 869 627 - |
| 5 | 870 628 - |
| 871 629 { | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
872 # log "%s" "Updating queue on idle"; |
|
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
873 gui_updateinfo; |
| 5 | 874 gui_updatequeue; |
| 875 } | |
| 876 | |
| 877 default { | |
| 878 log "%s" "Got unhandled RT event $code $data"; | |
| 1 | 879 } |
| 880 } | |
| 881 } | |
| 882 | |
| 883 proc n_rtinput {} { | |
| 884 global state; | |
| 885 | |
| 886 set rth ""; | |
| 887 | |
| 5 | 888 while {1} { |
| 889 set line [gets $state(serv_fd)]; | |
| 890 if {[eof $state(serv_fd)]} { | |
| 891 log "%s" "Server went away on read"; | |
| 892 exit 1; | |
| 893 } | |
| 894 # log "%s" "Read - $line"; | |
| 895 if {$line == ""} { | |
| 896 return; | |
| 1 | 897 } |
| 5 | 898 # Check for RT text |
| 899 set foo [split $line "\t"]; | |
| 900 if {[string index $line 0] == "="} { | |
| 901 lappend state(rtlist) [list [string range [lindex $foo 0] 1 3] [lrange $foo 1 end]]; | |
| 902 # log "%s" "RT event"; | |
| 903 } else { | |
| 904 lappend state(tmpphrase) $line | |
| 905 if {$line == "."} { | |
| 906 set state(pushbuf) [linsert $state(pushbuf) 0 $state(tmpphrase)]; | |
| 907 # log "%s" "push buffer - '$state(tmpphrase)'"; | |
| 908 set state(tmpphrase) ""; | |
| 909 } | |
| 910 } | |
| 911 } | |
| 1 | 912 } |
| 913 | |
| 914 proc n_getrtn {var} { | |
| 915 upvar $var rtn; | |
| 916 global state; | |
| 917 | |
| 918 set gotcode 0; | |
| 919 catch {unset rtn(code)}; | |
| 920 catch {unset rtn(data)}; | |
| 921 catch {unset rtn(lines)} | |
| 922 | |
| 923 while {[llength $state(pushbuf)] == 0} { | |
| 5 | 924 # log "%s" "Sleeping for data"; |
| 1 | 925 vwait state(pushbuf); |
| 926 } | |
| 5 | 927 |
| 928 # log "%s" "Waking up, got $state(pushbuf)"; | |
| 929 | |
| 1 | 930 set buf [lindex $state(pushbuf) 0]; |
| 931 set state(pushbuf) [lrange $state(pushbuf) 1 end]; | |
| 932 | |
| 933 while {1} { | |
| 934 if {[llength $buf] == 0} { | |
| 935 break; | |
| 936 } | |
| 937 | |
| 938 set line [lindex $buf 0]; | |
| 939 set buf [lrange $buf 1 end]; | |
| 940 | |
| 941 if {[string index $line 0] == "."} { | |
| 942 break; | |
| 943 } | |
| 944 | |
| 945 if {$gotcode == 0} { | |
| 946 set rtn(code) [string range $line 0 2]; | |
| 947 set rtn(data) [string range $line 4 end]; | |
| 948 set gotcode 1; | |
| 949 continue; | |
| 950 } | |
| 951 | |
| 952 lappend rtn(lines) $line; | |
| 953 } | |
| 954 | |
| 955 if {$gotcode == 0} { | |
| 5 | 956 log "%s" "Failed to parse phrase (got . before server response)"; |
| 1 | 957 } |
| 958 } | |
| 959 | |
| 960 ################################################################## | |
| 961 # Log a message to stderr | |
| 962 # | |
| 963 proc log {format args} { | |
| 964 # Extract the calling function's name | |
| 3 | 965 if {[catch {set fname [lindex [info level -1] 0]}]} { |
| 966 set fname "unknown"; | |
| 967 } | |
| 1 | 968 |
| 969 # Evaluate the supplied format string and arguments | |
| 970 if {[catch {set csm [eval format {$format} $args]} msg]} { | |
| 971 set csm "bad log message. format='$format' args='$args'"; | |
| 972 } | |
| 973 | |
| 974 # Emit the message | |
| 5 | 975 catch { |
| 976 puts stderr "[clock format [clock seconds] -format {%y/%m/%d %H:%M:%S} -gmt yes]:$fname: $csm"; | |
| 977 flush stderr; | |
| 978 } | |
| 979 } | |
| 980 | |
| 981 proc acquire_lock {} { | |
| 982 global state; | |
| 983 | |
| 984 # Extract the calling function's name | |
| 985 if {[catch {set fname [lindex [info level -1] 0]}]} { | |
| 986 set fname "unknown"; | |
| 987 } | |
| 988 | |
| 989 # log "%s" "Acquiring lock for $fname"; | |
| 990 | |
| 991 set foo 0; | |
| 992 | |
| 993 if {[info exists state(lock)]} { | |
| 994 while {$state(lock) != ""} { | |
| 995 set foo 1; | |
| 996 log "%s" "$fname waiting for lock (held by [lindex $state(lock) 1])"; | |
| 997 vwait state(lock); | |
| 998 } | |
| 999 | |
| 1000 if {$foo == 1} { | |
| 1001 log "%s" "Lock released"; | |
| 1002 } | |
| 1003 | |
| 1004 } | |
| 1005 | |
| 1006 set cookie [clock clicks]; | |
| 1007 set state(lock) [list $cookie $fname]; | |
| 1008 # log "%s" "Lock acquired"; | |
| 1009 return $cookie; | |
| 1 | 1010 } |
| 1011 | |
| 5 | 1012 proc release_lock {cookie} { |
| 1013 global state; | |
| 1014 | |
| 1015 # Extract the calling function's name | |
| 1016 if {[catch {set fname [lindex [info level -1] 0]}]} { | |
| 1017 set fname "unknown"; | |
| 1018 } | |
| 1019 | |
| 1020 if {$cookie == ""} { | |
| 1021 log "%s" "$fname trying to unlock without being locked"; | |
| 1022 exit 1; | |
| 1023 } | |
| 1024 | |
| 1025 if {$cookie != [lindex $state(lock) 0]} { | |
| 1026 log "%s" "Lock cookie not matched!"; | |
| 1027 exit 1; | |
| 1028 } | |
| 1029 | |
| 1030 if {$fname != [lindex $state(lock) 1]} { | |
| 1031 log "%s" "$fname tried to free [lindex $state(lock) 1]'s lock!"; | |
| 1032 exit 1; | |
| 1033 } | |
| 1034 | |
| 1035 set state(lock) ""; | |
| 1036 # log "%s" "Lock for $fname now free"; | |
| 1037 } | |
| 1038 | |
| 1039 proc foobar {n1 n2 op} { | |
| 1040 global state; | |
| 1041 | |
| 1042 log "%s" "$op, now $state(lock)"; | |
| 1043 } | |
| 1044 | |
| 1045 if {[catch {main} msg]} { | |
|
6
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
1046 catch {tk_dialog .dummy "Error!" [format "%s\n%s" $msg $errorInfo] error 0 "OK"}; |
|
b370e0bbe050
Remove the check every second, since it breaks stuff :-/
darius
parents:
5
diff
changeset
|
1047 exit 1; |
| 5 | 1048 } |
| 1049 |