#!/usr/bin/wish
# If we are not started from fubar
if {![info exists LIBRARYDIR]} {
	set LIBRARYDIR [file dirname [info script]]
	set CONFIGDIR ~/.fubar
}	
if {[file exists /proc/net/irda/discovery]} {
	namespace eval irda {
		#variable discovery "/proc/net/irda/discovery"
		variable discovery "/proc/net/irda/discovery"
		variable config [file join $::CONFIGDIR irda.conf]
		if {![file exists $config]} {
			# create default config
			file copy [file join $::LIBRARYDIR irda.conf] $config
		}	
		#update interval in milliseconds
		variable poll 2000
		variable configread 0;#ensure config to be read on first update
		variable canvas .irda
		variable menu $canvas.m
		variable hintBits {0x100 PnP 0x200	PDA 0x400	Computer 0x800	Printer
   0x1000	Modem 0x2000	Fax 0x4000	LAN 0x1 	Telephony 0x2 	FileServer
      0x4 	Comm 0x8 	Message 0x10 	Http 0x20 	OBEX }
	   variable stdIcons {computer 
{R0lGODlhEAAQAMIAAICAgMDAwAAAAP///wAA/////////////yH5BAEKAAcALAAAAAAQABAA
AANIeLrcDjDGF6qtQDAwuu+QtnBCaQ7hNghE26KZyroELCokXafj92WQkWlYAgREHJ/HGDuE
gAJoyig4WqtYTVLpOSqI4JJj7EgAADs=}
		pda
{R0lGODlhDgAOAMIAANPT02lpaQBkAP///////////////////yH5BAEKAAQALAAAAAAOAA4A
AAMySLrcBDDGwIC4WAC67PjYVmVhwD3ktZ2eMJRsqpmda6u0YqViJUGnhWlIZBCJPYeSkAAA
Ow==}
		modem
{R0lGODlhEAAQAKEAAAAAAKyqrL2+vf///yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQB
CgADACwAAAAAEAAQAAACLZyPCMm3zR40oE4XgoRA5510osZ5nQBSmSagzRig6TCecx3fZl6y
7mSbhYSIAgA7}
		lan
{R0lGODlhEAAQAKEAAI6KjgAAAP///////yH5BAEKAAIALAAAAAAQABAAAAInlI8pwKztmjKS
zgNQuGYff4GCqIjBiaYnN7IJycKcfGUu5biQfU8FADs=}
		printer
{R0lGODlhEAAQAOcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoKCgsLCwwMDA0N
DQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZGRoaGhsbGxwcHB0dHR4eHh8f
HyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygoKCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDEx
MTIyMjMzMzQ0NDU1NTY2Njc3Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkND
Q0REREVFRUZGRkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV
VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2RkZGVlZWZmZmdn
Z2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNzc3R0dHV1dXZ2dnd3d3h4eHl5
eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKCgoODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouL
i4yMjI2NjY6Ojo+Pj5CQkJGRkZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2d
nZ6enp+fn6CgoKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v
r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+vr+/v8DAwMHB
wcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3Nzc7Ozs/Pz9DQ0NHR0dLS0tPT
09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc3N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl
5ebm5ufn5+jo6Onp6erq6uvr6+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf3
9/j4+Pn5+fr6+vv7+/z8/P39/f7+/v///yH5BAEKAP4ALAAAAAAQABAAAAhNAP0JFAigoMGC
AxMC+Mew4T8ACQk+PLgQYsSFDhtaVDjx4MOI/jBm/Hixo0GSHEeiJEixpUWXMAuqHClTZcWH
HWc6RBiTYkqaIHsODAgAOw==}
		fax
{R0lGODlhEAAQAMIAAICAgP///wAAAMDAwP///////////////yH5BAEKAAQALAAAAAAQABAA
AANISLoMznCBQB90juog5Azf1inTMGSiFJylOXAnUc4C4ApmRgO1e9a7Xs4BpJiEGKLQOEx2
cLlVkjciCKAsZcSK024X1+p3vEgAADs=}
}

		variable iconUnknown {
R0lGODlhEAAQAIAAAAAAAP///yH5BAEKAAEALAAAAAAQABAAAAIgjA+px6bbEGAphtownZnb
/oGhNJLl5ZWamp4u+q5vUwAAOw==
}
		variable validFlags 
		# Список допустимых флагов значение 1 если должен быть параметр
		array set validFlags {
			pidfile 1
			!pidfile 1
			gui 1
			silent 0
			show 0
		}
		proc update {} {
			variable discovery
			variable configread
			variable config
			if {[file mtime $config]>$configread} {
				readconfig
			}	
			set f [open $discovery] 
			while {[gets $f line]>=0} {
				if {[string match "nickname:*" $line]} {
					found $line
					close $f
					return
				}	
			}
			close $f
			not_found
		}
		#
		# schedules next update
		#
		proc reschedule {} {
			variable poll
			after $poll ::irda::update
		}
		#
		# Обработка пустого discovery
		# Удаляет все позиции из меню и удаляет иконку 
		# 
		proc not_found {} {
			variable hint
			variable canvas
			variable menu
			$canvas delete peer
			$menu delete 1 end
			set hint "No IR device in range"
			proc show_menu {} {}
			reschedule
		}
		#
		# Обработка найденного устройства. Входной параметр -
		# строчка из discovery
		#
		proc found {line} {
			variable hint
			variable hintBits
			foreach field [split $line ","] {
				if {[regexp {([a-z]+): +(.*)} $field xx name value]} {
					set props($name) $value
				}
			}
			set propList {}
			if {![string match "$props(nickname)*" $hint]} {
				foreach {bitMask prop} $hintBits {
					if {$props(hint) & $bitMask} {
						lappend propList $prop
					}
				}	
				set hint "$props(nickname) [join  $propList ","]"
				setup_menu $propList
				setup_icon $props(nickname) $propList
			}
			reschedule
		}
		#
		# Проверяет корректность флага
		#
		proc checkFlag {name value file line} {
			variable validFlags
			if {![info exists validFlags($name)]} {
				error "Invalid flag `$name' at $file:$line"
			}	
			if {$value && !$validFlags($name)} {
				error "Flag $name shouldn't have a value at $file:$line"
			}	
			if {!$value && $validFlags($name)} {
				error "Flag $name shouldn have a value at $file:$line"
			}	
		}
		#
		# Чтение конфигурационного файла из глобальной переменной
		# config. Заполняет
		# глобальный массив confsections
		#
	    proc readconfig {} {
			variable config
			variable confsections
			variable configread
			set configread [clock seconds]
			set f [open $config]
			set sp "\[ \t\]+"
			set qstr "(\"\[^\"]+\"|\[^ \t\]+)"
			set lineno 0
			array unset confsections {}
			set confsections(devices) {}
			while {[gets $f line]>=0} {
				incr lineno
				if {![string length $line]} continue
				if {[regexp "^\[ \t\]*#" $line]} continue
				if {[regexp "^(\[A-Za-z\]\+):\[ \t\]*$" $line xx secname]} {
					set secname [string tolower $secname]
					set confsections($secname) {}
				} else {
					if {![info exists secname]} {
						error "Syntax error in $config:$lineno - menu item without sectname"
					}
					if {$secname != "devices"} {
						if {![regexp "\[ \t\]*$qstr$sp$qstr$sp\(.+)$" $line xx label flags cmd]} {
							error "Syntax eror in $config:$lineno"
						}	
						set flagList {}
						foreach flag [split [string trim $flags \"] ","] {
							if {![string length $flag]} continue
							if {[regexp {([^=]+)=(.*)} $flag xx name param]} {
								checkFlag $name 1 $config $lineno
								lappend flagList $name $param
							} else {
								checkFlag $flag 0 $config $lineno
								lappend flagList $flag ""
							}	
						}
						lappend confsections($secname) [string trim $label \"] $flagList $cmd
					} else {
						if {![regexp "\[ \t\]*$qstr$sp(.*)" $line xx pattern filename]} {
							error "Syntax error in $config:$lineno"
						}	
						lappend deviceIcons $pattern filename
					}	
				}
			}
		}	
		#
		# Показывает иконку устройства. Параметры nickname устройства
		# и список его атрибутов. 
		proc setup_icon {name props} {
			variable confsections
			variable stdIcons
			variable iconUnknown
			# Сначала ищем специфическую иконку в секции devices
			foreach {pattern icon} $confsections(devices) {
				if [string match $pattern $name] {
					foreach path [list $::CONFIGDIR $::LIBRARYDIR] {
						set fn [file join $path "icons" $name]
						if [file exists $fn] {
							peer_image -file $fn
							return	
						}		
					}
					# Если картинки не найдено, прекращаем перебор
					break
				}
			}
			set searchList [string tolower $props]
			# Если не найдено, ищем стандартную
			foreach {device image} $stdIcons {
				if {[lsearch -exact $searchList $device]!=-1} {
					peer_image -data $image
					return
				}	
			}
			# устанавливаем иконку неизвестного устройства
			peer_image -data $iconUnknown
				
		}
		#
		# Создает иконку с тэгом peer на канве.
		# 
		proc peer_image {option value} {
			variable canvas
			$canvas create image 17 8 -anchor w -tag peer \
								-image [image create photo $option $value]
		}						
		#
		# Добавляет в меню позиции соответствующие свойствам данного
		# устройства и запоминает действия, которые следует выполнить
		# по postcommand в процедуре show_menu 
		#
		proc setup_menu {props} {
			variable confsections
			variable menu
			set checkCode ""
			foreach prop [string tolower $props] {
				if [info exists confsections($prop)] {
					if {[$menu index end] > 0} {
						$menu add separator
					}	
					foreach {name flags command} $confsections($prop) {
						array unset flg
						array set flg $flags
						if {[info exists flg(pidfile)]} {
							if {[string length $flg(pidfile)]} {
								append checkCode [list check_pidfile $name $flg(pidfile) disable normal] "\n"
							} else {
								append checkCode [list check_process $name $command disable normal] "\n"
							}
						} elseif {[info exists flg(!pidfile)]} {
							if {[string length $flg(!pidfile)]} {
								append checkCode [list check_pidfile $name $flg(!pidfile) normal disable] "\n"
							} else {
								append checkCode [list check_process $name $command normal disable] "\n"
							}
						}
						if {[info exists flg(gui)]} {
							set cmd [list ::launch_gui $name $flg(gui) $command]
						} elseif {[info exist flg(show)]} {
							set cmd [list ::irda::launch_log $name $command]
						} else {
							set cmd [list ::irda::launch_bacground $name $command]
						}	
						$menu add command -label $name -command $cmd
					}
				}
			}	
			proc show_menu {} "$checkCode"
					
		}
		#
		# Процедуры используемые в postcommand
		#
		# Проверяет существование указанного файла. если он существует
		# выставляет статус угазанный в ifexists иначе - в ifnotexists
		# 
		proc check_pidfile {item file ifexists ifnotexists} {
			variable menu
			if {[file exists $file]} {
				$menu entryconfig $item -state $ifexists
			} else {
				$menu entryconfig $item -state $ifnotexists
			}	
		}
		#
		# Проверяет существование процесса с указанной командой строкой
		#
		proc check_process {item command ifexists ifnotexists} {
			set f [open "|ps auxww" "r"]
			while {[gets $f line]>=0} {
				if {[string match *$command $line]} {
					$menu entryconfig $item -state $ifexists
					close $f
					return
				}
			}
			$menu entryconfig $item -state $ifnotexists
		}	
		# Процедуры, используемые для запуска команд
		# Если существует окно указанного класса, делает ему raise
		# иначе - выполняет команду
		proc launch_gui {name class command} {
			if [catch package require Fvwm] {
				::fvwm::getWindowList a
				foreach {index value} [array get a "*,class"] {
					if {$value == "$class"} {
						set $id [lindex [split $index ","] 0]
						::fvwm::send Raise $id
						::fvwm::send Focus $id
						return
					}
				}	
			}
			launch_background $name $command
		}
		#
		# Запускает команду направляя ее вывод в окно
		#
		proc launch_log {name command} {
		 	set w [uniqueWindow .irda.log]
			wm title $w $name
			text $w.t -yscrollcomand "$w.s set" -width 80 -state disabled
			scrollbar $w.s -command "$w.t yview" -orient vert
			pack $w.t -side left -fill both -expand y
			pack $w.s -side right -fill y -expand n
			set f [open "|$command" r]
			fconfigure $f -blocking no -buffering no
			fileevent $f readable [list ::irda::logInput $f $w.t]
		}

		proc logInput {file window} {
			if {[eof $f]} {
				if [catch {close $f} msg] {
					set string "\n********** TERMINATED *******\n$msg"
				} else {	
					set string "\n*********** FINISHED ***************\n"
				}
			} else {
				set string [read $f]
			}
			$w configure -state normal
			$w insert end $string
			$w see end
			$w configure -state disabled
		}	
			
		#
		# Запускает команду в фоне
		#
		proc launch_background {name command} {
			set exec [expandFilename $name $command]
			eval exec $command &
		}

		
		# Подставляет имя файла. Возвращает -code return
		# если пользователь отказался от выбора
		#
		proc expandFilename {name command} {
			if {![regexp -indices {%filename%} $command match]} {
				#nothig to substitute
				return $command
			}	
			if {![string length [set filename [tk_openFile -title $name]][} {
				#operation cancelled
				return -code return
			}
			return [eval string replace [list $command] $match [list $filename]]
		}
		
		#setting up an interface
		canvas $canvas -width 32 -height 16
	    pack $canvas -side right
		menu $menu -postcommand ::irda::show_menu
		bind $canvas <1> "$menu post \[winfo rootx %W\] \[expr \[winfo rooty .\]+\[winfo height .\]\]"
		$canvas create image 1 8 -anchor w -image [image create photo\
		-data {R0lGODlhEAAQAIAAAAAAAP///yH5BAEKAAEALAAAAAAQABAAQAIojI8AGKr2XluJSskgnVkf
zHnX9lkL2IVptXouM4aOKdOiXbpo/q5gAQA7}]
		#
		# Hint window management
		# 
		toplevel $canvas.hint
		wm overrideredirect $canvas.hint y
		wm withdraw $canvas.hint
		label $canvas.hint.l -textvar ::irda::hint -font 6x10 -background yellow
		pack $canvas.hint.l -side left
		bind $canvas <Enter> ::irda::start_hint
		bind $canvas <Leave> ::irda::cancel_hint
		bind $canvas <Motion> ::irda::reset_hint
		proc start_hint {} {
			variable hint_after_id
			set hint_after_id [after 1000 ::irda::show_hint]
		}
		proc cancel_hint {} {
			variable hint_after_id
			variable canvas
			if [info exists hint_after_id] {
				after cancel $hint_after_id
				unset hint_after_id
			}
			if {[wm state $canvas.hint]=="normal"} {
				wm withdraw $canvas.hint
			}
		}
		proc reset_hint {} {
			cancel_hint
			start_hint
		}
		proc show_hint {} {
			variable canvas
			wm geometry $canvas.hint +[expr [winfo pointerx .]+2]+[expr [winfo pointery .]+2]
			wm deiconify $canvas.hint
			raise $canvas.hint
		}	

	}
	irda::update
}