00001 # TKE - Advanced Programmer's Editor 00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com) 00003 # 00004 # This program is free software; you can redistribute it and/or modify 00005 # it under the terms of the GNU General Public License as published by 00006 # the Free Software Foundation; either version 2 of the License, or 00007 # (at your option) any later version. 00008 # 00009 # This program is distributed in the hope that it will be useful, 00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of 00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00012 # GNU General Public License for more details. 00013 # 00014 # You should have received a copy of the GNU General Public License along 00015 # with this program; if not, write to the Free Software Foundation, Inc., 00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 00017 00018 ###################################################################### 00019 # Name: bgproc.tcl 00020 # Author: Trevor Williams (phase1geo@gmail.com) 00021 # Date: 5/13/2013 00022 # Brief: Provides services for performing system and Tcl commands in 00023 # the background. 00024 ###################################################################### 00025 00026 namespace eval bgproc { 00027 00028 variable last_update 0 00029 variable update_interval 100 00030 00031 array set resource_completed { 00032 all 0 00033 } 00034 array set resources {} 00035 array set resource_pid {} 00036 array set resource_tmo {} 00037 array set cancelled {} 00038 00039 ############################################################# 00040 #------------------------------------------------------------ 00041 # PUBLIC PROCEDURES 00042 #------------------------------------------------------------ 00043 ############################################################# 00044 00045 ############################################################# 00046 # This procedure should be called by the toplevel code when 00047 # it wants to wait for all pending commands to complete. 00048 # blocks until all background activity has completed. 00049 proc synchronize {{resource ""}} { 00050 00051 variable resource_completed 00052 variable resources 00053 00054 # Wait for the specified resource to complete 00055 if {$resource ne ""} { 00056 00057 # If the given resource list is in existence, wait for it to complete. 00058 if {[info exists resources($resource)]} { 00059 if {![info exists resource_completed($resource)]} { 00060 set resource_completed($resource) 0 00061 } 00062 vwait bgproc::resource_completed($resource) 00063 } 00064 00065 # Wait for all resources to complete 00066 } else { 00067 00068 # If we have any processes outstanding, wait for them to be completed. 00069 if {[array size resources] > 0} { 00070 vwait bgproc::resource_completed(all) 00071 } 00072 00073 } 00074 00075 } 00076 00077 ############################################################# 00078 # Calls the given system command in the background and guarantees 00079 # that it will complete before the GUI is shutdown. 00080 proc system {resource cmd args} { 00081 00082 # Handle options 00083 array set opts { 00084 -cancelable 0 00085 -killable 0 00086 -releasable 0 00087 -callback "" 00088 -readcallback "" 00089 -redirect "" 00090 -timeout 0 00091 -variable "" 00092 } 00093 array set opts $args 00094 00095 # Push the resource 00096 push_resource $resource [array get opts] [list bgproc::system_helper $resource $cmd $opts(-callback) $opts(-readcallback) $opts(-redirect) $opts(-timeout) $opts(-variable)] 00097 00098 } 00099 00100 ############################################################# 00101 # Calls the given Tcl command in the background and guarantees 00102 # that it will complete before the GUI is shutdown. 00103 proc command {resource cmd args} { 00104 00105 # Handle options 00106 array set opts { 00107 -cancelable 0 00108 -callback "" 00109 } 00110 array set opts $args 00111 00112 # We cannot kill or release Tcl commands 00113 array set opts { 00114 -killable 0 00115 -releasable 0 00116 } 00117 00118 # Push the resource 00119 push_resource $resource [array get opts] [list bgproc::command_helper $resource $cmd $opts(-callback)] 00120 00121 } 00122 00123 ############################################################# 00124 # This procedure can be called from anywhere. It calls the 00125 # update command if it hasn't been called within a specified 00126 # period of time. 00127 proc update {{initialize 0}} { 00128 00129 variable last_update 00130 variable update_interval 00131 00132 # Get the current time 00133 set curr_time [clock milliseconds] 00134 00135 # If we are initializing, don't update 00136 if {$initialize} { 00137 set last_update $curr_time 00138 00139 # If the difference between the last update time and the current time exceeds the 00140 # maximum allowed update interval, perform the update and save the current time as 00141 # the last update time. 00142 } elseif {($curr_time - $last_update) >= $update_interval} { 00143 set last_update $curr_time 00144 ::update 00145 } 00146 00147 } 00148 00149 if {[string first wish [info nameofexecutable]] != -1} { 00150 00151 ############################################################# 00152 # Displays a progress dialog box that performs a local grab with 00153 # a potential cancel button (available if the resource is killable). 00154 proc progress_dialog {resource msg parent} { 00155 00156 variable resources 00157 variable cancelled 00158 00159 if {[llength $resources($resource)] > 0} { 00160 00161 set w ".resourceprogwin[lsearch [array names resources] $resource]" 00162 00163 if {![winfo exists $w]} { 00164 00165 toplevel $w -bd 2 -relief raised 00166 wm overrideredirect $w 1 00167 wm transient $w $parent 00168 wm resizable $w 0 0 00169 00170 frame $w.f 00171 label $w.f.msg -text $msg 00172 ttk::progressbar $w.f.pb -orient horizontal -mode indeterminate 00173 button $w.f.cancel -text [msgcat::mc "Cancel"] -command "set bgproc::cancelled($resource) 1; bgproc::killall $resource" 00174 00175 grid columnconfigure $w.f 0 -weight 1 00176 grid $w.f.msg -row 0 -column 0 -sticky news -padx 2 -pady 2 00177 grid $w.f.pb -row 1 -column 0 -sticky news -padx 2 -pady 2 00178 if {[lindex $resources($resource) 0 2]} { 00179 grid $w.f.cancel -row 0 -column 1 -sticky ews -rowspan 2 -padx 2 -pady 2 00180 } 00181 00182 pack $w.f -fill both -expand yes 00183 00184 # Place the window and set the focus/grab 00185 ::tk::PlaceWindow $w widget $parent 00186 ::tk::SetFocusGrab $w $w 00187 00188 # Start the progress bar 00189 $w.f.pb start 00190 00191 # Wait for the resource to complete 00192 synchronize $resource 00193 00194 # Stop the progress bar 00195 $w.f.pb stop 00196 00197 # Restore the focus and grab 00198 ::tk::RestoreFocusGrab $w $w 00199 00200 # Return a value of 0 if we were cancelled 00201 if {[info exists cancelled($resource)]} { 00202 unset cancelled($resource) 00203 return 0 00204 } 00205 00206 } 00207 00208 } 00209 00210 return 1 00211 00212 } 00213 00214 } 00215 00216 ############################################################# 00217 #------------------------------------------------------------ 00218 # INTERNAL PROCEDURES 00219 #------------------------------------------------------------ 00220 ############################################################# 00221 00222 ############################################################# 00223 # Gathers the command output from the given command channel. 00224 proc get_command_output {resource callback readcallback fid pid redirect_id var} { 00225 00226 variable system_result 00227 variable resource_pid 00228 variable resource_tmo 00229 00230 if {[eof $fid]} { 00231 00232 # Change the file to blocking so that we can get error information from it - TBD 00233 fconfigure $fid -blocking 1 00234 00235 # Close the channel 00236 if {[catch "close $fid" rc]} { 00237 set error_found 1 00238 set system_result($pid) $rc 00239 if {$var ne ""} { 00240 upvar #0 $var uvar 00241 set uvar "" 00242 } 00243 } else { 00244 set error_found 0 00245 } 00246 00247 # Handle an I/O redirect 00248 if {$redirect_id ne ""} { 00249 catch "close $redirect_id" 00250 } 00251 00252 # If we have a timeout mechanism set for our resource, cancel it. 00253 if {[info exists resource_tmo($resource)]} { 00254 after cancel $resource_tmo($resource) 00255 unset resource_tmo($resource) 00256 } 00257 00258 # If we have a callback function to invoke, call it now 00259 if {[info exists resource_pid($resource)]} { 00260 unset resource_pid($resource) 00261 if {$callback ne ""} { 00262 if {[catch "$callback $error_found [list $system_result($pid)]" rc]} { 00263 bgerror $rc 00264 } 00265 } 00266 unset system_result($pid) 00267 } 00268 00269 # Pop the current resource and handle any new jobs 00270 pop_resource $resource 00271 00272 } elseif {[set data [read $fid]] ne ""} { 00273 if {$redirect_id ne ""} { 00274 puts -nonewline $redirect_id $data 00275 } 00276 if {$readcallback ne ""} { 00277 if {[catch "$readcallback [list $data]" rc]} { 00278 bgerror $rc 00279 } 00280 } 00281 append system_result($pid) $data 00282 if {$var ne ""} { 00283 upvar #0 $var uvar 00284 append uvar $data 00285 } 00286 } 00287 00288 } 00289 00290 ############################################################# 00291 # Helper procedure for the system procedure. 00292 proc system_helper {resource cmd callback readcallback redirect timeout var} { 00293 00294 variable system_result 00295 variable resources 00296 variable resource_pid 00297 variable resource_tmo 00298 00299 # If we are killable and our resource queue is > 1, don't run ourself. 00300 if {![lindex $resources($resource) 0 2] || ([llength $resources($resource)] == 1)} { 00301 00302 # Start the executable in the background 00303 if {[catch "open {| $cmd 2>@1} r" cmd_id]} { 00304 if {$callback ne ""} { 00305 if {[catch "$callback 1 [list $cmd_id]" rc]} { 00306 bgerror $rc 00307 } 00308 } else { 00309 notifier::notify -type error -parent $::top_window \ 00310 -message [format "%s (%s)" [msgcat::mc "Unable to run system command"] $cmd] -detail $cmd_id 00311 } 00312 pop_resource $resource 00313 return 00314 } 00315 00316 set pid [pid $cmd_id] 00317 set system_result($pid) "" 00318 00319 # If a variable was specified, initialize it as well 00320 if {$var ne ""} { 00321 upvar #0 $var uvar 00322 set uvar "" 00323 } 00324 00325 # Add our PID to the resources queue 00326 set resource_pid($resource) $pid 00327 00328 # If we need to redirect the I/O, open the file 00329 set redirect_id "" 00330 if {$redirect ne ""} { 00331 set redirect_id [open $redirect a] 00332 } 00333 00334 # Create a file handler to gather the return information 00335 fconfigure $cmd_id -blocking 0 00336 fileevent $cmd_id readable [list bgproc::get_command_output $resource $callback $readcallback $cmd_id $pid $redirect_id $var] 00337 00338 # If a timeout value was specified, kill the resource after the specified period of time 00339 if {$timeout > 0} { 00340 set resource_tmo($resource) [after $timeout [list bgproc::kill_pid $resource]] 00341 } 00342 00343 } else { 00344 00345 # Pop the current resource and handle any new jobs 00346 pop_resource $resource 00347 00348 } 00349 00350 } 00351 00352 ############################################################# 00353 # Interrupts the given PID and frees the resource_pid, if necessary. 00354 proc interrupt_pid {resource} { 00355 00356 variable resource_pid 00357 variable resource_tmo 00358 00359 if {[info exists resource_pid($resource)]} { 00360 if {![catch "exec kill -s INT $resource_pid($resource)" rc]} { 00361 unset resource_pid($resource) 00362 } 00363 } 00364 00365 catch "unset resource_tmo($resource)" 00366 00367 } 00368 00369 ############################################################# 00370 # Kills the given PID and frees the resource_pid, if necessary. 00371 proc kill_pid {resource} { 00372 00373 variable resource_pid 00374 variable resource_tmo 00375 00376 if {[info exists resource_pid($resource)]} { 00377 if {![catch "exec kill -9 $resource_pid($resource)" rc]} { 00378 unset resource_pid($resource) 00379 } 00380 } 00381 00382 catch "unset resource_tmo($resource)" 00383 00384 } 00385 00386 ############################################################# 00387 # Helper procedure for the command proc. 00388 proc command_helper {resource cmd {callback ""}} { 00389 00390 # Perform the command 00391 set retval [eval $cmd] 00392 00393 # If we have a callback function to invoke, call it now 00394 if {$callback ne ""} { 00395 eval "$callback [list $retval]" 00396 } 00397 00398 # Pop the current resource and handle any new jobs 00399 pop_resource $resource 00400 00401 } 00402 00403 ############################################################# 00404 # Kills/removes all resources from the given resource queue 00405 # pattern. Returns 1 if a process was successfully killed; 00406 # otherwise, returns 0. 00407 proc killall {{pattern *}} { 00408 00409 variable resources 00410 variable resource_pid 00411 00412 set retval 0 00413 00414 foreach resource [array names resources $pattern] { 00415 00416 if {[info exists resources($resource)] && [lindex $resources($resource) 0 2]} { 00417 00418 if {[info exists resource_pid($resource)]} { 00419 00420 # Kill the resource at the beginning of the queue 00421 if {![catch "exec kill -9 $resource_pid($resource)"]} { 00422 unset resource_pid($resource) 00423 } 00424 00425 } 00426 00427 # Clear out the rest of the entries in the given resource list 00428 if {[llength $resources($resource)] > 1} { 00429 set resources($resource) [lrange $resources($resource) 1 end] 00430 } 00431 00432 set retval 1 00433 00434 } 00435 00436 } 00437 00438 return $retval 00439 00440 } 00441 00442 ############################################################# 00443 # Releases any resources that are releasable. 00444 proc releaseall {} { 00445 00446 variable resources 00447 variable resource_pid 00448 00449 foreach resource [array names resources] { 00450 if {[llength [set resources($resource) [lsearch -not -all -inline -index 3 $resources($resource) 1]]] == 0} { 00451 unset resources($resource) 00452 } 00453 } 00454 00455 } 00456 00457 ############################################################# 00458 # Adds a given resource to its resource queue and runs the head 00459 # queue, if its the only one. 00460 proc push_resource {resource popts cmd} { 00461 00462 variable resources 00463 variable resource_pid 00464 00465 array set opts $popts 00466 00467 # Add the command call to the associated resource queue 00468 lappend resources($resource) [list $cmd $opts(-cancelable) $opts(-killable) $opts(-releasable)] 00469 00470 # Call the system helper, if we are the only thing in the resource queue, run it now 00471 if {[llength $resources($resource)] == 1} { 00472 after 1 [lindex $resources($resource) 0 0] 00473 00474 # If the command at the head of the queue is killable, kill it now 00475 } elseif {[lindex $resources($resource) 0 2] && [info exists resource_pid($resource)]} { 00476 00477 # Attempt to kill the job 00478 if {![catch "exec kill -9 $resource_pid($resource)"]} { 00479 unset resource_pid($resource) 00480 } 00481 00482 } 00483 00484 } 00485 00486 ############################################################# 00487 # Pops the given resource and starts the next job, if one exists. 00488 proc pop_resource {resource} { 00489 00490 variable resources 00491 variable resource_completed 00492 00493 # Pop ourselves off of the resource queue and start the next, if there is something 00494 set resources($resource) [lrange $resources($resource) 1 end] 00495 00496 # Start the next command if one exists 00497 if {[llength $resources($resource)] > 0} { 00498 00499 # Pop any cancelable events (except for the last one) 00500 while {([llength $resources($resource)] > 1) && [lindex $resources($resource) 0 1]} { 00501 set resources($resource) [lrange $resources($resource) 1 end] 00502 } 00503 00504 # Run the command 00505 after 1 [lindex $resources($resource) 0 0] 00506 00507 } else { 00508 00509 unset resources($resource) 00510 set resource_completed($resource) 1 00511 00512 # If the resource array is empty, specify that all current processes have completed 00513 if {[array size resources] == 0} { 00514 set resource_completed(all) 1 00515 } 00516 00517 } 00518 00519 } 00520 00521 }