# $Id: customstatus.tcl 246 2009-12-10 00:47:49Z Totktonada $
# "Custom presence statuses" plugin for Tkabber.
# Written by Konstantin Khomoutov <flatworm@users.sourceforge.net>
# See licence.terms for the terms of distribution.
# See README for details.

namespace eval customstatus {
	# TODO change to "no" when releasing:
	package require control
	::control::control assert enabled yes
	namespace import ::control::assert

	# Load message catalog:
	package require msgcat
	::msgcat::mcload [file join [file dir [info script]] msgs]

	image create photo customstatus/chat-write -file [file join [file dirname [info script]] pixmaps chat-write.gif]
	# Some hacky options:
	variable options
	array set options {
		subvert_main_presets_menu   no
		subvert_quick_presets_menu  no
		add_toolbar_item            yes
		toolbar_item_image          customstatus/chat-write
		accelerate_menus            no
		extend_quick_presets_panel  yes
		quick_presets_panel_image   customstatus/chat-write
	}

	variable presets

	custom::defgroup CustomStatusPresets \
		"Custom status presets" \
		-group Hidden

	custom::defvar presets {} \
		"Custom status presets" \
		-group CustomStatusPresets \
		-type list

	hook::add finload_hook [namespace current]::install

	proc mycommand args {
		lreplace $args 0 0 [my [lindex $args 0]]
	}

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

proc customstatus::install {} {
	global user_status_list
	variable options
	variable presets
	variable s2d

	array set s2d $user_status_list

	set m [recreate_menu]

	if {$options(add_toolbar_item)} {
		set n [ifacetk::add_toolbar_button \
			$options(toolbar_item_image) \
			[mycommand post_menu $m] \
			[::msgcat::mc "Presence presets"]]

		set bbox [.mainframe gettoolbar 0].bbox
		$bbox itemconfigure $n -state disabled
		proc [namespace current]::toolbar_button_state \
			{bbox idx state connid} {
				$bbox itemconfigure $idx -state $state
		}
		hook::add connected_hook [mycommand \
			toolbar_button_state $bbox $n normal]
		hook::add disconnected_hook [mycommand \
			toolbar_button_state $bbox $n disabled]
	}

	set pm [.mainframe getmenu plugins]
	$pm add command -label [::msgcat::mc "Edit presence presets"] \
		-command [mycommand edit_presence_presets]

	# HACK! Inserting a new menu item to the menu hierarchy
	# created by [descmenu] of a MainFrame breaks any keybindings
	# on the menu items that happen to be lower than the newly
	# inserted one since that bindings are made to numerical
	# indices of menu entries.
	# So if any keybindings will be added below Ctrl-J, this
	# code will break them:
	if {$options(subvert_main_presets_menu)} {
		set pm   [.mainframe getmenu presence]
		set prio [::msgcat::mc "Change priority..."]
		set cmd  [$pm entrycget $prio -command]

		set tm [.mainframe getmenu tkabber]
		set lwr [::msgcat::mc "Log out with reason..."]
		set ix [expr {[$tm index $lwr] + 1}]
		$tm insert $ix command \
			-label $prio -command $cmd
		set pres [::msgcat::mc "Presence"]
		$tm entryconfigure $pres -menu $m
	}

	# HACK! see [rebuild_menu]
	if {$options(subvert_quick_presets_menu)} {
		.presence.button configure -menu $m
	}

	if {$options(extend_quick_presets_panel)} {
		set b [button .presence.custom \
			-image $options(quick_presets_panel_image) \
			-command [mycommand post_menu $m] \
			-state disabled]
		pack $b -side left -after .presence.button -anchor w -fill y
		proc [namespace current]::quick_button_state {b state connid} {
				$b configure -state $state
		}
		hook::add connected_hook [mycommand quick_button_state $b normal]
		hook::add disconnected_hook [mycommand quick_button_state $b disabled]
	}
}

proc customstatus::recreate_menu {} {
	variable presets
	variable s2d

	# HACK! This name is chosen to allow subvertion of the
	# standard "quick presence menu": since .presence.button
	# is a menubutton widget its menu must be its descendant,
	# so we do it:
	set m .presence.button.custom_menu
	if {[winfo exists $m]} {
		destroy $m
	}
	menu $m

	set accel 0
	foreach {status msg} $presets {
		next_accel accel label aidx
		append label "$s2d($status): "
		if {[string len $msg] > 25} {
			append label [string range $msg 0 22] ...
		} else {
			append label $msg
		}
		$m add command -label $label -underline $aidx \
			-command [mycommand use $status $msg]
	}

	$m add separator
	$m add command -label [::msgcat::mc "Edit presence presets"] \
		-command [mycommand edit_presence_presets]

	set m
}

proc customstatus::next_accel {vaccel vprefix vindex} {
	upvar 1 $vaccel accel $vprefix prefix $vindex index
	variable options

	if {$options(accelerate_menus) && $accel < 9} {
		set prefix "[incr accel]. "
		set index 0
	} else {
		set prefix ""
		set index -1
	}
}

proc customstatus::post_menu menu {
	tk_popup $menu [winfo pointerx .] [winfo pointery .]
}

proc customstatus::use {status message} {
	global textstatus userstatus

	set textstatus $message
	set userstatus $status
}

proc customstatus::edit_presence_presets {} {
	global user_status_list
	variable presets
	variable editor
	variable items
	variable descs
	variable d2s
	variable s2d

	set w .presence_status_presets
	if {[winfo exists $w]} {
		focus $w
		return
	}

	Dialog $w -title [::msgcat::mc "Presence presets editor"] \
		-modal none -transient no \
		-separator 1 -anchor e -default 0 -cancel 1

	variable action
	$w add -text [::msgcat::mc "OK"]     -command [list set [my action] commit]
	$w add -text [::msgcat::mc "Cancel"] -command [list set [my action] discard]

	bind $w <Destroy> +[mycommand cleanup_state $w %W]

	set if [$w getframe]

	foreach {s d} $user_status_list {
		switch -- $s { invisible - unavailable continue }
		set d2s($d) $s
		set s2d($s) $d
		lappend descs $d
	}

	# Items holder:
	set sw [ScrolledWindow $if.sw -scrollbar vertical]
	set sf [ScrollableFrame $sw.items -constrainedwidth yes]
	$sw setwidget $sf
	set f [$sf getframe]

	# Footer elements:
	button $if.new -text [::msgcat::mc "Add item"] \
		-command [mycommand add_preset $f [::msgcat::mc "Available"] ""]

	# Pack them bottom up so that the items holder is packed last:
	pack $if.new -side bottom -anchor se
	pack $sw -side bottom -fill both -expand true

	# Now place existing items:

	grid columnconfigure $f 1 -weight 1

	# Column captions:
	label $f.lpres -text [::msgcat::mc "Presence"]
	label $f.lmsg  -text [::msgcat::mc "Message"]
	grid $f.lpres $f.lmsg -sticky w -padx 1m

	# Now goes the content:
	set items {}
	set editor(id) 0
	foreach {s m} $presets {
		add_preset $f $s2d($s) $m
	}

	$w draw
	vwait [my action]

	switch -- $action {
		commit { commit_changes $w }
		discard {}
	}
	unset action

	destroy $w
}

proc customstatus::add_preset {w desc msg} {
	variable presets
	variable editor
	variable descs
	variable items

	set id $editor(id)
	lappend items $id

	set editor(desc,$id) $desc
	set editor(message,$id) $msg

	set 1 [ComboBox $w.desc$id -values $descs \
		-editable false \
		-textvariable [my editor(desc,$id)]]
	set 2 [entry $w.message$id \
		-textvariable [my editor(message,$id)]]
	set 3 [button $w.up$id -text [::msgcat::mc "Up"] \
		-command [mycommand move_up $w $id]]
	set 4 [button $w.down$id -text [::msgcat::mc "Down"] \
		-command [mycommand move_down $w $id]]
	set 5 [button $w.delete$id -text [::msgcat::mc "Delete"] \
		-command [mycommand delete_preset $w $id]]

	grid $1 $2 $3 $4 $5 -sticky we -padx 1m

	bind $2 <Control-Up> [mycommand move_up $w $id]
	bind $2 <Control-Down> [mycommand move_down $w $id]

	incr editor(id)
}

proc customstatus::delete_preset {w id} {
	variable editor
	variable items

	destroy $w.desc$id $w.message$id $w.up$id $w.down$id $w.delete$id
	array unset editor *,$id

	set ix [lsearch -exact -integer $items $id]
	set items [lreplace $items $ix $ix]
}

proc customstatus::commit_changes w {
	variable presets
	variable editor
	variable items
	variable d2s

	set out {}
	foreach id $items {
		set status $d2s($editor(desc,$id))
		lappend out $status $editor(message,$id)
	}

	set presets $out

	recreate_menu
}

proc customstatus::cleanup_state {w1 w2} {
	if {![string equal $w1 $w2]} return

	variable editor
	array unset editor

	variable items
	unset items

	variable descs
	unset descs

	variable d2s
	array unset d2s

	variable s2d
	array unset s2d
}

proc customstatus::move_up {w id} {
	variable items
	variable editor

	set a [lsearch -exact -integer $items $id]
	set b [expr {$a == 0 ? [llength $items] - 1 : $a - 1}]

	exchange $w $a $b
}

proc customstatus::move_down {w id} {
	variable items
	variable editor

	set a [lsearch -exact -integer $items $id]
	set b [expr {$a == [llength $items] - 1 ? 0 : $a + 1}]

	exchange $w $a $b
}

proc customstatus::exchange {w 1 2} {
	variable editor

	foreach field {desc message} {
		set tmp $editor($field,$1)
		set editor($field,$1) $editor($field,$2)
		set editor($field,$2) $tmp
	}

	# Focus follows moved preset, if possible:
	if {[regexp ^$w.(desc|message)$1\$ [focus] -> widget]} {
		focus $w.$widget$2
	}
}

