# $Id: now_playing.tcl 230 2009-08-19 15:00:45Z kostix $
# "Now Playing" -- User Tune plugin for Tkabber.
# It is able to automatically gather now-playing information
# from a number of media players and publish it according
# to the XEP-0118 ("User Tune") protocol.
# Written by Konstantin Khomoutov <flatworm@users.sourceforge.net>
# See license.terms for details about distribution.
# See README for details about usage.

namespace eval now_playing {
	variable options
	variable lasttime 0
	variable lastmethod none
	variable connections [list]
	variable monitoring off
	variable nwarns

	proc my what {
		return [uplevel 1 namespace current]::$what
	}

	proc mycmd args {
		lset args 0 [uplevel 1 namespace current]::[lindex $args 0]
	}

	proc K {x y} { set x }

	custom::defgroup "User Tune" \
		[::msgcat::mc "Plugins for automatic gathering of\
			information for User Tune personal eventing facility."] \
		-group Plugins

	custom::defgroup "Now Playing" \
		[::msgcat::mc "Support processing of \"now playing\" information\
			served by various media players."] \
		-group "User Tune"

	custom::defvar options(media_player) none \
		[::msgcat::mc "Media player that manages the now playing file.\
			Please note that some media players and/or their \"now playing\"\
			plugins require additional configuration to work with this plugin.\
			Please consult the README file of this plugin for configuration\
			instructions. Select \"None\" to disable this plugin."] \
		-type options \
		-values [list] \
		-command [mycmd on_media_player_changed] \
		-group "Now Playing"

	custom::defvar options(check_timeout) 1 \
		[::msgcat::mc "Timeout (in seconds) between checks\
			for modification of the available now-playing information."] \
		-type integer \
		-group "Now Playing"

	custom::defvar options(update_threshold) 30 \
		[::msgcat::mc "Minimal amount of time (in seconds) that must tick\
			between adjacent changes in the now-playing information\
			for it to be noticed and used."] \
		-type integer \
		-command [mycmd on_update_thresh_changed] \
		-group "Now Playing"

	custom::defvar options(file) [file join $::configdir now_playing] \
		[::msgcat::mc "Pathname of the now playing file.\
			(This setting is only relevant to those media players that\
			serve the information about their user tune using a text file.)"] \
		-type file \
		-group "Now Playing"

	hook::add connected_hook \
		[mycmd on_new_connection]
	hook::add disconnected_hook \
		[mycmd on_connection_gone]

	# How many warnings of each topic to report:
	set options(throttle_warns_after) 3
}

proc now_playing::warn {topic msg} {
	variable options
	variable nwarns

	if {![info exists nwarns($topic)]} {
		set nwarns($topic) 0
	} elseif {$nwarns($topic) >= $options(throttle_warns_after)} return

	puts stderr "np_file: $msg"
	incr nwarns($topic)
}

proc now_playing::enabled {} {
	variable options

	expr {![string equal $options(media_player) none]}
}

proc now_playing::method {} {
	variable options

	set options(method,$options(media_player))
}

proc now_playing::player {action args} {
	variable options
	upvar 0 options($action,$options(media_player)) script

	if {$script != ""} {
		namespace eval :: [linsert $args 0 $script]
	}
}

proc now_playing::monitoring {op {val ""}} {
	variable monitoring

	switch -- $op {
		get {
			set monitoring
		}
		is {
			expr {$monitoring && $val]}
		}
		set {
			if {$val && !$monitoring} {
				set monitoring on
				method_start_[method]
			} elseif {$monitoring && !$val} {
				set monitoring off
				method_stop_[method]
			}
			set monitoring
		}
		default {
			return -code error "Bad operation \"$op\":\
				must be get, is or set"
		}
	}
}

# Calling of this procedure does only have sense when done from
# a now_playing_enumerate_media_players hook.
proc now_playing::add_media_player args {
	variable options
	variable players

	set init    ""
	set cleanup ""
	set yield   ""

	foreach {opt val} $args {
		switch -- $opt {
			-tag     { set tag $val }
			-name    { set name $val }
			-method  { set method $val }
			-init    { set init $val }
			-cleanup { set cleanup $val }
			-yield   { set yield $val }
			default {
				return -code error "Bad option \"$opt\":\
					must be one of -tag, -name or -parser"
			}
		}
	}

	foreach v {tag name method} {
		if {![info exists $v]} {
			return -code error "Required option missing: -$v"
		}
	}

	switch -- $method {
		none - file - registry - send - sockpull {}
		default {
			return -code error "Bad method \"$method\":\
				must be one of file, registry or send"
		}
	}

	set options(name,$tag)    $name
	set options(method,$tag)  $method
	set options(init,$tag)    $init
	set options(cleanup,$tag) $cleanup
	set options(yield,$tag)   $yield

	lappend players $tag $name
}

