00001 # Copyright (C) 1997-2004 The CDG Team <cdg@nats.informatik.uni-hamburg.de> 00002 # 00003 # This file is free software; as a special exception the author gives 00004 # unlimited permission to copy and/or distribute it, with or without 00005 # modifications, as long as this notice is preserved. 00006 # 00007 # This program is distributed in the hope that it will be useful, but 00008 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the 00009 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00010 00011 ## ---------------------------------------------------------------------------- 00012 ## \file YadaProc.tcl 00013 ## Bunch of small helper functions. 00014 ## This module collects all helpers that don't fit in a proper class for themselves. 00015 ## Actually for those cases the YadaMain might be taken, but ... 00016 ## 00017 ## \author Michael Daum 00018 ## 00019 ## $Id YadaProc.tcl$ 00020 ## ---------------------------------------------------------------------------- 00021 00022 ## ---------------------------------------------------------------------------- 00023 ## convert a time in numerical format to a human readeable format. 00024 ## \param time time in milliseconds 00025 ## \returns a string representation 00026 ## ---------------------------------------------------------------------------- 00027 proc timeToString {time} {; ## \type TclNumber 00028 00029 if {$time <= 0.0} { 00030 return "0 ms" 00031 } 00032 00033 # calculate the units 00034 set time [expr double($time)] 00035 set w [expr floor($time / 604800000.0)] 00036 set time [expr $time - $w * 604800000.0] 00037 set d [expr floor($time / 86400000.0)] 00038 set time [expr $time - $d * 86400000.0] 00039 set h [expr floor($time / 3600000.0)] 00040 set time [expr $time - $h * 3600000.0] 00041 set m [expr floor($time / 60000.0)] 00042 set time [expr $time - $m * 60000.0] 00043 set s [expr floor($time / 1000.0)] 00044 set ms [expr $time - $s * 1000] 00045 00046 # build the string 00047 set isFirst 1 00048 set result "" 00049 foreach unit {w d h m s ms} { 00050 set value [subst \$$unit] 00051 if {$value > 0.0} { 00052 if {$isFirst} { 00053 set isFirst 0 00054 } else { 00055 append result " " 00056 } 00057 append result [format "%.0f %s" $value $unit] 00058 } 00059 } 00060 00061 return $result 00062 } 00063 00064 ## ---------------------------------------------------------------------------- 00065 ## get the index of an entry in a listbox. 00066 ## \param listBox the tcl command of the list box 00067 ## \param entry an entry in the \a listBox 00068 ## \returns the index > 0 if the \a entry exists, -1 if not so 00069 ## ---------------------------------------------------------------------------- 00070 proc getIndexOfName {listBox entry} {; ## \type TclCommand, TclString 00071 set listOfEntries [$listBox get 0 end] 00072 set index [lsearch $listOfEntries $entry] 00073 return $index 00074 } 00075 00076 ## ---------------------------------------------------------------------------- 00077 ## open a message dialog with a given text. 00078 ## \param message the notification text 00079 ## \param image an image name, see YadaImages for possible values 00080 ## ---------------------------------------------------------------------------- 00081 proc printMessage {message {image "info"}} {; ## \type TclString, TclString 00082 if {![winfo exists .msg]} { 00083 iwidgets::messagedialog .msg \ 00084 } 00085 .msg configure \ 00086 -text $message \ 00087 -title "Yada - Message" \ 00088 -image [YadaImages::get $image] \ 00089 -modality application \ 00090 -textpadx 10 \ 00091 -master . 00092 00093 .msg hide Cancel 00094 .msg center . 00095 .msg activate 00096 destroy .msg 00097 } 00098 00099 ## ---------------------------------------------------------------------------- 00100 ## extract notifications. 00101 ## This helper extracts all notifications in a cdgp DomDocument. That is, it 00102 ## searches for \\<notify ...\\> nodes and gets the \a desc attribute from it. 00103 ## \param document the DomDocument that we are interested in 00104 ## \param severity optionally specify the \c type attribute of the notification 00105 ## that we want to extract 00106 ## \returns the TclList of all messages in all notifications 00107 ## ---------------------------------------------------------------------------- 00108 proc getAllNotifications {document {severity ""}} {; ## \type DomDocument, TclString 00109 00110 set messages "" 00111 00112 # get the cdgp logfile root element 00113 set cdgpNode [$document getElement "cdgp"] 00114 if {$cdgpNode != ""} { 00115 00116 if {$severity != ""} { 00117 set nodes [$cdgpNode descendant all "notify" "type" $severity] 00118 } else { 00119 set nodes [$cdgpNode descendant all "notify"] 00120 } 00121 00122 foreach node $nodes { 00123 lappend messages [$node getAttribute "desc"] 00124 } 00125 } 00126 00127 return $messages 00128 } 00129 00130 ## ---------------------------------------------------------------------------- 00131 ## Sets mouse cursor to indicate busy processing 00132 ## @return list of changed widgets and previous cursor settings 00133 ## ({<widget> <cursor> ....}) 00134 ## ---------------------------------------------------------------------------- 00135 proc setBusy {} { 00136 set busy {} 00137 set list {.} 00138 # Traverse the widget hierarchy to locate widgets with 00139 # a nondefault -cursor setting. 00140 # 00141 while {$list != ""} { 00142 set next {} 00143 foreach w $list { 00144 catch {set cursor [$w cget -cursor]} 00145 if {[winfo toplevel $w] == $w || $cursor != "" } { 00146 lappend busy $w $cursor 00147 set cursor {} 00148 } 00149 set next [concat $next [winfo children $w]] 00150 } 00151 set list $next 00152 } 00153 00154 # Change the cursor: 00155 # 00156 foreach {w _} $busy { 00157 catch {$w configure -cursor watch} 00158 } 00159 update idletasks 00160 00161 return $busy 00162 } 00163 00164 00165 ## ---------------------------------------------------------------------------- 00166 ## Restores mouse cursor settings for widget hierarchy corresponding 00167 ## to saved settings in first argument (should be identical to return value 00168 ## of proc setBusy) 00169 ## ---------------------------------------------------------------------------- 00170 proc resetBusy { listPrevSettings } {; ## \type TclList 00171 # Restore the original cursor settings. 00172 # 00173 foreach {w cursor} $listPrevSettings { 00174 catch {$w configure -cursor $cursor} 00175 } 00176 }