http://www.club977.com

http://tcl.jtang.org/shoutcast_player/shoutcast_player.tar.gz

 #//#
 # 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 "<stopped>"
 }

 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='<title>';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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References