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 }