proc now_playing::enumerate_media_players args {
	variable options
	variable players

	foreach {tag name method yield} [list \
		none       [::msgcat::mc "None"]  none     {} \
		amarok     "Amarok"               send     {} \
		foobar     "Foobar2000"           file     [mycmd foobar_yield] \
		QL         "Quod Libet"           file     [mycmd quodlibet_yield] \
		wmp        "Windows Media Player" registry [mycmd wmp_yield]  \
	] {
		add_media_player -tag $tag -name $name -method $method -yield $yield
	}

	add_media_player -tag mpd -name "MPD" -method sockpull \
		-init [mycmd mpd_init] -cleanup [mycmd mpd_cleanup] \
		-yield [mycmd mpd_yield]

	hook::run now_playing_enumerate_media_players

	custom::configvar [namespace current]::options(media_player) -values $players

	unset players
}

proc now_playing::on_new_connection connid {
	variable connections

	lappend connections $connid

	monitoring set [expr {[enabled] && [llength $connections] > 0}]
}

proc now_playing::on_connection_gone connid {
	variable connections

	# Empty $connid means all the connections are gone at once.
	if {$connid == ""} {
		set connections [list]
	} else {
		set ix [lsearch -exact $connections $connid]
		if {$ix >= 0} {
			set connections [lreplace $connections $ix $ix]
		}
	}

	monitoring set [expr {[enabled] && [llength $connections] > 0}]
}

proc now_playing::on_media_player_changed args {
	variable lastmethod
	variable connections

	if {![string equal $lastmethod [method]]} {
		method_stop_$lastmethod
	}
	set lastmethod [method]

	monitoring set [expr {[enabled] && [llength $connections] > 0}]

	if {![enabled]} {
		foreach connid $connections {
			::plugins::tune::unpublish $connid
		}
	}
}

proc now_playing::on_update_thresh_changed args {
	variable options

	# Prevent modification time threshold from being lower than 10 sec:
	if {$options(update_threshold) < 10} {
		set options(update_threshold) 10
	}
}

proc now_playing::poll {op {script ""}} {
	variable repollid

	switch -- $op {
		using {
			[mycmd poller] $script
		}
		cancel {
			if {[info exists repollid]} {
				after cancel $repollid
				unset repollid
			}
		}
		default {
			return -code error "Bad operation \"$op\":\
				must be one of using or cancel"
		}
	}

}

proc now_playing::poller script {
	variable options
	variable repollid

	debugmsg tune [info level 0]

	namespace eval :: $script

	if {$options(check_timeout) > 0} {
		set repollid [after \
			[expr {$options(check_timeout) * 1000}] [info level 0]]
	}
}

#### Method: none

proc now_playing::method_start_none {} {}

proc now_playing::method_stop_none {} {}

#### Method: file

proc now_playing::method_start_file {} {
	debugmsg tune [info level 0]
	poll using [mycmd file_yield]
}

proc now_playing::method_stop_file {} {
	debugmsg tune [info level 0]
	poll cancel
}

proc now_playing::read_utf8 fname {
	set fd [open $fname]
	fconfigure $fd -encoding utf-8
	K [string trimleft [read $fd] \uFEFF] [close $fd]
}

proc now_playing::file_yield {} {
	variable options
	variable lasttime

	if {![file readable $options(file)]} {
		warn missing "file \"$options(file)\" doesn't exist or is not readable"
		return
	}

	set mtime [file mtime $options(file)]
	if {$mtime - $lasttime < $options(update_threshold)} return
	set lasttime $mtime

	upvar 0 options(media_player) tag
	set failed [catch [list $options(yield,$tag) $options(file)]]
	if {$failed} {
		global errorInfo
		set monitoring false
		warn parsing "parser script for player \"$options(name,$tag)\"\
			failed: $errorInfo"
	}
}

#### Foobar2000:

