#!/bin/sh
# -*-tcl-*- \
# the next line restarts using wish \
exec wish8.4 "$0" "$@"

# tktz - timezone viewer.
#
# Copyright (c) 2006 Alexander Gromnizki <iwerdon@gmail.com>
# All Rights Reserved.
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is fur-
# nished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FIT-
# NESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
# THE SOFTWARE.
#
# $Id: tktz,v 1.5 2006/05/29 14:32:31 alex Exp $

set pref(prog.name) tktz
set pref(prog.ver) 0.2
set pref(prog.ename) [file tail $argv0]
set pref(prog.cvs) {$Id: tktz,v 1.5 2006/05/29 14:32:31 alex Exp $}

set pref(time.cur) [clock format [clock seconds]]
set pref(time.tz) nil
set pref(time.tzdiff) nil
set pref(time.diff) 0

# default values for:
# 1. path to the file with timezone's descriptions
set pref(tz.file) /usr/share/zoneinfo/zone.tab
# 2. user filter
set pref(tz.filter) {}
# 3. contents of listbox widget
set pref(tz.list) {}
# 4. current timezone
set pref(tz.current) {}
# 5. default timezone
set pref(tz.default) {}
# 6. all data from timezone file
set timezone_data {}

# next variables are here for clarify only, don't try
# to modify them because such activity is nonsense at this point
set pref(help.src) will_be_set_later;	# Help file
set pref(sel.primary) {};				# X selection atom PRIMARY buffer
set pref(list.item.xsel) -1;			# Current item == PRIMARY selection
set pref(list.selbg.def) yellow;		# Default color for listbox
										# selectbackground option
set pref(list.selbg.xsel) orange;		# Default color for listbox
										# selectbackground option for
										# item that == PRIMARY selection

# --[ useful Tk addons ]------------------------------------------------

# return a list of all windows in a widget hierarchy
proc wlist {{w .}} {
	set list [list $w]
	foreach i [winfo children $w] {
		set list [concat $list [wlist $i]]
	}
	return $list
}

# Helps user to override startup value stored in -textvariable or
# -variable attribute
proc xrdb_get_values {} {
	global pref

	# make `widget_lvar' array
	foreach w [wlist] {
		foreach i {variable textvariable} {
			if {![catch {$w cget -$i} lval]} {
				if {$lval != ""} { set widget_lvar($w) $lval }
			}
		}
	}

	# for standard widgets set specific X resource name
	foreach i [array names widget_lvar] {
		switch [winfo class $i] {
			Button { set widget_xrdb($i) text }
			Checkbutton { set widget_xrdb($i) is_checked }
			Label { set widget_xrdb($i) text }
			Spinbox { set widget_xrdb($i) spin }
			Entry { set widget_xrdb($i) text }
		}
	}

	foreach i [array names widget_xrdb] {
		set value [option get $i $widget_xrdb($i) ""]
		if {$value != ""} {
			set $widget_lvar($i) $value
#			puts "$widget_lvar($i) has been set"
		}
	}
}

# xrdb_path - full widget path
# opt - option
# def - default value if opt == ""
proc xrdb_get_option { xrdb_path opt def } {
	set value [option get $xrdb_path $opt ""]
	if {$value != ""} {
		return $value
	} else {
		return $def
	}
}

proc err { str {ecode 1}} {
	global pref
	tk_messageBox -type ok -icon error \
		-title "$pref(prog.name) error" \
		-message $str
	if {$ecode} { exit $ecode }
}

