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