[DZ] - 10 Jan 2005: This is a simple shoutcast stream player. It supports stream titles, future versions should support saving stream to disk.

 ###### player-cmd.tcl ######################################################
 #
 # Shoutcast stream player
 #
 # Copyright 2005 - DZ
 #
 # Shared under NOL licence : http://wiki.tcl.tk/nol
 #
 # Version 0.1 - January 2005
 #
 ############################################################################
 #
 # This is a simple shoutcast stream player. It supports titles. Future
 # versions will support saving the stream to disk.
 #
 #
 #
 #        connect
 #        readHeader
 #         /      \
 # readStream   readStreamMetaInt
 #              readTitleLength
 #              readTitle
 #
 
 package require http
 package require Memchan
 package require snack
 
 
 set doDebug 0
 
 proc debug {text} {
   if {$::doDebug == 1} {
     puts $text
   }
 }
 
 
 
 namespace eval shoutcast {
 
   namespace export *
 
   set header(icy-metaint) 0
   set doDebug 0
   set title "No data"
 
   set readSize 8192
   set total 0
 
   set s {}
 }
 
 
 proc shoutcast::init {} {
 
   package forget snack
   package require snack
 
   array unset header
   set header(icy-metaint) 0
   set title "No data"
 
   set readSize 8192
   set total 0
 
   set s {}
   set sock {}
 
   set fd {}
 }
 
 proc shoutcast::openChannel {} {
   variable fd
 
 # save stream in file
 #  set fd [open 1.mp3 w]
 #  fconfigure $fd -translation binary
 
   set fd [fifo]
   fconfigure $fd -translation binary -encoding binary \
     -buffering full -buffersize 200000 ;# -blocking true
 
 }
 
 proc shoutcast::closeChannel {} {
   variable fd
 
   catch {close $fd}
 }
 
 
 proc shoutcast::initSnack {} {
   variable s
 
   if {$s == {}} {
     set s [snack::sound s]
   }
 }
 
 
 proc shoutcast::connect {url port} {
   global sock
 
   shoutcast::init
   shoutcast::openChannel
   shoutcast::initSnack
 
   set sock [socket $url $port]
 
   fconfigure $sock -blocking 0 -buffering full -buffersize 100000 \
     -translation {binary auto}
 #  fconfigure $fd -translation binary -encoding binary \
 #    -buffering full -buffersize 200000 ;# -blocking true
 
 
   append buff "GET / HTTP/1.0\n"
   append buff "Host: $url\n"
   append buff "Accept: */*\n"
   append buff "User-Agent: xmms/1.2.7\n"
   append buff "Icy-MetaData:1\n"
   #append buff "x-audiocast-udpport: $::udp_port\n"
   append buff "\n"
 
   puts $sock $buff
   flush $sock
 
 #  after 2000
 
   fileevent $sock readable { shoutcast::readHeader $sock }
 }
 
 
 proc shoutcast::readHeader {sock} {
   variable header
   variable fd
 
   set count [gets $sock line]
   if {$count == -1} { return }
 
 
   set h [split $line ":"]
   if {[llength $h] == 2} {
     foreach {key value} $h { set header($key) $value }
   }
 
 
 
   if {$count == 1 && $line == "\r"} {
 
     if {$header(icy-metaint) != 0} {
       fileevent $sock readable { shoutcast::readStreamMetaInt $sock }
     } else {
       fileevent $sock readable { shoutcast::readStream $sock }
     }
   }
 }
 
 
 proc shoutcast::readStream {sock} {
   variable readSize
   variable total
   variable fd
 
   set data [read $sock 4096]
 
   puts -nonewline $fd $data
 }
 
 
 proc shoutcast::readStreamMetaInt {sock} {
   variable readSize
   variable total
   variable fd
 
 
   set data [read $sock $readSize]
   set count [string length $data]
   set total [incr total $count]
 
   puts -nonewline $fd $data
 
   if {$total != 8192} {
     set readSize [expr {$readSize - $count}]
     debug "-count: $count, total: $total, readSize: $readSize"
   } else {
     debug "+count: $count, total: $total, readSize: $readSize"
     set readSize 8192
     set total 0
     fileevent $sock readable { shoutcast::readTitleLength $sock }
   }
 }
 
 proc shoutcast::readTitleLength {sock} {
   set c 0
   set titleSize [read $sock 1]
 
   scan $titleSize %c c
   debug "c: $c"
 
   set titleSize [expr {$c * 16}]
 
   fileevent $sock readable [list shoutcast::readTitle $sock $titleSize]
 }
 
 proc shoutcast::readTitle {sock size} {
   variable title
 
   #StreamTitle='';StreamUrl='';
 
   if {$size != 0} {
     set t [read $sock $size]
     set t [string trim $t]
     set rx [regexp -- {StreamTitle='(.*)';StreamUrl='(.*)';} $t - _title url]
     if {$rx} {
       set title $_title
     }
   }
 
   fileevent $sock readable { shoutcast::readStreamMetaInt $sock }
 }
 
 proc shoutcast::play {} {
   variable s
   variable fd
 
   $s configure -channel $fd -buffersize 100000 -debug 0
   $s play ;#-command shoutcast::disconnect
 }
 
 proc shoutcast::stop {} {
   variable s
 
   $s stop
   shoutcast::disconnect
   $s destroy
 }
 
 proc shoutcast::disconnect {} {
   global sock
   catch {close $sock}
 
   shoutcast::closeChannel
 }
 
This is the GUI:

 ###### player-gui.tcl ######################################################  
 #                                                   
 # Shoutcast stream player - gui
 #
 # Copyright 2005 - DZ
 #
 # Shared under NOL licence : http://wiki.tcl.tk/nol
 #
 # Version 0.1 - January 2005
 #
 ############################################################################
  
 source player-cmd.tcl
 
 
 #set host 127.0.0.1
 #set port 5002
 
 set host 206.98.167.99
 set port 8712
 
 
 namespace eval player {
 
   namespace export *
 
   set status stop
 }
 
 proc player::createGui {} {
   label .title -textvariable shoutcast::title
   pack .title -fill both -expand 1
   button .play -text Play -command player::cmdPlay
   button .stop -text Stop -command player::cmdStop
   button .record -text Rec
   button .quit -text Quit -command player::cmdQuit
 
   pack .play .stop .record .quit -side left
 }
 
 
 proc player::cmdQuit {} {
   variable status
 
   if {$status == "play"} {
     shoutcast::stop
     set status stop
   }
 
   exit
 }
 
 proc player::cmdPlay {} {
   variable status
 
   if {$status == "play"} {
 #    shoutcast::stop
 #    set status stop
      return
   }
 
   shoutcast::connect $host $port
   set status play
 
   after 3000 shoutcast::play
 }
 
 proc player::cmdStop {} {
   variable status
 
   if {$status == "play"} {
     shoutcast::stop
     set status stop
   }
 }
 

 if {0} {
 proc showInfo {} {
 
   puts [$shoutcast::s info]
   after 3000 showInfo
 }
 after 3000 showInfo
 }
 
 player::createGui