# <b> - bold
# <i> - green
# <h3> - (current size) + bold + brown
# <h2> - (size=+2) + bold + brown
# <h1> - (size=+4) + bold + brown
# highlights URL & e-mail automatically
proc highlight_text { path } {
	array set arec {
		url {(https?|ftp|gopher)://([A-Za-z\d_.=\+?~&%/-]+?)(?::([0-9]+))?([A-Za-z\d_.=\+?~&%/-]+?)}
		email {[A-Za-z\d_.-]+@[A-Za-z\d_.-].[A-Za-z\d_.-]+}
		bold {<b>.*?</b>}
		italic {<i>.*?</i>}
 		h1 {<h1>.*?</h1>}
 		h2 {<h2>.*?</h2>}
 		h3 {<h3>.*?</h3>}
	}
	array set markup {
		url {0 0}
		email {0 0}
		bold {3 4}
		italic {3 4}
		h1 {4 5}
		h2 {4 5}
		h3 {4 5}
	}

	# make tags; every tag has name equal `arec' index + "_tag" suffix
	$path tag configure url_tag -foreground blue -underline 1
	$path tag configure email_tag -foreground #9a32cd
	$path tag configure bold_tag \
		-font "[font actual [$path cget -font]] -weight bold"
	$path tag configure italic_tag -foreground #008b00 
	$path tag configure h1_tag -foreground #990000 \
		-font "[font actual [$path cget -font]] -weight bold \
-size [expr [font actual [$path cget -font] -size]+4]"
	$path tag configure h2_tag -foreground #990000 \
		-font "[font actual [$path cget -font]] -weight bold \
-size [expr [font actual [$path cget -font] -size]+2]"
	$path tag configure h3_tag -foreground #990000 \
		-font "[font actual [$path cget -font]] -weight bold"

	foreach i [array names arec] {
		set start 1.0
		while {[set first [$path search -regexp -count num -- $arec($i) $start end]] != ""} {
			set last [$path index "$first + $num chars"]
			$path tag add ${i}_tag $first $last

			# delete markup
			set md_1 [lindex $markup($i) 0]
			set md_2 [lindex $markup($i) 1]
			if {$md_1 && $md_2} {
				$path delete $first "$first + $md_1 chars" \
					"$last - $md_2 chars" $last
				set start "$last - $md_2 chars"
			} else { set start $last }
		}
	}
}


# --[ app routines ]-----------------------------------------------------

proc find_prog_dir {} {
	global pref
	
	if {![catch { file link [info script] } out]} {
		return [file dirname $out]
	} else {
		return [file dirname [info script]]
	}
}

# return a list with from timezone data file
# fp - result from open(n)
proc data_get_list { fd } {
	global env
	
	if {$fd == ""} { err "Missing file descriptor" 65 }
	while {[gets $fd line] >= 0} {
		if {[regexp -- {^\s*$} $line]} { continue }
		if {[regexp -- {^\s*\#.*$} $line]} { continue }

		set env(TZ) [lindex $line 2]
		lappend r [format "%2s %-35s %-12s %s" [lindex $line 0] \
					   [lindex $line 2] \
					   [clock format [clock seconds] -format "%z %Z"] \
					   [lrange $line 3 end]]
		unset env(TZ)
	}
	seek $fd 0
	if {![info exists r]} {
		err "Broken timezone file" 65
	} else { return $r }
}

# return new list with matched data only
# data - result from data_get_list()
proc data_search { data filter } {
	if {$filter == ""} {
		# update window title
		regexp -- {^[^:]*} [wm title .dlg_main] title
		wm title .dlg_main $title
		wm iconname .dlg_main $title
		return $data
	}
	
	foreach i $data {
		if {![regexp -nocase -- $filter $i]} continue
		lappend r $i
	}
	if {![info exists r]} {
		err "Your search didn't match any time zones" 0
		return ""
	}

	# update window title
	regexp -- {^[^:]*} [wm title .dlg_main] title
	wm title .dlg_main "$title: $filter"
	wm iconname .dlg_main "$title: $filter"
	
	return $r
}

proc time_set { Var } {
	upvar $Var var
	global pref env
	
	if {$pref(tz.current) != ""} { set env(TZ) $pref(tz.current) }
	set var [clock format [clock seconds] -format "%a %b %d %H:%M:%S %z %Z %Y"]
	catch { unset env(TZ) }
	after 1000 [list time_set $Var]
}

proc time_tz_set { w Var } {
	global pref env
	upvar $Var var
	
	if {[set pos [$w curselection]] == ""} {
		# the list has been rearranged
		$w activate 0
		$w see 0
		$w selection clear 0 end
		$w selection set 0
		event generate $w <<ListboxSelect>>
		set pos 0
	}
	set row [$w get $pos]
	set tz [lindex [eval concat $row] 1]
	
	if {$pref(tz.current) != ""} { set env(TZ) $pref(tz.current) }
	set local [clock format [clock seconds] -format {%m/%d/%Y %T}]
	set env(TZ) $tz
	set remote [clock format [clock seconds] -format {%m/%d/%Y %T}]
	if {$tz != $pref(time.tz) } {
		# update blue timezone label
		set pref(time.tz) $tz
	}
	set var [clock format [clock seconds] -format "%a %b %d %H:%M:%S %z %Z %Y"]
	# set difference
	set minute [expr { (([clock scan $remote] - [clock scan $local]) / 60) % 60 }]
	set hour [expr { (([clock scan $remote] - [clock scan $local]) / 60) / 60 }]
	if {$pref(time.diff) != "$hour:$minute"} {
		set pref(time.diff) $hour:$minute
	}
	unset env(TZ)
	after 1000 [list time_tz_set $w $Var]
}

proc dlg_main {} {
	global pref tcl_patchLevel tk_patchLevel

	set p [toplevel .dlg_main -class [string toupper [string index $pref(prog.name) 0]][string range $pref(prog.name) 1 end]]
	
	wm title $p "$pref(prog.name) $pref(prog.ver)"
	wm protocol $p WM_DELETE_WINDOW exit

	#
	# Time
	#
	labelframe $p.time -text Time
	pack $p.time -fill x -padx 5

	# current
	label $p.l_time1 -text Current: -anchor w -width 20
	label $p.l_time_val -textvariable pref(time.cur)
	# first row
	grid $p.l_time1 $p.l_time_val -sticky w -padx 5 -in $p.time

	# in specific timezone
	frame $p.difftime -width 20
	label $p.l_difftime1 -text In
	label $p.l_difftime_tzname -textvariable pref(time.tz)
	label $p.l_difftime3 -text timezone:
	label $p.l_difftime_val -textvariable pref(time.tzdiff)
	# second row
	pack $p.l_difftime1 $p.l_difftime_tzname $p.l_difftime3 -side left -in $p.difftime
	grid $p.difftime $p.l_difftime_val -sticky w -padx 5 -in $p.time

	# difference label
	label $p.l_diff1 -text "Difference (HH:MM):" -anchor w
	label $p.l_diff_val -textvariable pref(time.diff)
	# third row
	grid $p.l_diff1 $p.l_diff_val -sticky w -padx 5 -in $p.time
	grid columnconfigure $p.time 1 -weight 1

	#
	# Timezone
	#
	labelframe $p.tz -text Timezone
	pack $p.tz -fill both -expand 1 -padx 5

	frame $p.tz.ff
	pack $p.tz.ff -fill x

	# file
	label $p.l_file1 -text "Source file:"
	label $p.l_file_val -textvariable pref(tz.file)
	
	grid $p.l_file1 $p.l_file_val -in $p.tz.ff
	grid $p.l_file1 -sticky w -padx {5 0} -in $p.tz.ff
	grid $p.l_file_val -sticky w -padx 5 -in $p.tz.ff

	# filter
	label $p.l_filter1 -text "Text filter (ARE):"
	entry $p.e_filter_val -textvariable pref(tz.filter) -width 15
	
	grid $p.l_filter1 $p.e_filter_val -in $p.tz.ff
	grid $p.l_filter1 -sticky w -padx {5 0} -in $p.tz.ff
	grid $p.e_filter_val -sticky ew -padx 5 -in $p.tz.ff
	grid columnconfigure $p.tz.ff 1 -weight 1

	# list
	frame $p.tz.data -borderwidth 5
	pack $p.tz.data -fill both -expand 1

	scrollbar $p.sc_listy -command "$p.list yview" -takefocus 0
	scrollbar $p.sc_listx -orient horizontal -command "$p.list xview" -takefocus 0
	listbox $p.list -setgrid 1 -height 8 -listvariable pref(tz.list) \
		-yscroll "$p.sc_listy set" -xscroll "$p.sc_listx set" \
		-exportselection 0
	
	pack $p.sc_listx -fill x -side bottom -in $p.tz.data
	pack $p.sc_listy -fill y -in $p.tz.data \
		-side [xrdb_get_option $p.sc_listy position left]
	pack $p.list -side left -expand 1 -fill both -in $p.tz.data

	#
	# Buttons
	#
	button $p.btn_help -text Help -command { dlg_help	}
	button $p.btn_quit -text Quit -command { exit }

	pack $p.btn_help -side left -pady 5 -padx {5 1}
	pack $p.btn_quit -side left -pady 5

	# Label for tcl/tk version
	if {$tcl_patchLevel == $tk_patchLevel} {
		set ver "Tcl/Tk $tk_patchLevel"
	} else { set ver "Tcl $tcl_patchLevel/Tk $tk_patchLevel" }
	label $p.l_tcltk -text $ver -relief ridge
	pack $p.l_tcltk -side right -padx 5

	# focus on the filter entry
	focus $p.e_filter_val
}

proc help_eval { filename } {
	global pref
	
	if [catch {open $filename} fd] { err $fd 0 }	
	while {[gets $fd line] >= 0} {
		if {[regexp -- {^\s*\#.*$} $line]} { continue }

		append r "[subst $line]\n"
	}
	close $fd
	if {![info exists r]} {
		err "Broken help file ``$filename''" 0
	} else { return $r }
}

proc dlg_help {} {
	global pref tcl_platform

	set p .dlg_help
	if {[winfo exists $p]} {
		destroy $p
		return
    }

	toplevel $p -class [string toupper [string index $pref(prog.name) 0]][string range $pref(prog.name) 1 end]Help
	wm title $p "$pref(prog.name) $pref(prog.ver) help"
	wm iconname $p "$pref(prog.name) $pref(prog.ver) help"

	text $p.t_help -yscrollcommand "$p.sc_helpy set" -xscrollcommand "$p.sc_helpx set" -padx 5
	scrollbar $p.sc_helpy -command "$p.t_help yview"
	scrollbar $p.sc_helpx -orient horizontal -command "$p.t_help xview"
	pack $p.sc_helpx -side bottom  -fill x
	pack $p.sc_helpy -side [xrdb_get_option $p.sc_helpy position left] -fill y
	pack $p.t_help -side left -fill both -expand 1

	$p.t_help tag configure spacing -spacing3 2p -spacing2 2p -wrap none
	$p.t_help insert end [help_eval $pref(help.src)] spacing
	highlight_text $p.t_help
	$p.t_help mark set insert 1.0
	$p.t_help configure -state disabled
	
	if {$tcl_platform(platform) == "windows"} {
		bind $p <Escape> { destroy [winfo toplevel %W] }
	}
	bind $p q { destroy [winfo toplevel %W] }

	# make popup menu
	menu $p.menu_popup
	$p.menu_popup add command -label "Close window" -command "destroy $p"
	$p.menu_popup add separator
	$p.menu_popup add command -label "File revision" -command {
		tk_messageBox -type ok -icon info -title "$pref(prog.name) file revision" \
			-message $pref(prog.cvs)
	}
	bind $p.t_help <3> "tk_popup $p.menu_popup %X %Y"

	focus $p.sc_helpy
}

# is_single - non empty if modifier was pressed
proc bind_general { is_single key } {
#	puts "$is_single - $key"
	#
	# listbox
	#
	set listbox .dlg_main.list
	set filter .dlg_main.e_filter_val
	if {[focus] != $listbox} {
		switch -- $key {
			Up { tk::ListboxUpDown $listbox -1 }
			Down { tk::ListboxUpDown $listbox 1 }
			Prior {
				$listbox yview scroll -1 pages
				$listbox activate @0,0
				tk::ListboxUpDown $listbox 0
			}
			Next {
				$listbox yview scroll 1 pages
				$listbox activate @0,0
				tk::ListboxUpDown $listbox 0
			}
			Home {
				if {$is_single == ""} {
					# with modifier
					$listbox activate 0
					$listbox see 0
					$listbox selection clear 0 end
					$listbox selection set 0
					event generate $listbox <<ListboxSelect>>
					return
				}
			}
			End {
				if {$is_single == ""} {
					# with modifier
					$listbox activate end
					$listbox see end
					$listbox selection clear 0 end
					$listbox selection set end
					event generate $listbox <<ListboxSelect>>
					return
				}
			}
		}

		if {[focus] != $filter} {
			switch -- $key {
				Left {
					if {$is_single == ""} {
						# with modifier
						$listbox xview scroll -1 pages
					} else { $listbox xview scroll -1 units }
				}
				Right {
					if {$is_single == ""} {
						# with modifier
						$listbox xview scroll 1 pages
					} else { $listbox xview scroll 1 units }
				}
				Home {
					$listbox xview moveto 0
				}
				End {
					$listbox xview moveto 1
				}
			}
		}
	}
}

proc bind_special {} {
	global pref

	bind Entry <Control-Home> {# nothing}
	bind Entry <Control-End> {# nothing}

	# start filter
	bind .dlg_main.e_filter_val <Return> {
		# fill list with new values
		if {[set data_filtered [data_search $timezone_data $pref(tz.filter)]] != ""} {
			set pref(tz.list) $data_filtered
			selection clear .dlg_main.list
		}
	}

	# set selected timezone as current
	bind .dlg_main.list <Double-Button-1> { timezone_set %W false }
	bind .dlg_main <Meta-s> { timezone_set .dlg_main.list false }
	# set current timezone to the default
	bind .dlg_main.l_time_val <Double-Button-1> { timezone_set %W true }
	bind .dlg_main <F2> { timezone_set .dlg_main.l_time_val true }

	bind .dlg_main <Control-s> { focus .dlg_main.e_filter_val }
	bind .dlg_main <F1> { dlg_help }

	# button 3 owns a selection
	bind .dlg_main.list <3> {
		if {[winfo exists %W]} {
			tk::ListboxBeginSelect %W [%W index @%x,%y]
			%W activate @%x,%y
			if {[%W curselection] == ""} { return }
			set pref(sel.str) [%W get [%W curselection]]
			regsub -- {\s*$} $pref(sel.str) {} pref(sel.primary)
#			puts '$pref(sel.str)'

			# selection will be cleared on app exit
			selection handle .dlg_main.list selection_getdata
			selection own -command selection_lost .dlg_main.list
			if {[selection own] == ".dlg_main.list" } {
				selection_lost;			# clear possible previous selection
				set pref(list.item.xsel) [%W curselection]
				.dlg_main.list itemconfigure $pref(list.item.xsel) \
					-selectbackground $pref(list.selbg.xsel)
			}
		}
	}
}

proc selection_getdata {offset maxchars} {
	global pref
	return [string range $pref(sel.primary) $offset [expr {$offset+$maxchars}]]
}

proc selection_lost {} {
	global pref
	# we protect code from raising error because item may be
	# non-existent after new user search
	catch {
		.dlg_main.list itemconfigure $pref(list.item.xsel) \
			-selectbackground $pref(list.selbg.def)
	}
}

proc timezone_set { w reset } {
	global pref
	
	if {!$reset} {
		if {[$w curselection] == ""} { return }
		set answer [tk_messageBox -message "Set [lindex [$w get [$w curselection]] 1] timezone as current?" \
						-type yesno -icon question \
						-title "$pref(prog.name) question"]
		if {$answer == yes } {
			set pref(tz.current) [lindex [$w get [$w curselection]] 1]
			unset answer
		}
	} else {
		set answer [tk_messageBox \
						-message "Reset current timezone to the default $pref(tz.default)?" \
						-type yesno -icon question \
						-title "$pref(prog.name) question"]
		if {$answer == yes } {
			set pref(tz.current) $pref(tz.default)
			unset answer
		}
	}
}

proc parse_command_line {} {
	global argv pref
	
	foreach {opt arg} $argv {
		switch -regexp -- $opt {
			^-xrm$ {
				foreach {key val} [split $arg :] { break }
				if {![info exists key]} {
					err "Options requires an argument -- xrm" 0
					break
				}
				# remove possible garbage
				regsub -- {^\s*(\S+)\s*$} $key {\1} key
				regsub -- {^\s*(\S+)\s*$} $val {\1} val
				# add new options
				option add $key $val
			}
			^-+h(elp)?$ {
				puts "$pref(prog.name): no help is provided at this point :P"
				exit
			}
		}
	}
}

# --[ main ]-------------------------------------------------------------

wm withdraw .

if {$tcl_platform(platform) == "windows"} {
	catch {option readfile [file join $env(HOME) .Xdefaults] userDefault}
}

#
# Simple resources
# (which users can override in .Xdefaults)
# 
# label with selected name of timezone
option add *l_difftime_tzname.foreground blue startupFile
# label for tcl version
option add *l_tcltk.foreground "#8b1a1a" startupFile

option add *btn_quit.activeBackground "#ff7f24" startupFile
option add *Text.background "#e5e5e5" startupFile
switch -- $tcl_platform(platform) {
	unix {
		option add *Dialog.msg.wrapLength 6i startupFile
		option add *font {Helvetica 10} startupFile
		option add *list.font {lucidatypewriter 10} startupFile
		option add *Text.font {lucidatypewriter 10} startupFile
		option add *Entry.font {lucidatypewriter 10} startupFile
		
		option add *Entry.background "#e5e5e5" startupFile
		option add *Listbox.background "#e5e5e5" startupFile
		option add *Listbox.selectBackground yellow startupFile
	}
	windows {
		option add *font {Serif 8} startupFile
		option add *list.font {Courier 9} startupFile
		option add *Text.font {Courier 9} startupFile
		option add *Button.width 8 startupFile
	}
}

# options -xrm '*foo: bar' from command line override all resources
parse_command_line

# set current timezone
if {[info exists env(TZ)] && $env(TZ) != ""} {
	set pref(tz.current) $env(TZ)
	set pref(tz.default) $env(TZ)
}

#
# Draw dialog
#
dlg_main

# 1. read some user config
xrdb_get_values
# set variables for holding necessary listbox widget values
set pref(list.selbg.def) \
	[xrdb_get_option .dlg_main.list selectBackground \
		 [.dlg_main.list cget -selectbackground]]
# virtual option
set pref(list.selbg.xsel) [xrdb_get_option .dlg_main.list xprimary_selbg "#ffa500"]

# 2. read file with timezone data (this depends on step 1)
if {![catch {open $pref(tz.file)} fd]} {
	set timezone_data [data_get_list $fd]
	if {[set data_filtered [data_search $timezone_data $pref(tz.filter)]] != ""} {
		set pref(tz.list) $data_filtered
	} else {
		set pref(tz.list) $timezone_data
	}
} else { err $fd 66 }

#
# Final setup
#

# set help file 
set pref(help.src) [find_prog_dir]/$pref(prog.name).help

bind .dlg_main <KeyPress> { bind_general %s %K }
bind .dlg_main <Control-KeyPress> { bind_general %A %K }
bind_special

# start ticking current time
time_set pref(time.cur)
# start ticking time in selected timezone
time_tz_set .dlg_main.list pref(time.tzdiff)