proc now_playing::foobar_yield fname {
	variable connections

	debugmsg tune [info level 0]

	foobar_parse [read_utf8 $fname] info

	switch -- $info(status) {
		STOPPED {
			foreach connid $connections {
				::plugins::tune::unpublish $connid
			}
		}
		PLAYING {
			unset info(status)
			set args [list]
			foreach {key val} [array get info] {
				if {$val == ""} continue
				lappend args -$key $val
			}
			foreach connid $connections {
				eval [list ::plugins::tune::publish $connid] $args
			}
		}
	}
}

proc now_playing::foobar_parse {data vinfo} {
	upvar 1 $vinfo info

	array set info {
		status ""
		artist ""
		title  ""
		track  ""
		length ""
		source ""
		uri    ""
	}

	set lines [list]
	foreach line [split $data \n] {
		lappend lines [string trim $line]
	}

	set status [string toupper [lindex $lines 0]]
	switch -- $status {
		STOPPED {
			return
		}
		PLAYING {
			# processed below
		}
		default {
			return -code error "Bad playing status \"$status\":\
				must be one of PLAYING or STOPPED"
		}
	}

	foreach line [lrange $lines 1 end] {
		if {[regexp -nocase \
				{^(artist|title|track|length|source|uri)\s+(.*)$} \
				$line -> tag value]} {
			set tag [string tolower $tag]
			set info($tag) $value
		} else {
			warn junk "skipped junk line \"$line\""
		}
	}

	if {![string equal $info(length) ""]} {
		set length [string trimleft $info(length) 0]
		if {![string is integer $length] || $length < 0} {
			warn format "bad length \"$length\":\
				must be non-negative short integer"
			set length ""
		}
	}
}

#### Quod Libet:

proc now_playing::quodlibet_yield fname {
	variable connections

	quodlibet_parse [read_utf8 $fname] info

	switch -- $info(status) {
		paused -
		inactive {
			foreach connid $connections {
				::plugins::tune::unpublish $connid
			}
		}
		playing {
			unset info(status)
			set args [list]
			foreach {key val} [array get info] {
				if {$val == ""} continue
				lappend args -$key $val
			}
			foreach connid $connections {
				eval [list ::plugins::tune::publish $connid] $args
			}
		}
		default {
			warn format "unknown or missing playing status, ignored"
		}
	}
}

proc now_playing::quodlibet_parse {data vinfo} {
	upvar 1 $vinfo info

	array set info {
		status ""
		artist ""
		title  ""
		track  ""
		length ""
		source ""
		uri    ""
	}

	foreach line [split $data \n] {
		set line [string trim $line]
		if {[string length $line] == 0} continue
		set ix [string first = $line]
		set key [string range $line 0 [expr {$ix - 1}]]
		set val [string range $line [expr {$ix + 1}] end]
		switch -- $key {
			status      { set info(status) $val }
			album       { set info(source) $val }
			artist      { set info(artist) $val }
			~#length    { set info(length) $val }
			title       { set info(title)  $val }
			tracknumber { set info(track)  $val }
			default     {
				warn format "unknown key: \"$key\", ignored"
			}
		}
	}
}

#### Method: send

proc now_playing::method_start_send {} {
	debugmsg tune [info level 0]
	interp alias {} [mycmd now_playing] {} [mycmd process_sent]
}

proc now_playing::method_stop_send {} {
	debugmsg tune [info level 0]
	interp alias {} [mycmd now_playing] {} [mycmd no_op]
}

proc now_playing::no_op args {
	debugmsg tune [info level 0]
}

proc now_playing::process_sent args {
	variable options
	variable lasttime

	set now [clock seconds]
	if {$now - $lasttime < $options(update_threshold)} return
	set lasttime $now

	eval process $args
}

# TODO finally make it the endpoint for all methods of processing,
# argument checking and PEP stuff should be done here only.
proc now_playing::process args {
	variable connections

	debugmsg tune [info level 0]

	# TODO check options for sanity

	set state ""
	set opts [list]
	foreach {opt val} $args {
		if {[string equal $opt -state]} {
			set state $val
		} else {
			if {$val != ""} {
				lappend opts $opt $val
			}
		}
	}

	switch -- $state {
		inactive {
			foreach connid $connections {
				::plugins::tune::unpublish $connid
			}
		}
		active {
			foreach connid $connections {
				eval [list ::plugins::tune::publish $connid] $opts
			}
		}
		default {
			return -code error "Bad playing status: \"$state\":\
				must be active or inactive"
		}
	}
}

#### Method: registry

proc now_playing::method_start_registry {} {
	debugmsg tune [info level 0]
}

