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: plugins.tcl 00020 # Author: Trevor Williams (phase1geo@gmail.com) 00021 # Date: 5/11/2013 00022 # Brief: Namespace to support the plugin framework. 00023 # 00024 # List of available plugin actions: 00025 # menu - Adds a menu to the main menubar 00026 # tab_popup - Adds items to the tab popup menu 00027 # root_popup - Adds items to a root directory sidebar popup menu 00028 # dir_popup - Adds items to a non-root directory sidebar popup menu 00029 # file_popup - Adds items to a file sidebar popup menu 00030 # text_binding - Adds one or more bindings to a created text field. 00031 # on_start - Runs when the editor is started or when the plugin is installed 00032 # on_open - Runs when a tab is opened 00033 # on_focusin - Runs when a tab receives focus 00034 # on_close - Runs when a tab is closed 00035 # on_update - Runs when a tab is updated 00036 # on_quit - Runs when the editor is exited 00037 # on_reload - Takes action when the plugin is reloaded 00038 # on_save - Runs prior to a file being saved 00039 # on_rename - Runs when a file/folder is being renamed 00040 # on_duplicate - Runs when a file is being duplicated 00041 # on_delete - Runs when a file/folder is being deleted 00042 # on_trash - Runs when a file/folder is moved to the trash 00043 # on_uninstall - Runs when the plugin is uninstalled by the user. Allows UI cleanup, etc. 00044 # on_pref_load - Runs when the plugin preference items need to be added. 00045 # on_pref_ui - Runs when the plugin preference panel needs to be displayed in the preferences window. 00046 # on_drop - Runs when a file or text is dropped in an editing buffer. 00047 # on_theme_change - Runs after the user has changed themes. 00048 # syntax - Adds the given syntax file to the list of available syntaxes 00049 # vcs - Adds support for a version control system to the difference viewer 00050 # info_panel - Adds items to the sidebar information panel. 00051 # expose - Adds procedures that can be called from any plugin. 00052 ###################################################################### 00053 00054 namespace eval plugins { 00055 00056 variable registry_size 0 00057 variable plugin_mb "" 00058 variable tab_popup "" 00059 variable root_popup "" 00060 variable dir_popup "" 00061 variable file_popup "" 00062 00063 array set registry {} 00064 array set plugins {} 00065 array set prev_sourced {} 00066 array set bound_tags {} 00067 array set menu_vars {} 00068 array set exposed {} 00069 00070 array set categories [list \ 00071 miscellaneous [msgcat::mc "Miscellaneous"] \ 00072 editing [msgcat::mc "Editing"] \ 00073 tools [msgcat::mc "Tools"] \ 00074 sessions [msgcat::mc "Sessions"] \ 00075 search [msgcat::mc "Search"] \ 00076 filesystem [msgcat::mc "File System"] \ 00077 vcs [msgcat::mc "Version Control"] \ 00078 documentation [msgcat::mc "Documentation"] \ 00079 syntax [msgcat::mc "Syntax"] \ 00080 sidebar [msgcat::mc "Sidebar"] \ 00081 ] 00082 00083 set plugins_file [file join $::tke_home plugins.tkedat] 00084 00085 ###################################################################### 00086 # Handles any changes to plugin menu variables. 00087 proc handle_menu_variable {index name1 name2 op} { 00088 00089 variable registry 00090 variable menu_vars 00091 00092 $registry($index,interp) eval set $name2 $menu_vars($name2) 00093 00094 } 00095 00096 ###################################################################### 00097 # Procedure that is called be each plugin that registers all of the 00098 # actions that the plugin can perform. 00099 proc register {name actions} { 00100 00101 variable registry 00102 variable registry_size 00103 00104 set i 0 00105 while {($i < $registry_size) && ($registry($i,name) ne $name)} { 00106 incr i 00107 } 00108 00109 if {$i < $registry_size} { 00110 set j 0 00111 foreach action $actions { 00112 set registry($i,action,[lindex $action 0],$j) [lrange $action 1 end] 00113 incr j 00114 } 00115 } 00116 00117 } 00118 00119 ###################################################################### 00120 # Loads the header information from all available plugins. 00121 proc load {{read_config_file 1}} { 00122 00123 variable registry 00124 variable registry_size 00125 00126 set registry_size 0 00127 00128 # Get all of the plugin directories in the installation directory 00129 if {[namespace exists ::freewrap]} { 00130 set dirs [lmap item [zvfs::list [file join $::tke_dir plugins * header.tkedat]] { 00131 file dirname $item 00132 }] 00133 } else { 00134 set dirs [glob -nocomplain -directory [file join $::tke_dir plugins] -types d *] 00135 } 00136 00137 # Get any plugins from the user's home directory 00138 if {[file exists [file join $::tke_home iplugins]]} { 00139 lappend dirs {*}[glob -nocomplain -directory [file join $::tke_home iplugins] -types d *] 00140 } 00141 00142 foreach plugin $dirs { 00143 00144 # Read the header information 00145 if {![catch { tkedat::read [file join $plugin header.tkedat] 0 } rc]} { 00146 00147 array set header $rc 00148 00149 # Store this information if the name is specified and it should be included 00150 if {[info exists header(name)] && ($header(name) ne "") && [info exists header(include)] && ($header(include) eq "yes")} { 00151 set registry($registry_size,selected) 0 00152 set registry($registry_size,status) "" 00153 set registry($registry_size,interp) "" 00154 set registry($registry_size,tgntd) 0 00155 set registry($registry_size,file) [file join $plugin main.tcl] 00156 set registry($registry_size,name) $header(name) 00157 set registry($registry_size,display_name) [expr {[info exists header(display_name)] ? $header(display_name) : [make_display_name $header(name)]}] 00158 set registry($registry_size,author) [expr {[info exists header(author)] ? $header(author) : ""}] 00159 set registry($registry_size,website) [expr {[info exists header(website)] ? $header(website) : ""}] 00160 set registry($registry_size,email) [expr {[info exists header(email)] ? $header(email) : ""}] 00161 set registry($registry_size,version) [expr {[info exists header(version)] ? $header(version) : ""}] 00162 set registry($registry_size,category) [expr {[info exists header(category)] ? [string tolower $header(category)] : "miscellaneous"}] 00163 set registry($registry_size,description) [expr {[info exists header(description)] ? $header(description) : ""}] 00164 set registry($registry_size,treqd) [expr {[info exists header(trust_required)] ? ([string compare -nocase $header(trust_required) "yes"] == 0) : 0}] 00165 incr registry_size 00166 } 00167 00168 array unset header 00169 00170 } 00171 00172 } 00173 00174 # Read in the contents of the plugin configuration file 00175 if {$read_config_file} { 00176 read_config 00177 } 00178 00179 } 00180 00181 ###################################################################### 00182 # Perfoms a reload of the available plugins. 00183 proc reload {{file_index ""}} { 00184 00185 variable registry 00186 variable registry_size 00187 variable prev_sourced 00188 00189 # Delete all exposed procedures 00190 delete_all_exposed 00191 00192 # Delete all plugin menu items 00193 delete_all_menus 00194 00195 # Delete all plugin text bindings 00196 delete_all_text_bindings 00197 00198 # Delete all plugin syntax registrations 00199 delete_all_syntax 00200 00201 # Delete all VCS commands 00202 delete_all_vcs_commands 00203 00204 catch { array unset prev_sourced } 00205 for {set i 0} {$i < $registry_size} {incr i} { 00206 if {$registry($i,selected) && ($registry($i,interp) ne "")} { 00207 foreach action [array names registry $i,action,on_reload,*] { 00208 set prev_sourced($registry($i,name)) $registry($action) 00209 } 00210 handle_resourcing $i 00211 interpreter::destroy $registry($i,name) 00212 set registry($i,interp) "" 00213 } 00214 } 00215 00216 # Clear the plugin information 00217 array unset registry 00218 set registry_size 0 00219 00220 # Load plugin header information 00221 load 00222 00223 # Add all exposed procedures 00224 add_all_exposed 00225 00226 # Add all of the plugins 00227 add_all_menus 00228 00229 # Add all of the text bindings 00230 add_all_text_bindings 00231 00232 # Add all of the syntaxes 00233 add_all_syntax 00234 00235 # Add all of the VCS commands 00236 add_all_vcs_commands 00237 00238 # Update the preferences 00239 handle_on_pref_load 00240 00241 # Update the file information panel 00242 ipanel::insert_info_panel_plugins 00243 00244 # Re-apply menu bindings in case the user added some for plugins 00245 bindings::load_file 1 00246 00247 # Tell the user that the plugins have been successfully reloaded 00248 gui::set_info_message [msgcat::mc "Plugins successfully reloaded"] 00249 00250 } 00251 00252 ###################################################################### 00253 # Writes the current plugin configuration file to the tke home directory. 00254 proc write_config {} { 00255 00256 variable registry 00257 variable registry_size 00258 variable plugins 00259 variable plugins_file 00260 00261 # Create the array to store in the plugins.tkedat file 00262 for {set i 0} {$i < $registry_size} {incr i} { 00263 set plugins($registry($i,name)) [list selected $registry($i,selected) trust_granted $registry($i,tgntd)] 00264 } 00265 00266 # Store the data 00267 catch { tkedat::write $plugins_file [array get plugins] } 00268 00269 } 00270 00271 ###################################################################### 00272 # Reads the user's plugin configuration file. 00273 proc read_config {} { 00274 00275 variable registry 00276 variable registry_size 00277 variable plugins 00278 variable plugins_file 00279 variable prev_sourced 00280 00281 set bad_sources [list] 00282 00283 # Read the plugins file 00284 if {![catch { tkedat::read $plugins_file } rc]} { 00285 00286 array set plugins $rc 00287 00288 for {set i 0} {$i < $registry_size} {incr i} { 00289 if {[info exists plugins($registry($i,name))]} { 00290 array set data $plugins($registry($i,name)) 00291 if {$data(selected) || [info exists prev_sourced($registry($i,name))]} { 00292 set registry($i,selected) 1 00293 set registry($i,tgntd) $data(trust_granted) 00294 set interpreter [interpreter::create $registry($i,name) $data(trust_granted)] 00295 if {[catch { interp eval $interpreter source $registry($i,file) } status]} { 00296 handle_status_error "read_config" $i $status 00297 lappend bad_sources $i 00298 interpreter::destroy $registry($i,name) 00299 } else { 00300 set registry($i,interp) $interpreter 00301 handle_reloading $i 00302 } 00303 } 00304 } 00305 00306 } 00307 00308 } 00309 00310 # If there was an error in sourcing any of the selected plugins, report the error to the user 00311 if {[llength $bad_sources] > 0} { 00312 set names [list] 00313 foreach bad_source $bad_sources { 00314 set registry($bad_source,selected) 0 00315 lappend names $registry($bad_source,display_name) 00316 } 00317 tk_messageBox -default ok -type ok -icon warning -parent . -title [msgcat::mc "Plugin Errors"] \ 00318 -message [msgcat::mc "Syntax errors found in selected plugins"] -detail [join $names \n] 00319 } 00320 00321 # Add all of the exposed procs 00322 add_all_exposed 00323 00324 # Add all of the available VCS commands 00325 add_all_vcs_commands 00326 00327 # Add preference items 00328 handle_on_pref_load 00329 00330 } 00331 00332 ###################################################################### 00333 # Handles an error when sourcing a plugin file. 00334 proc handle_status_error {procname index status} { 00335 00336 variable registry 00337 00338 # Save the status 00339 set registry($index,status) $status 00340 00341 # Get the name of the plugin 00342 set name $registry($index,display_name) 00343 00344 # If we are doing development, send the full error info to standard output 00345 if {[::tke_development]} { 00346 puts $::errorInfo 00347 } 00348 00349 # Log the error information in the diagnostic logfile 00350 logger::log $::errorInfo 00351 00352 # Set the current information message 00353 gui::set_info_message [format "%s (%s,%s): %s" [msgcat::mc "ERROR"] $name $procname [lindex [split $status \n] 0]] 00354 00355 } 00356 00357 ###################################################################### 00358 # Called when a plugin is sourced. Checks to see if the plugin wants 00359 # to be called to save data when it is resourced (data will otherwise 00360 # be lost once the plugin has been resourced. 00361 proc handle_resourcing {index} { 00362 00363 variable registry 00364 variable prev_sourced 00365 00366 set name $registry($index,name) 00367 00368 if {$registry($index,selected) && [info exists prev_sourced($name)]} { 00369 if {[catch { $registry($index,interp) eval [lindex $prev_sourced($name) 0] $index } status]} { 00370 handle_status_error "handle_resourcing" $index $status 00371 } 00372 } 00373 00374 } 00375 00376 ###################################################################### 00377 # Called when a plugin is sourced. If the plugin retrieves saved information, 00378 # allows the plugin to do it. 00379 proc handle_reloading {index} { 00380 00381 variable registry 00382 variable prev_sourced 00383 00384 set name $registry($index,name) 00385 00386 if {$registry($index,selected) && [info exists prev_sourced($name)]} { 00387 if {[catch { $registry($index,interp) eval [lindex $prev_sourced($name) 1] $index } status]} { 00388 handle_status_error "handle_reloading" $index $status 00389 } 00390 } 00391 00392 } 00393 00394 ###################################################################### 00395 # Allows a plugin to save temporary data to non-corruptible memory. 00396 # This memory will be cleared whenever the plugin retrieves the data. 00397 proc save_data {index name value} { 00398 00399 variable temp_user_data 00400 00401 set temp_user_data($index,$name) $value 00402 00403 } 00404 00405 ###################################################################### 00406 # If a previous call to save_data form the same index/name combination 00407 # was called, returns the value stored for that variable. Removes 00408 # temporary memory prior to returning. 00409 proc restore_data {index name} { 00410 00411 variable temp_user_data 00412 00413 if {[info exists temp_user_data($index,$name)]} { 00414 set value $temp_user_data($index,$name) 00415 unset temp_user_data($index,$name) 00416 } else { 00417 set value "" 00418 } 00419 00420 return $value 00421 00422 } 00423 00424 ###################################################################### 00425 # Installs available plugins. 00426 proc install {} { 00427 00428 variable registry 00429 variable registry_size 00430 00431 # Add registries to launcher 00432 for {set i 0} {$i < $registry_size} {incr i} { 00433 if {!$registry($i,selected)} { 00434 set name $registry($i,name) 00435 set display_name $registry($i,display_name) 00436 launcher::register_temp "`PLUGIN:$display_name" "plugins::install_item $i" $display_name 0 "plugins::show_detail $i" 00437 } 00438 } 00439 00440 # Display the launcher in PLUGIN: mode 00441 launcher::launch "`PLUGIN:" 1 00442 00443 } 00444 00445 ###################################################################### 00446 # Displays the plugin grant dialog window. 00447 proc grant_window {plugin_name} { 00448 00449 variable grant 00450 00451 # Default the permission to be reject 00452 set grant "reject" 00453 00454 toplevel .installwin 00455 wm title .installwin [msgcat::mc "Plugin Trust Requested"] 00456 wm transient .installwin . 00457 wm resizable .installwin 0 0 00458 wm protocol .installwin WM_DELETE_WINDOW { 00459 # Do nothing 00460 } 00461 00462 ttk::frame .installwin.f 00463 ttk::label .installwin.f.l1 -text $plugin_name 00464 ttk::label .installwin.f.e1 -text "" 00465 ttk::label .installwin.f.l2 -text [msgcat::mc "Plugin requires permission to view or modify your system."] 00466 ttk::label .installwin.f.l3 -text [msgcat::mc "Grant permission?"] 00467 ttk::label .installwin.f.e2 -text "" 00468 00469 pack .installwin.f.l1 -padx 2 -pady 2 00470 pack .installwin.f.e1 -padx 2 00471 pack .installwin.f.l2 -padx 2 00472 pack .installwin.f.l3 -padx 2 00473 pack .installwin.f.e2 -padx 2 00474 00475 ttk::frame .installwin.rf 00476 ttk::frame .installwin.rf.f 00477 ttk::radiobutton .installwin.rf.f.r -text [format " %s" [msgcat::mc "Reject"]] -variable plugins::grant -value "reject" 00478 ttk::radiobutton .installwin.rf.f.g -text [format " %s" [msgcat::mc "Grant"]] -variable plugins::grant -value "grant" 00479 ttk::radiobutton .installwin.rf.f.a -text [format " %s" [msgcat::mc "Always grant from developer"]] -variable plugins::grant -value "always" 00480 ttk::label .installwin.rf.f.e -text "" 00481 00482 pack .installwin.rf.f.r -anchor w -padx 2 00483 pack .installwin.rf.f.g -anchor w -padx 2 00484 pack .installwin.rf.f.a -anchor w -padx 2 00485 pack .installwin.rf.f.e 00486 pack .installwin.rf.f 00487 00488 set bwidth [msgcat::mcmax "OK" "Cancel"] 00489 00490 ttk::frame .installwin.bf 00491 ttk::button .installwin.bf.ok -style BButton -text [msgcat::mc "OK"] -width $bwidth -command { 00492 destroy .installwin 00493 } 00494 ttk::button .installwin.bf.cancel -style BButton -text [msgcat::mc "Cancel"] -width $bwidth -command { 00495 set plugins::grant "cancel" 00496 destroy .installwin 00497 } 00498 00499 pack .installwin.bf.cancel -side right -padx 2 -pady 2 00500 pack .installwin.bf.ok -side right -padx 2 -pady 2 00501 00502 pack .installwin.f 00503 pack .installwin.rf -fill x 00504 pack .installwin.bf -fill x 00505 00506 # Place the window 00507 ::tk::PlaceWindow .installwin widget . 00508 00509 # Take the focus and grab 00510 ::tk::SetFocusGrab .installwin .installwin.r 00511 00512 # Wait for the window to close 00513 tkwait window .installwin 00514 00515 # Return the focus and grab 00516 ::tk::RestoreFocusGrab .installwin.r installwin 00517 00518 return $grant 00519 00520 } 00521 00522 ###################################################################### 00523 # Installs the plugin in the registry specified by name. 00524 proc install_item {index} { 00525 00526 variable registry 00527 00528 # Delete all exposed procedures 00529 delete_all_exposed 00530 00531 # Delete all plugin menu items 00532 delete_all_menus 00533 00534 # Delete all plugin text bindings 00535 delete_all_text_bindings 00536 00537 # Delete all syntax 00538 delete_all_syntax 00539 00540 # Delete all VCS commands 00541 delete_all_vcs_commands 00542 00543 # Source the file if it hasn't been previously sourced 00544 if {$registry($index,interp) eq ""} { 00545 if {$registry($index,treqd) && !$registry($index,tgntd)} { 00546 switch [grant_window $registry($index,name)] { 00547 "grant" { set registry($index,tgntd) 1 } 00548 "reject" { set registry($index,tgntd) 0 } 00549 "always" { set registry($index,tgntd) 1 } 00550 default { 00551 add_all_exposed 00552 add_all_menus 00553 add_all_text_bindings 00554 add_all_syntax 00555 add_all_vcs_commands 00556 ipanel::insert_info_panel_plugins 00557 handle_on_pref_load 00558 return 00559 } 00560 } 00561 } 00562 set interpreter [interpreter::create $registry($index,name) $registry($index,tgntd)] 00563 if {[catch { uplevel #0 [list interp eval $interpreter source $registry($index,file)] } status]} { 00564 handle_status_error "install_item" $index $status 00565 set registry($index,selected) 0 00566 interpreter::destroy $registry($index,name) 00567 } else { 00568 gui::set_info_message [format "%s (%s)" [msgcat::mc "Plugin installed"] $registry($index,display_name)] 00569 set registry($index,selected) 1 00570 set registry($index,interp) $interpreter 00571 handle_reloading $index 00572 run_on_start_after_install $index 00573 } 00574 00575 # Otherwise, just mark the plugin as being selected 00576 } else { 00577 gui::set_info_message [format "%s (%s)" [msgcat::mc "Plugin installed"] $registry($index,display_name)] 00578 set registry($index,selected) 1 00579 run_on_start_after_install $index 00580 } 00581 00582 # Add all exposed procedures 00583 add_all_exposed 00584 00585 # Add all of the plugins 00586 add_all_menus 00587 00588 # Add all of the text bindings 00589 add_all_text_bindings 00590 00591 # Add all syntaxes 00592 add_all_syntax 00593 00594 # Add all VCS commands 00595 add_all_vcs_commands 00596 00597 # Update file information 00598 ipanel::insert_info_panel_plugins 00599 00600 # Re-apply menu bindings in case the user added some for plugins 00601 bindings::load_file 1 00602 00603 # Add all loaded preferences 00604 handle_on_pref_load 00605 00606 # Save the installation information to the config file 00607 write_config 00608 00609 } 00610 00611 ###################################################################### 00612 # This procedure is called in the install_item procedure and causes any 00613 # on_start actions associated with the plugin to be called when the plugin 00614 # is installed. 00615 proc run_on_start_after_install {index} { 00616 00617 variable registry 00618 00619 # If the given event contains an "on_uninstall" action, run it. 00620 foreach {name action} [array get registry $index,action,on_start,*] { 00621 if {[catch { $registry($index,interp) eval {*}$action } status]} { 00622 handle_status_error "run_on_start" $index $status 00623 } 00624 } 00625 00626 } 00627 00628 ###################################################################### 00629 # Uninstalls previously installed plugins. 00630 proc uninstall {} { 00631 00632 variable registry 00633 variable registry_size 00634 00635 for {set i 0} {$i < $registry_size} {incr i} { 00636 if {$registry($i,selected)} { 00637 set name $registry($i,name) 00638 set display_name $registry($i,display_name) 00639 launcher::register_temp "`PLUGIN:$display_name" "plugins::uninstall_item $i" $display_name 00640 } 00641 } 00642 00643 # Display the launcher in PLUGIN: mode 00644 launcher::launch "`PLUGIN:" 00645 00646 } 00647 00648 ###################################################################### 00649 # Uninstalls the specified plugin. 00650 proc uninstall_item {index} { 00651 00652 variable registry 00653 00654 # Call "on_uninstall" command, if it exists 00655 handle_on_uninstall $index 00656 00657 # Delete all exposed procedures 00658 delete_all_exposed 00659 00660 # Delete all plugin menu items 00661 delete_all_menus 00662 00663 # Delete all text bindings 00664 delete_all_text_bindings 00665 00666 # Delete all syntax 00667 delete_all_syntax 00668 00669 # Delete all VCS commands 00670 delete_all_vcs_commands 00671 00672 # Destroy the interpreter 00673 interpreter::destroy $registry($index,name) 00674 00675 # Unselect the plugin 00676 set registry($index,selected) 0 00677 set registry($index,interp) "" 00678 00679 # Add all exposed procedures 00680 add_all_exposed 00681 00682 # Add all of the plugins 00683 add_all_menus 00684 00685 # Add all of the text bindings 00686 add_all_text_bindings 00687 00688 # Add all of the syntaxes 00689 add_all_syntax 00690 00691 # Add all of the VCS commands 00692 add_all_vcs_commands 00693 00694 # Update file information 00695 ipanel::insert_info_panel_plugins 00696 00697 # Re-apply menu bindings in case the user added some for plugins 00698 bindings::load_file 1 00699 00700 # Save the plugin information 00701 write_config 00702 00703 # Display the uninstall message 00704 gui::set_info_message [format "%s (%s)" [msgcat::mc "Plugin uninstalled"] $registry($index,display_name)] 00705 00706 } 00707 00708 ###################################################################### 00709 # Displays the installed plugins and their information (if specified). 00710 proc show_installed {} { 00711 00712 variable registry 00713 variable registry_size 00714 00715 for {set i 0} {$i < $registry_size} {incr i} { 00716 if {$registry($i,selected)} { 00717 set name $registry($i,name) 00718 set display_name $registry($i,display_name) 00719 launcher::register_temp "`PLUGIN:$display_name" [list plugins::show_installed_item $i] $display_name 0 [list plugins::show_detail $i] 00720 } 00721 } 00722 00723 # Display the launcher in PLUGIN: mode 00724 launcher::launch "`PLUGIN:" 1 00725 00726 } 00727 00728 ###################################################################### 00729 # Cleans the given string for Markdown output. 00730 proc clean_str {str} { 00731 00732 return [string map {_ {\_} * {\*}} $str] 00733 00734 } 00735 00736 ###################################################################### 00737 # Displays the installed item's detail and README information (if specified). 00738 proc show_installed_item {index} { 00739 00740 variable registry 00741 00742 set display_name $registry($index,display_name) 00743 00744 # Create a buffer 00745 gui::add_buffer end [format "%s: %s" [msgcat::mc "Plugin"] $display_name] "" -readonly 1 -lang "Markdown" 00746 00747 # Get the newly added buffer 00748 gui::get_info {} current txt 00749 00750 # Allow the text buffer to be edited 00751 $txt configure -state normal 00752 00753 # Display the plugin detail 00754 $txt insert end "__Version:__\n\n" 00755 $txt insert end "$registry($index,version)\n\n\n" 00756 $txt insert end "__Author:__\n\n" 00757 $txt insert end "$registry($index,author) ([clean_str $registry($index,email)])\n\n\n" 00758 if {$registry($index,website) ne ""} { 00759 set website [clean_str $registry($index,website)] 00760 $txt insert end "__Website:__\n\n" 00761 $txt insert end "\[$website\]($website)\n\n\n" 00762 } 00763 $txt insert end "__Description:__\n\n" 00764 $txt insert end [clean_str $registry($index,description)] 00765 00766 # Add the README contents (if it exists) 00767 if {![catch { open [file join [file dirname $registry($index,file)] README.md] r } rc]} { 00768 $txt insert end "\n\n\n__README Content:__\n\n" bold 00769 $txt insert end [read $rc] 00770 close $rc 00771 } 00772 00773 # Hide the meta characters 00774 menus::hide_meta_chars .menubar.view 00775 00776 # Disallow the text buffer to be edited 00777 $txt configure -state disabled 00778 00779 } 00780 00781 ###################################################################### 00782 # Displays plugin information into the given text widget. 00783 proc show_detail {index txt} { 00784 00785 variable registry 00786 00787 $txt tag configure bold -underline 1 00788 00789 $txt insert end "Version:" bold " $registry($index,version)\n\n" 00790 $txt insert end "Author:" bold " $registry($index,author) ($registry($index,email))\n\n" 00791 if {$registry($index,website) ne ""} { 00792 $txt insert end "Website:" bold " $registry($index,website)\n\n" 00793 } 00794 $txt insert end "Description:\n\n" bold 00795 $txt insert end $registry($index,description) 00796 00797 } 00798 00799 ###################################################################### 00800 # Generates the Tcl name based on the given display name. 00801 proc make_tcl_name {display_name} { 00802 00803 return [string tolower [string map {{ } _} $display_name]] 00804 00805 } 00806 00807 ###################################################################### 00808 # Generates a display name based on the given Tcl name. 00809 proc make_display_name {name} { 00810 00811 return [utils::str2titlecase [string map {_ { }} $name]] 00812 00813 } 00814 00815 ###################################################################### 00816 # Creates a new plugin. If 'install_dir' is true, the plugin will be 00817 # created in the TKE installed directory (only valid for TKE development). 00818 # If 'install_dir' is false, the plugin will be created in the user's 00819 # iplugins directory in their TKE home directory. 00820 proc create_new_plugin {{install_dir 0}} { 00821 00822 set name "" 00823 00824 if {[gui::get_user_response [msgcat::mc "Enter plugin name"] name]} { 00825 00826 if {![regexp {^[a-zA-Z0-9_]+$} $name]} { 00827 gui::set_info_message [msgcat::mc "ERROR: Plugin name is not valid (only alphanumeric and underscores are allowed)"] 00828 return 00829 } 00830 00831 if {$install_dir} { 00832 set dirname [file join $::tke_dir plugins $name] 00833 } else { 00834 set dirname [file join $::tke_home iplugins $name] 00835 } 00836 00837 if {[file exists $dirname]} { 00838 gui::set_info_message [msgcat::mc "ERROR: Plugin name already exists"] 00839 return 00840 } 00841 00842 # Create the plugin directory 00843 if {[catch { file mkdir $dirname }]} { 00844 gui::set_info_message [msgcat::mc "ERROR: Unable to create plugin directory"] 00845 return 00846 } 00847 00848 # Create the filenames 00849 set header [file join $dirname header.tkedat] 00850 set main [file join $dirname main.tcl] 00851 00852 # Create the main file 00853 if {[catch { open $main w } rc]} { 00854 gui::set_info_message [msgcat::mc "ERROR: Unable to write plugin files"] 00855 return 00856 } 00857 00858 # Create the display name 00859 set display_name [utils::str2titlecase [string map {_ { }} $name]] 00860 00861 # Create the main file 00862 puts $rc "# Plugin namespace" 00863 puts $rc "namespace eval $name {" 00864 puts $rc "" 00865 puts $rc " # INSERT CODE HERE" 00866 puts $rc "" 00867 puts $rc "}" 00868 puts $rc "" 00869 puts $rc "# Register all plugin actions" 00870 puts $rc "api::register $name {" 00871 puts $rc "" 00872 puts $rc "}" 00873 close $rc 00874 00875 # Add the new file to the editor 00876 gui::add_file end $main 00877 00878 # Create the header file 00879 if {[catch { open $header w } rc]} { 00880 gui::set_info_message [msgcat::mc "ERROR: Unable to write plugin files"] 00881 return 00882 } 00883 00884 # Create the header file 00885 puts $rc "name {$name}" 00886 puts $rc "display_name {$display_name}" 00887 puts $rc "author {}" 00888 puts $rc "email {}" 00889 puts $rc "website {}" 00890 puts $rc "version {1.0}" 00891 puts $rc "include {yes}" 00892 puts $rc "trust_required {no}" 00893 puts $rc "category {miscellaneous}" 00894 puts $rc "description {}" 00895 close $rc 00896 00897 # Add the file to the editor 00898 gui::add_file end $header 00899 00900 } 00901 00902 } 00903 00904 ###################################################################### 00905 # Returns the list of available categories in a sorted list. 00906 proc get_categories {type} { 00907 00908 variable categories 00909 00910 if {$type eq "lower"} { 00911 return [lsort [array names categories]] 00912 } else { 00913 set cats [list] 00914 foreach {lower display} [array get categories] { 00915 lappend cats $display 00916 } 00917 return [lsort $cats] 00918 } 00919 00920 } 00921 00922 ###################################################################### 00923 # Called when the user clicks on a category within the text editor. 00924 # We will display a popup menu that will list the possible categories. 00925 # If the user clicks on a category, automatically replaces the existing 00926 # category with the selected one. 00927 proc edit_categories {txt startpos endpos} { 00928 00929 variable categories 00930 variable current_category 00931 00932 # Get the current category from the text 00933 set current_category [string map {\{ {} \} {}} [$txt get $startpos $endpos]] 00934 00935 if {[winfo exists [set mnu $txt.categoryPopup]]} { 00936 destroy $mnu 00937 } 00938 00939 menu $mnu -tearoff 0 00940 00941 foreach category [lsort [array names categories]] { 00942 $mnu add radiobutton -label $categories($category) -variable plugins::current_category -value $category -command [list plugins::change_category $txt $startpos $endpos $category] 00943 } 00944 00945 lassign [$txt bbox $startpos] x y w h 00946 00947 tk_popup $mnu [expr [winfo rootx $txt] + $x] [expr [winfo rooty $txt] + ($y + $h)] 00948 00949 } 00950 00951 ###################################################################### 00952 # Changes the category 00953 proc change_category {txt startpos endpos category} { 00954 00955 $txt replace $startpos $endpos "\{$category\}" 00956 00957 } 00958 00959 ###################################################################### 00960 # Returns the index of the plugin that matches the given name if found; 00961 # otherwise, returns the empty string. 00962 proc get_plugin_index {name} { 00963 00964 variable registry 00965 variable registry_size 00966 00967 for {set i 0} {$i < $registry_size} {incr i} { 00968 if {$registry($i,name) eq $name} { 00969 return $i 00970 } 00971 } 00972 00973 return "" 00974 00975 } 00976 00977 ###################################################################### 00978 # Finds all of the registry entries that match the given action. 00979 proc find_registry_entries {type} { 00980 00981 variable registry 00982 00983 set plugin_list [list] 00984 foreach action [lsort -dictionary [array names registry *,action,$type,*]] { 00985 lassign [split $action ,] index 00986 if {$registry($index,selected)} { 00987 lappend plugin_list [concat $index $registry($action)] 00988 } 00989 } 00990 00991 return $plugin_list 00992 00993 } 00994 00995 ###################################################################### 00996 # Adds the menus to the given plugin menu. This is called after the 00997 # plugin menu is initially created. 00998 proc menu_add {mnu action} { 00999 01000 # Get the list of menu entries 01001 if {[llength [set entries [find_registry_entries $action]]] > 0} { 01002 $mnu add separator 01003 } 01004 01005 # Add each of the entries 01006 foreach entry $entries { 01007 lassign $entry index type hier do state 01008 menu_add_item $index $mnu $action [split $hier /] $type $do $state 01009 } 01010 01011 } 01012 01013 ###################################################################### 01014 # Adds menu item, creating all needed cascading menus. 01015 proc menu_add_item {index mnu action hier type do state} { 01016 01017 variable registry 01018 variable menu_vars 01019 01020 # If the type is a separator, we need to run the while loop one more time 01021 set force [expr {[lindex $type 0] eq "separator"}] 01022 01023 # Add cascading menus 01024 while {([set hier_len [llength [set hier [lassign $hier level]]]] > 0) || $force} { 01025 set sub_mnu [string tolower [string map {{ } _} $level]] 01026 if {![winfo exists $mnu.$sub_mnu]} { 01027 set new_mnu [menu $mnu.$sub_mnu -tearoff 0 -postcommand "plugins::menu_state $mnu.$sub_mnu $action"] 01028 $registry($index,interp) alias $new_mnu interpreter::widget_win $registry($index,name) $new_mnu 01029 $mnu add cascade -label $level -menu $mnu.$sub_mnu 01030 } 01031 set mnu $mnu.$sub_mnu 01032 if {$hier_len == 0} { 01033 set force 0 01034 } 01035 } 01036 01037 # Handle the state 01038 if {$state ne ""} { 01039 if {[catch { $registry($index,interp) eval $state } status]} { 01040 handle_status_error "menu_add_item" $index $status 01041 set state "disabled" 01042 } elseif {$status} { 01043 set state "normal" 01044 } else { 01045 set state "disabled" 01046 } 01047 } 01048 01049 # Add menu item 01050 switch [lindex $type 0] { 01051 command { 01052 $mnu add command -label $level -command [list $registry($index,interp) eval {*}$do] -state $state 01053 } 01054 checkbutton { 01055 set menu_vars([lindex $type 1]) [$registry($index,interp) eval set [lindex $type 1]] 01056 $mnu add checkbutton -label $level -variable plugins::menu_vars([lindex $type 1]) \ 01057 -command [list $registry($index,interp) eval {*}$do] -state $state 01058 trace variable plugins::menu_vars([lindex $type 1]) w "plugins::handle_menu_variable $index" 01059 } 01060 radiobutton { 01061 set menu_vars([lindex $type 1]) [$registry($index,interp) eval set [lindex $type 1]] 01062 $mnu add radiobutton -label $level -variable plugins::menu_vars([lindex $type 1]) \ 01063 -value [lindex $type 2] -command [list $registry($index,interp) eval {*}$do] -state $state 01064 trace variable plugins::menu_vars([lindex $type 1]) w "plugins::handle_menu_variable $index" 01065 } 01066 cascade { 01067 set new_mnu_name "$mnu.[string tolower [string map {{ } _} $level]]" 01068 set new_mnu [menu $new_mnu_name -tearoff 0 -postcommand "plugins::post_cascade_menu $index $do $new_mnu_name"] 01069 $registry($index,interp) alias $new_mnu interpreter::widget_win $registry($index,name) $new_mnu 01070 $mnu add cascade -label $level -menu $new_mnu 01071 } 01072 separator { 01073 $mnu add separator 01074 } 01075 } 01076 01077 } 01078 01079 ###################################################################### 01080 # Handles a cascade menu post command. 01081 proc post_cascade_menu {index do mnu} { 01082 01083 variable registry 01084 01085 # Recursively delete all of the items in the given menu 01086 menu_delete_cascade $mnu 01087 01088 # Call the plugins do command to populate the menu 01089 if {[catch { $registry($index,interp) eval $do $mnu } status]} { 01090 handle_status_error "post_cascade_menu" $index $status 01091 } 01092 01093 } 01094 01095 ###################################################################### 01096 # Recursively deletes all submenus of the given menu. 01097 proc menu_delete_cascade {mnu} { 01098 01099 # If the menu is empty, stop now 01100 if {[$mnu index end] ne "none"} { 01101 01102 # Recursively remove the children menus 01103 for {set i 0} {$i <= [$mnu index end]} {incr i} { 01104 if {[$mnu type $i] eq "cascade"} { 01105 menu_delete_cascade [set child_menu [$mnu entrycget $i -menu]] 01106 destroy $child_menu 01107 } 01108 } 01109 01110 # Delete all of the menu items 01111 $mnu delete 0 end 01112 01113 } 01114 01115 } 01116 01117 ###################################################################### 01118 # Deletes all of the menus in the plugins menu. 01119 proc menu_delete {mnu action} { 01120 01121 # Get the list of menu entries 01122 if {[llength [find_registry_entries $action]] > 0} { 01123 01124 while {1} { 01125 switch [$mnu type last] { 01126 "separator" { 01127 $mnu delete last 01128 return 01129 } 01130 "cascade" { 01131 menu_delete_cascade [$mnu entrycget last -menu] 01132 destroy [$mnu entrycget last -menu] 01133 $mnu delete last 01134 } 01135 default { 01136 $mnu delete last 01137 } 01138 } 01139 } 01140 01141 } 01142 01143 } 01144 01145 ###################################################################### 01146 # Updates the plugin menu state of the given menu. 01147 proc menu_state {mnu action} { 01148 01149 variable registry 01150 variable menus 01151 variable menu_vars 01152 01153 foreach entry [find_registry_entries $action] { 01154 lassign $entry index type hier do state 01155 set entry_mnu "" 01156 foreach {m a} [array get menus] { 01157 if {$a eq $action} { 01158 set entry_mnu $m 01159 } 01160 } 01161 if {[llength [set hier_list [split $hier /]]] > 1} { 01162 append entry_mnu ".[string tolower [string map {{ } _} [join [lrange $hier_list 0 end-1] .]]]" 01163 } 01164 if {$mnu eq $entry_mnu} { 01165 if {[catch { $registry($index,interp) eval $state } status]} { 01166 handle_status_error "menu_state" $index $status 01167 } elseif {$status} { 01168 $mnu entryconfigure [lindex $hier_list end] -state normal 01169 } else { 01170 $mnu entryconfigure [lindex $hier_list end] -state disabled 01171 } 01172 switch [lindex $type 0] { 01173 checkbutton { set menu_vars([lindex $type 1]) [$registry($index,interp) eval set [lindex $type 1]] } 01174 radiobutton { set menu_vars([lindex $type 1]) [$registry($index,interp) eval set [lindex $type 1]] } 01175 } 01176 } 01177 } 01178 01179 } 01180 01181 ###################################################################### 01182 # Adds to the list of all exposed procedures. 01183 proc add_all_exposed {} { 01184 01185 variable registry 01186 variable exposed 01187 01188 foreach entry [find_registry_entries "expose"] { 01189 foreach p [lassign $entry index] { 01190 if {![catch { $registry($index,interp) eval info procs $p } rc] && ($rc eq "::$p")} { 01191 set exposed($p) $index 01192 } else { 01193 handle_status_error "exposed" $index "Exposed proc $p does not exist" 01194 } 01195 } 01196 } 01197 01198 } 01199 01200 ###################################################################### 01201 # Adds all of the plugins to the list of available menus. 01202 proc add_all_menus {} { 01203 01204 variable menus 01205 01206 foreach {mnu action} [array get menus] { 01207 menu_add $mnu $action 01208 } 01209 01210 } 01211 01212 ###################################################################### 01213 # Adds all of the text bindings to all open text widgets. 01214 proc add_all_text_bindings {} { 01215 01216 foreach {txt tags} [gui::get_all_texts] { 01217 handle_text_bindings $txt $tags 01218 } 01219 01220 } 01221 01222 ###################################################################### 01223 # Adds all of the syntax files. 01224 proc add_all_syntax {} { 01225 01226 variable registry 01227 01228 foreach entry [find_registry_entries "syntax"] { 01229 lassign $entry index sfile 01230 set sfile [file join $::tke_dir plugins $registry($index,name) $sfile] 01231 syntax::add_syntax $sfile $registry($index,interp) 01232 } 01233 01234 } 01235 01236 ###################################################################### 01237 # Clears the list of all exposed procedures. 01238 proc delete_all_exposed {} { 01239 01240 variable exposed 01241 01242 array unset exposed 01243 01244 } 01245 01246 ###################################################################### 01247 # Clears everything from the given menu. 01248 proc delete_from_menu {mnu} { 01249 01250 variable menus 01251 01252 if {[info exists menus($mnu)]} { 01253 menu_delete $mnu $menus($mnu) 01254 } 01255 01256 } 01257 01258 ###################################################################### 01259 # Deletes all plugins from their respective menus. 01260 proc delete_all_menus {} { 01261 01262 variable menus 01263 01264 foreach {mnu action} [array get menus] { 01265 menu_delete $mnu $action 01266 } 01267 01268 } 01269 01270 ###################################################################### 01271 # Deletes all text bindings that were previously created. 01272 proc delete_all_text_bindings {} { 01273 01274 variable bound_tags 01275 01276 foreach {bt txts} [array get bound_tags] { 01277 foreach txt $txts { 01278 if {![winfo exists $txt]} continue 01279 if {[set index [lsearch -exact [set btags [bindtags $txt]] $bt]] != -1} { 01280 bindtags $txt [lreplace $btags $index $index] 01281 } 01282 if {[set index [lsearch -exact [set btags [bindtags $txt.t]] $bt]] != -1} { 01283 bindtags $txt.t [lreplace $btags $index $index] 01284 } 01285 } 01286 } 01287 01288 # Delete all of the bound tags 01289 array unset bound_tags 01290 01291 } 01292 01293 ###################################################################### 01294 # Removes the given syntax files. 01295 proc delete_all_syntax {} { 01296 01297 foreach entry [find_registry_entries "syntax"] { 01298 lassign $entry index sfile 01299 syntax::delete_syntax $sfile 01300 } 01301 01302 } 01303 01304 ###################################################################### 01305 # Called when the plugin menu is created. 01306 proc handle_plugin_menu {mnu} { 01307 01308 variable menus 01309 01310 # Add the menu to the list of menus to update 01311 set menus($mnu) menu 01312 01313 # Add the menu items 01314 menu_add $mnu menu 01315 01316 } 01317 01318 ###################################################################### 01319 # Adds any tab_popup menu items to the tab popup menu. 01320 proc handle_tab_popup {mnu} { 01321 01322 variable menus 01323 01324 # Add the menu to the list of menus to update 01325 set menus($mnu) tab_popup 01326 01327 # Add the menu items 01328 menu_add $mnu tab_popup 01329 01330 } 01331 01332 ###################################################################### 01333 # Adds any root_popup menu items to the given menu. 01334 proc handle_root_popup {mnu} { 01335 01336 variable menus 01337 01338 # Add the menu to the list of menus to update 01339 set menus($mnu) root_popup 01340 01341 # Add the menu items 01342 menu_add $mnu root_popup 01343 01344 } 01345 01346 ###################################################################### 01347 # Adds any dir_popup menu items to the given menu. 01348 proc handle_dir_popup {mnu} { 01349 01350 variable menus 01351 01352 # Add the menu to the list of menus to update 01353 set menus($mnu) dir_popup 01354 01355 # Add the menu items 01356 menu_add $mnu dir_popup 01357 01358 } 01359 01360 ###################################################################### 01361 # Adds any file_popup menu items to the given menu. 01362 proc handle_file_popup {mnu} { 01363 01364 variable menus 01365 01366 # Add the menu to the list of menus to update 01367 set menus($mnu) file_popup 01368 01369 # Add the menu items 01370 menu_add $mnu file_popup 01371 01372 } 01373 01374 ###################################################################### 01375 # Creates a bindtag on behalf of the user for the given text widget 01376 # and calls the associated procedure to have the bindings added. 01377 proc handle_text_bindings {txt tags} { 01378 01379 variable registry 01380 variable bound_tags 01381 01382 set ttags [bindtags $txt.t] 01383 set tpre_index [expr [lsearch -exact $ttags all] + 1] 01384 set tpost_index [lsearch -exact $ttags .] 01385 01386 array set ptags { 01387 pretext {} 01388 posttext {} 01389 } 01390 01391 # Allow all plugins to access, query, and modify text widgets 01392 foreach entry [find_registry_entries "*"] { 01393 lassign $entry index 01394 interpreter::add_ctext $registry($index,interp) $registry($index,name) $txt 01395 } 01396 01397 # Bind text widgets to tags 01398 foreach entry [find_registry_entries "text_binding"] { 01399 lassign $entry index type name bind_type cmd 01400 set bt "plugin__$registry($index,name)__$name" 01401 if {($bind_type eq "all") || ([lsearch $tags $bt] != -1)} { 01402 lappend ptags($type) $bt 01403 if {![info exists bound_tags($bt)]} { 01404 if {[catch { $registry($index,interp) eval $cmd $bt } status]} { 01405 handle_status_error "handle_text_bindings" $index $status 01406 } 01407 set bound_tags($bt) $txt 01408 } else { 01409 lappend bound_tags($bt) $txt 01410 } 01411 } 01412 } 01413 01414 # Set the bindtags 01415 if {[llength $ptags(posttext)] > 0} { 01416 set ttags [linsert $ttags $tpost_index {*}$ptags(posttext)] 01417 } 01418 if {[llength $ptags(pretext)] > 0} { 01419 set ttags [linsert $ttags $tpre_index {*}$ptags(pretext)] 01420 } 01421 bindtags $txt.t $ttags 01422 01423 } 01424 01425 ###################################################################### 01426 # Generically handles the given event. 01427 proc handle_event {event args} { 01428 01429 variable registry 01430 01431 foreach entry [find_registry_entries $event] { 01432 if {[catch { $registry([lindex $entry 0],interp) eval [lindex $entry 1] $args } status]} { 01433 handle_status_error "handle_event" [lindex $entry 0] $status 01434 } 01435 } 01436 01437 } 01438 01439 ###################################################################### 01440 # Called whenever the application is started. 01441 proc handle_on_start {} { 01442 01443 # Handle an application start 01444 handle_event "on_start" 01445 01446 } 01447 01448 ###################################################################### 01449 # Called whenever a file is opened in a tab. 01450 proc handle_on_open {file_index} { 01451 01452 handle_event "on_open" $file_index 01453 01454 } 01455 01456 ###################################################################### 01457 # Called whenever a file is saved. 01458 proc handle_on_save {file_index} { 01459 01460 handle_event "on_save" $file_index 01461 01462 } 01463 01464 ###################################################################### 01465 # Called whenever a file/folder is renamed. 01466 proc handle_on_rename {old_fname new_fname} { 01467 01468 handle_event "on_rename" $old_fname $new_fname 01469 01470 } 01471 01472 ###################################################################### 01473 # Called whenever a file is duplicated. 01474 proc handle_on_duplicate {old_fname new_fname} { 01475 01476 handle_event "on_duplicate" $old_fname $new_fname 01477 01478 } 01479 01480 ###################################################################### 01481 # Called whenever a file/folder is deleted. 01482 proc handle_on_delete {fname} { 01483 01484 handle_event "on_delete" $fname 01485 01486 } 01487 01488 ###################################################################### 01489 # Called whenever a file/folder is moved to the trash. 01490 proc handle_on_trash {fname} { 01491 01492 handle_event "on_trash" $fname 01493 01494 } 01495 01496 ###################################################################### 01497 # Called whenever a tab receives focus. 01498 proc handle_on_focusin {tab} { 01499 01500 handle_event "on_focusin" $tab 01501 01502 } 01503 01504 ###################################################################### 01505 # Called whenever a tab is closed. 01506 proc handle_on_close {file_index} { 01507 01508 variable registry 01509 variable bound_tags 01510 01511 handle_event "on_close" $file_index 01512 01513 # Delete the list of bound tags 01514 set txt [gui::get_file_info $file_index txt] 01515 foreach entry [find_registry_entries "text_binding"] { 01516 lassign $entry index type name bind_type cmd 01517 set bt "plugin__$registry($index,name)__$name" 01518 if {[info exists bound_tags($bt)] && ([set findex [lsearch $bound_tags($bt) $txt]] != -1)} { 01519 set bound_tags($bt) [lreplace $bound_tags($bt) $findex $findex] 01520 } 01521 } 01522 01523 } 01524 01525 ###################################################################### 01526 # Called whenever a tab is updated. 01527 proc handle_on_update {file_index} { 01528 01529 handle_event "on_update" $file_index 01530 01531 } 01532 01533 ###################################################################### 01534 # Called when the preferences file is loaded. This plugin should return 01535 # a list 01536 proc handle_on_pref_load {} { 01537 01538 variable registry 01539 01540 set prefs [list] 01541 01542 foreach entry [find_registry_entries "on_pref_load"] { 01543 if {[catch { $registry([lindex $entry 0],interp) eval [lindex $entry 1] } status]} { 01544 handle_status_error "handle_on_pref_load" [lindex $entry 0] $status 01545 } 01546 foreach {name value} $status { 01547 lappend prefs "Plugins/$registry([lindex $entry 0],name)/$name" $value 01548 } 01549 } 01550 01551 # Update the preferences namespace 01552 preferences::add_plugin_prefs $prefs 01553 01554 } 01555 01556 ###################################################################### 01557 # Called when the preferences window is created. This procedure is 01558 # responsible for creating the plugin preference frames. 01559 proc handle_on_pref_ui {w} { 01560 01561 variable registry 01562 01563 set plugins [list] 01564 01565 foreach entry [find_registry_entries "on_pref_ui"] { 01566 $w add [ttk::frame [set win $w.$registry([lindex $entry 0],name)]] 01567 scrolledframe::scrolledframe $win.f -yscrollcommand [list utils::set_yscrollbar $win.vb] 01568 scroller::scroller $win.vb -orient vertical -command [list $win.f yview] 01569 grid rowconfigure $win 0 -weight 1 01570 grid columnconfigure $win 0 -weight 1 01571 grid $win.f -row 0 -column 0 -sticky news 01572 grid $win.vb -row 0 -column 1 -sticky ns 01573 theme::register_widget $win.vb misc_scrollbar 01574 if {[catch { $registry([lindex $entry 0],interp) eval [lindex $entry 1] $win.f.scrolled } status]} { 01575 handle_status_error "handle_on_pref_ui" [lindex $entry 0] $status 01576 } else { 01577 lappend plugins $registry([lindex $entry 0],name) 01578 } 01579 } 01580 01581 return $plugins 01582 01583 } 01584 01585 ###################################################################### 01586 # Handles a file/text drop event. 01587 proc handle_on_drop {file_index type data} { 01588 01589 variable registry 01590 01591 set owned 0 01592 01593 foreach entry [find_registry_entries "on_drop"] { 01594 if {[catch { $registry([lindex $entry 0],interp) eval [lindex $entry 1] $file_index $type $data } status]} { 01595 handle_status_error "handle_on_drop" [lindex $entry 0] $status 01596 } elseif {![string is boolean $status]} { 01597 handle_status_error "handle_on_drop" [lindex $entry 0] "Callback procedure for handle_on_drop_enter did not return a boolean value" 01598 } elseif {$status} { 01599 set owned 1 01600 } 01601 } 01602 01603 return $owned 01604 01605 } 01606 01607 ###################################################################### 01608 # Called when the application is exiting. 01609 proc handle_on_quit {} { 01610 01611 # Handle the on_quit event 01612 handle_event "on_quit" 01613 01614 # Finally, write the plugin information file 01615 write_config 01616 01617 } 01618 01619 ###################################################################### 01620 # Called when the theme has changed. 01621 proc handle_on_theme_changed {} { 01622 01623 handle_event "on_theme_changed" 01624 01625 } 01626 01627 ###################################################################### 01628 # Called when a plugin is uninstalled. 01629 proc handle_on_uninstall {index} { 01630 01631 variable registry 01632 01633 # If the given event contains an "on_uninstall" action, run it. 01634 foreach {name action} [array get registry $index,action,on_uninstall,*] { 01635 if {[catch { $registry($index,interp) eval {*}$action } status]} { 01636 handle_status_error "on_uninstall" $index $status 01637 } 01638 } 01639 01640 } 01641 01642 ###################################################################### 01643 # Adds the VCS commands to the difference namespace. 01644 proc add_all_vcs_commands {} { 01645 01646 foreach entry [find_registry_entries "vcs"] { 01647 lassign $entry index name handles versions file_cmd diff_cmd find_version current_version version_log 01648 set ns ::diff::[string map {{ } _} [string tolower $name]] 01649 namespace eval $ns "proc name {} { return \"$name\" }" 01650 namespace eval $ns "proc type {} { return cvs }" 01651 namespace eval $ns "proc handles {fname} { return \[plugins::run_vcs $index $handles \$fname\] }" 01652 namespace eval $ns "proc versions {fname} { return \[plugins::run_vcs $index $versions \$fname\] }" 01653 namespace eval $ns "proc get_file_cmd {version fname} { return \[plugins::run_vcs $index $file_cmd \$fname \$version\] }" 01654 namespace eval $ns "proc get_diff_cmd {v1 v2 fname} { return \[plugins::run_vcs $index $diff_cmd \$fname \$v1 \$v2\] }" 01655 namespace eval $ns "proc find_version {fname v2 lnum} { return \[plugins::run_vcs $index $find_version \$fname \$v2 \$lnum\] }" 01656 namespace eval $ns "proc get_current_version {fname} { return \[plugins::run_vcs $index $current_version \$fname] }" 01657 namespace eval $ns "proc get_version_log {fname version} { return \[plugins::run_vcs $index $version_log \$fname \$version\] }" 01658 } 01659 01660 } 01661 01662 ###################################################################### 01663 # Removes the VCS commands from the diff namespace. 01664 proc delete_all_vcs_commands {} { 01665 01666 foreach entry [find_registry_entries "vcs"] { 01667 lassign $entry index name 01668 namespace delete ::diff::[string map {{ } _} [string tolower $name]] 01669 } 01670 01671 } 01672 01673 ###################################################################### 01674 # Runs the given VCS command. 01675 proc run_vcs {index cmd args} { 01676 01677 variable registry 01678 01679 if {[catch { $registry($index,interp) eval $cmd {*}$args } status]} { 01680 handle_status_error "run_vcs" $index $status 01681 return "" 01682 } 01683 01684 return $status 01685 01686 } 01687 01688 ###################################################################### 01689 # Returns file information titles to add. 01690 proc get_sidebar_info_titles {} { 01691 01692 set titles [list] 01693 set i 0 01694 01695 foreach entry [find_registry_entries "info_panel"] { 01696 lassign $entry index title copyable 01697 lappend titles $i $title $copyable 01698 incr i 01699 } 01700 01701 return $titles 01702 01703 } 01704 01705 ###################################################################### 01706 # Retrieves the file information for the given filename. 01707 proc get_sidebar_info_values {fname} { 01708 01709 variable registry 01710 01711 set values [list] 01712 set i 0 01713 01714 foreach entry [find_registry_entries "info_panel"] { 01715 lassign $entry index title copyable value_cmd 01716 if {[catch { $registry($index,interp) eval $value_cmd $fname } status]} { 01717 handle_status_error "get_sidebar_info_values" $index $status 01718 set status "" 01719 } 01720 lappend values $i $status 01721 incr i 01722 } 01723 01724 return $values 01725 01726 } 01727 01728 ###################################################################### 01729 # Returns true if the given name is exposed. 01730 proc is_exposed {name} { 01731 01732 variable exposed 01733 01734 return [info exists exposed($name)] 01735 01736 } 01737 01738 ###################################################################### 01739 # Executes the exposed procedure with the given arguments and returns 01740 # the value returned from the procedure. 01741 proc execute_exposed {name args} { 01742 01743 variable registry 01744 variable exposed 01745 01746 if {![info exists exposed($name)]} { 01747 return -code error "Attempting to execute a non-existent exposed proc" 01748 } 01749 01750 set index $exposed($name) 01751 01752 if {[catch { $registry($index,interp) eval $name $index $args } status]} { 01753 handle_status_error "execute_exposed" $index $status 01754 return -code error $status 01755 } else { 01756 return $status 01757 } 01758 01759 } 01760 01761 ###################################################################### 01762 # Show the iplugins directory in the sidebar. 01763 proc show_iplugins {} { 01764 01765 sidebar::add_directory [file join $::tke_home iplugins] -record 0 01766 01767 } 01768 01769 ###################################################################### 01770 # Returns true if a plugin export is currently possible; otherwise, returns 01771 # false. 01772 proc export_available {} { 01773 01774 set iplugins [file join $::tke_home iplugins] 01775 01776 # Get the currently selected file 01777 gui::get_info {} current txt fname 01778 01779 # If the given file exists in the iplugins directory, proceed with the export 01780 return [expr {[string compare -length [string length $iplugins] $iplugins $fname] == 0}] 01781 01782 } 01783 01784 ###################################################################### 01785 # Exports the plugin that is currently opened in the editor. 01786 proc export {} { 01787 01788 # If the export is not available, stop immediately 01789 if {![export_available]} { 01790 return 01791 } 01792 01793 # Get the currently selected file 01794 gui::get_info {} current txt fname 01795 set split_fname [file split $fname] 01796 set iplugin_index [lsearch $split_fname iplugins] 01797 set plugdir [file join {*}[lrange $split_fname 0 [expr $iplugin_index + 1]]] 01798 01799 # Perform the export 01800 plugmgr::export_win $plugdir 01801 01802 } 01803 01804 ###################################################################### 01805 # Recursively gathers a list of files to zip. 01806 proc get_file_list {abs {rel ""}} { 01807 01808 set file_list [list] 01809 01810 foreach item [glob -directory $abs *] { 01811 if {[file isdirectory $item]} { 01812 lappend file_list {*}[get_file_list $item [file join $rel [file tail $item]]] 01813 } elseif {[file isfile $item]} { 01814 lappend file_list [file join $rel [file tail $item]] 01815 } 01816 } 01817 01818 return $file_list 01819 01820 } 01821 01822 ###################################################################### 01823 # Exports the specified plugin as a .tkeplugz file. This filetype will 01824 # support drag-and-drop to install a given plugin. 01825 proc export_plugin {parent_win name odir} { 01826 01827 # Get the directory to export 01828 set idir [file join $::tke_home iplugins $name] 01829 01830 # If the directory does not exist return 0. 01831 if {![file exists $idir]} { 01832 return 0 01833 } 01834 01835 # Get the current working directory 01836 set pwd [pwd] 01837 01838 # Set the current working directory to the user themes directory 01839 cd [file dirname $idir] 01840 01841 # Get the list of files to use in list2zip 01842 set file_list [get_file_list $idir $name] 01843 01844 # Make sure there isn't a zipfile of the same name 01845 catch { file delete -force [file join $odir $name.tkeplugz] } 01846 01847 # Perform the archive 01848 if {[catch { zipper::list2zip [file dirname $idir] $file_list [file join $odir $name.tkeplugz] } rc]} { 01849 if {[catch { exec -ignorestderr zip -r [file join $odir $name.tkeplugz] $name } rc]} { 01850 tk_messageBox -parent $parent_win -icon error -type ok -default ok \ 01851 -message [format "%s %s" [msgcat::mc "Unable to zip plugin"] $name] 01852 } 01853 } 01854 01855 # Restore the current working directory 01856 cd $pwd 01857 01858 return 1 01859 01860 } 01861 01862 ###################################################################### 01863 # Opens a file browser to allow the user to select an installable plugin 01864 # file. 01865 proc import {} { 01866 01867 # Get the list of files to import from the user 01868 set ifiles [tk_getOpenFile -parent . -initialdir [gui::get_browse_directory] -filetypes {{{TKE Plugin File} {.tkeplugz}}} -defaultextension .tkeplugz -multiple 1] 01869 01870 # Perform the import for each selected file 01871 if {[llength $ifiles] > 0} { 01872 set success 1 01873 foreach ifile $ifiles { 01874 if {[import_plugin . $ifile] eq ""} { 01875 set success 0 01876 } 01877 } 01878 if {$success} { 01879 reload 01880 gui::set_info_message [msgcat::mc "Plugin import completed successfully"] 01881 } 01882 } 01883 01884 } 01885 01886 ###################################################################### 01887 # Imports the given plugin, copying the data to the user's home plugins 01888 # directory. 01889 proc import_plugin {parent_win fname} { 01890 01891 # Make sure that the plugins directory exists 01892 file mkdir [file join $::tke_home iplugins] 01893 01894 # If the directory exists, move it out of the way 01895 set odir [file join $::tke_home iplugins [file rootname [file tail $fname]]] 01896 if {[file exists $odir]} { 01897 file rename $odir $odir.old 01898 } 01899 01900 # Unzip the file contents 01901 if {[catch { zipper::unzip $fname [file dirname $odir] } rc]} { 01902 if {[catch { exec -ignorestderr unzip -u $fname -d [file dirname $odir] } rc]} { 01903 catch { file rename $odir.old $odir } 01904 tk_messageBox -parent $parent_win -icon error -type ok -default ok \ 01905 -message [format "%s %s" [msgcat::mc "Unable to unzip plugin"] $fname] -detail $rc 01906 return "" 01907 } 01908 } 01909 01910 # Remove the old file if it exists 01911 catch { file delete -force $odir.old } 01912 01913 # We need to set the file permissions to be readable 01914 foreach ifile [get_file_list $odir] { 01915 catch { file attributes [file join $odir $ifile] -permissions rw-r--r-- } 01916 } 01917 01918 return $odir 01919 01920 } 01921 01922 ###################################################################### 01923 # Returns the value of the given plugin attribute. 01924 proc get_header_info {plugin attr} { 01925 01926 variable registry 01927 variable registry_size 01928 01929 array set fields { 01930 display_name display_name 01931 name name 01932 author author 01933 email email 01934 website website 01935 version version 01936 trust_required treqd 01937 description description 01938 category category 01939 } 01940 01941 if {![info exists fields($attr)]} { 01942 return -code "Unsupported header field requested ($attr)" 01943 } 01944 01945 # Find the associated plugin and, when found, return the attribute value 01946 for {set i 0} {$i < $registry_size} {incr i} { 01947 if {$registry($i,name) eq $plugin} { 01948 return $registry($i,$fields($attr)) 01949 } 01950 } 01951 01952 return "" 01953 01954 } 01955 01956 ###################################################################### 01957 # Returns the list of files in the TKE home directory to copy. 01958 proc get_share_items {dir} { 01959 01960 return [list plugins.tkedat] 01961 01962 } 01963 01964 ###################################################################### 01965 # Called whenever the share directory changes. 01966 proc share_changed {dir} { 01967 01968 variable plugins_file 01969 01970 set plugins_file [file join $dir plugins.tkedat] 01971 01972 } 01973 01974 }