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 }