proc now_playing::method_stop_registry {} {
	debugmsg tune [info level 0]
}

#### Method: sockpull

proc now_playing::method_start_sockpull {} {
	debugmsg tune [info level 0]
	player init
}

proc now_playing::method_stop_sockpull {} {
	debugmsg tune [info level 0]
	poll cancel
	player cleanup
}

proc now_playing::sock_connect {host port {timeout ""}} {
	set sock [socket -async $host $port]
	variable $sock
	upvar 0 $sock state

	if {$timeout != ""} {
		set state(on_timeout) [after [expr {$timeout * 1000}] \
			[mycmd OnSockTimeout $sock]]
	}

	fileevent $sock readable [mycmd OnSockConnected $sock]

	vwait [my $sock](result)

	lassign $state(result) status msg
	unset state

	switch -- $status {
		OK {
			return $sock
		}
		ERROR {
			return -code error $msg
		}
	}
}

proc now_playing::OnSockConnected sock {
	variable $sock
	upvar 0 $sock state

	fileevent $sock readable {}
	if {[info exists state(on_timeout)]} {
		after cancel $state(on_timeout)
	}

	set err [fconfigure $sock -error]
	if {$err == ""} {
		set state(result) [list OK ""]
	} else {
		set state(result) [list ERROR $err]
	}
}

proc now_playing::OnSockTimeout sock {
	variable $sock
	upvar 0 $sock state

	set state(result) [list ERROR "Connection timed out"]
}

#### MPD:

proc now_playing::mpd_init {} {
	variable mpd
	upvar 0 mpd(sock) sock

	# TODO make host and port tunable:
	set sock [sock_connect localhost 6600 5]
	gets $sock ;# read hello string from mpd

	# TODO provide for login, if needed...

	fconfigure $sock -buffering line -translation lf -encoding utf-8

	poll using [mycmd mpd_yield $sock]
}

proc now_playing::mpd_cleanup {} {
	variable mpd

	if {[array exists mpd]} {
		close $mpd(sock)
		unset mpd
	}
}

proc now_playing::mpd_yield sock {
	variable mpd
	variable options
	variable lasttime
	variable connections

	debugmsg tune [info level 0]

	puts $sock status

	set state    unknown
	set playlist -1
	set songid   -1

	while 1 {
		if {[gets $sock line] < 0} {
			# EOF => mpd closed
			# TODO ideally, we should schedule connection retries here
			# instead of just giving up
			monitoring off
			return
		}
		switch -glob -- $line {
			OK      break
			state:* {
				set state    [mpd_getval $line state]
			}
			playlist:* {
				set playlist [mpd_getval $line playlist]
			}
			songid:* {
				set songid   [mpd_getval $line songid]
			}
		}
	}

	switch -- $state {
		stop  -
		pause {
			foreach connid $connections {
				::plugins::tune::unpublish $connid
			}
		}
		play {
			set unseen no
			if {![info exists mpd(playlist)]} {
				set mpd(playlist) $playlist
				set unseen yes
			}
			if {![info exists mpd(songid)]} {
				set mpd(songid) $songid
				set unseen yes
			}

			if {!$unseen
			&& $mpd(playlist) == $playlist
			&& $mpd(songid) == $songid} return

			set mpd(playlist) $playlist
			set mpd(songid)   $songid
		}
		default {
			warn parsing "unknown player state \"$state\", ignored"
			return
		}
	}

	set now [clock seconds]
	if {$now - $lasttime < $options(update_threshold)} return

	puts $sock currentsong

	set opts [list]

	while 1 {
		if {[gets $sock line] < 0} {
			# EOF => mpd closed
			# TODO ideally, we should schedule connection retries here
			# instead of just giving up
			monitoring off
			return
		}
		switch -glob -- $line {
			OK      break
			Artist:* {
				lappend opts -artist [mpd_getval $line Artist]
			}
			Title:* {
				lappend opts -title  [mpd_getval $line Title]
			}
			Track:* {
				lappend opts -track  [mpd_getval $line Track]
			}
			Time:* {
				lappend opts -length [mpd_getval $line Time]
			}
			Album:* {
				lappend opts -source [mpd_getval $line Album]
			}
		}
	}

	set lasttime $now

	foreach connid $connections {
		eval [list ::plugins::tune::publish $connid] $opts
	}
}

proc now_playing::mpd_getval {s key} {
	string trim [string range $s [string length $key:] end]
}

#### Final startup

now_playing::enumerate_media_players

