Another Shoutcast Player FROM: http://wiki.tcl.tk/14032 (imaged on 2009 mar 19) Copy the two code snippets below to player-cmd.tcl and player-gui.tcl. Run player-gui.tcl to bathe in music goodness. (This program requires both snack and memchan, both of which are supplied in the ActiveTcl distribution. It has been tested under Tcl 8.4.9 for Linux/x86; it ought to work for other platforms. The default URL goes to http://www.club977.com, a free 80's pop music station.) See notes on getting rid of popping sounds, at http://wiki.tcl.tk/14032 --------------------- player-cmd.tcl below: #//# # Shoutcast stream player. Based on Daniel Zlobec's basic snack # stream player (http://wiki.tcl.tk/13305) # # @author Jason Tang (tang@jtang.org) #//# package require Memchan package require snack namespace eval shoutcast { namespace export * set doDebug 0 set title "No data" set total 0 set s {} } proc shoutcast::connect {server port path} { variable sock shoutcast::init shoutcast::openChannel shoutcast::initSnack variable title "Connecting to $server..." update set sock [socket $server $port] fconfigure $sock -blocking 0 -buffering full -buffersize 100000 \ -translation {binary auto} append buff "GET $path HTTP/1.0\n" append buff "Host: $server\n" append buff "Icy-MetaData:1\n" append buff "Accept: */*\n" append buff "User-Agent: Tcl/8.4.9\n" append buff "\n" puts $sock $buff flush $sock set title "Connected to $server." fileevent $sock readable [list shoutcast::readHeader $sock] } proc shoutcast::init {} { package forget snack package require snack variable header array unset header set header(icy-metaint) 0 variable total 0 variable s {} variable sock {} variable fd {} } proc shoutcast::openChannel {} { variable fd set fd [fifo] fconfigure $fd -translation {binary binary} -encoding binary \ -buffering none -buffersize 100000 } proc shoutcast::closeChannel {} { variable fd catch {close $fd} } proc shoutcast::initSnack {} { variable s set s [snack::sound s] } proc shoutcast::disconnect {} { variable sock catch {close $sock} shoutcast::closeChannel } proc shoutcast::play {} { variable s variable fd $s configure -channel $fd -buffersize 100000 -debug 0 after 3000 [list $s play] } proc shoutcast::stop {} { variable s $s stop shoutcast::disconnect $s destroy variable title "" } proc shoutcast::readHeader {sock} { variable header variable fd set count [gets $sock line] if {$count == -1 && [eof $sock] == 1} { stop } set h [split $line ":"] if {[llength $h] == 2} { foreach {key value} $h { set header($key) [string trim $value] } } # reached end of meta tags; music data henceforth if {$count == 1 && $line == "\r"} { parray header if {[info exist header(icy-name)]} { variable title $header(icy-name) } if {[info exist header(icy-metaint)] && $header(icy-metaint) >= 0} { variable metaint $header(icy-metaint) variable readSize $metaint fileevent $sock readable [list shoutcast::readStreamMetaInt $sock] } else { fileevent $sock readable [list shoutcast::readStream $sock] } } } proc shoutcast::readStream {sock} { variable readSize variable total variable fd # stream has just music data, no music information fcopy $sock $fd -size 4096 } proc shoutcast::readStreamMetaInt {sock} { variable readSize variable total variable fd variable metaint set data [read $sock $readSize] incr total [string length $data] puts -nonewline $fd $data if {$total != $metaint} { set readSize [expr {$metaint - $total}] } else { set readSize $metaint set total 0 fileevent $sock readable [list shoutcast::readTitleLength $sock] } } proc shoutcast::readTitleLength {sock} { set c 0 set titleSize [read $sock 1] scan $titleSize %c c set titleSize [expr {$c * 16}] if {$c == 0} { fileevent $sock readable [list shoutcast::readStreamMetaInt $sock] } else { fileevent $sock readable [list shoutcast::readTitle $sock $titleSize] } } proc shoutcast::readTitle {sock size} { #Shoutcast song information looks like this: # StreamTitle='';StreamUrl='<url>'; set t "" while {$size > 0} { set data [read $sock $size] append t $data set size [expr {$size - [string length $data]}] } set t [string trim $t] if {[regexp -nocase -- {streamtitle='(.*?)';} $t foo _title] && $_title != ""} { variable title $_title } if {[regexp -nocase -- {streamurl='(.*?)';} $t foo url]} { # ignore the URL for now } fileevent $sock readable [list shoutcast::readStreamMetaInt $sock] } -------------------- player-gui.tcl below: #//# # Shoutcast player interface. Based on Daniel Zlobec's basic snack # stream player (http://wiki.tcl.tk/13305). # # @author Jason Tang (tang@jtang.org) #//# package require Tk source player-cmd.tcl # change this with other addresses of radio stations #set host 206.98.167.99 #set port 8712 namespace eval player { namespace export * set status stop } proc player::createGui {} { variable url "http://64.236.34.67:80/stream/1040" label .title -textvariable shoutcast::title -width 50 pack .title -fill both -expand 1 button .play -text Play -command player::cmdPlay button .stop -text Stop -command player::cmdStop button .quit -text Quit -command player::cmdQuit pack .quit .stop .play -side right label .l -text "URL: " entry .entry -textvariable player::url -width 32 pack .l .entry -side left } proc player::cmdQuit {} { variable status if {$status == "play"} { shoutcast::stop set status stop } exit } proc player::cmdPlay {} { variable status variable url if {$status == "play"} { return } if {[regexp {(\Ahttp:\/\/)?([^:/]+)(:(\d+))?(.*)} $url foo foo2 server foo3 port path]} { if {$port == ""} { set port 80 } if {$path == ""} { set path "/" } puts "server = $server; port = $port; path = $path" shoutcast::connect $server $port $path set status play shoutcast::play } else { set shoutcast::title "<could not parse url>" } } proc player::cmdStop {} { variable status if {$status == "play"} { shoutcast::stop set status stop } } player::createGui