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: ipanel.tcl
00020 # Author: Trevor Williams (phase1geo@gmail.com)
00021 # Date: 08/05/2017
00022 # Brief: Namespace for an information panel.
00023 ######################################################################
00024
00025 # msgcat::note Information panel displayed in the sidebar
00026
00027 namespace eval ipanel {
00028
00029 array set current {}
00030 array set widgets {}
00031
00032 ######################################################################
00033 # Create the needed images.
00034 proc create_images {} {
00035
00036 # If the images have already been created, return immediately
00037 if {[lsearch [image names] sidebar_info_close] != -1} {
00038 return
00039 }
00040
00041 theme::register_image sidebar_info_close bitmap sidebar -background \
00042 {msgcat::mc "Image displayed in sidebar information panel for closing the panel"} \
00043 -file [file join $::tke_dir lib images close.bmp] \
00044 -maskfile [file join $::tke_dir lib images close.bmp] \
00045 -foreground 1
00046
00047 theme::register_image sidebar_info_refresh bitmap sidebar -background \
00048 {msgcat::mc "Image displayed in sidebar information panel for refreshing content"} \
00049 -file [file join $::tke_dir lib images refresh.bmp] \
00050 -maskfile [file join $::tke_dir lib images refresh.bmp] \
00051 -foreground 1
00052
00053 theme::register_image sidebar_info_show bitmap sidebar -background \
00054 {msgcat::mc "Image displayed in sidebar information panel for showing file in sidebar"} \
00055 -file [file join $::tke_dir lib images show.bmp] \
00056 -maskfile [file join $::tke_dir lib images show.bmp] \
00057 -foreground 1
00058
00059 }
00060
00061 ######################################################################
00062 # Creates the information panel and returns the pathname to the panel.
00063 proc create {w args} {
00064
00065 variable widgets
00066 variable current
00067
00068 # Initialize variables
00069 set current($w) ""
00070
00071 array set opts {
00072 -closecmd ""
00073 -showcmd ""
00074 -lastfile ""
00075 }
00076 array set opts $args
00077
00078 # Create images if we need them
00079 create_images
00080
00081 # Create file info images
00082 image create photo $w,photo_preview
00083 image create bitmap $w,bitmap_preview
00084
00085 # Create file info panel
00086 set widgets($w,f) [frame $w -class info_panel]
00087 set widgets($w,fblank) [label $w.blank -image [image create bitmap -file [file join $::tke_dir lib images blank.bmp]]]
00088 set widgets($w,fbframe) [frame $w.bf]
00089 set widgets($w,frefresh) [label $w.bf.refresh -image sidebar_info_refresh]
00090 set widgets($w,v,image) [label $w.preview]
00091 set widgets($w,f,1) [frame $w.f1]
00092 set widgets($w,v,name) [label $w.name]
00093 set widgets($w,v,type) [label $w.type]
00094 set widgets($w,f,2) [frame $w.f2]
00095
00096 bind $widgets($w,frefresh) <Button-1> [list ipanel::update $w]
00097 bind $widgets($w,f) <Enter> [list grid $w.bf]
00098 bind $widgets($w,f) <Leave> [list grid remove $w.bf]
00099
00100 # Add tooltips to the buttons
00101 tooltip::tooltip $widgets($w,frefresh) [msgcat::mc "Update Info"]
00102
00103 if {$opts(-closecmd) ne ""} {
00104 set widgets($w,fclose) [label $w.bf.close -image sidebar_info_close]
00105 bind $widgets($w,fclose) <Button-1> [list ipanel::run_command $w $opts(-closecmd)]
00106 tooltip::tooltip $widgets($w,fclose) [msgcat::mc "Close Panel"]
00107 pack $widgets($w,fclose) -side right -padx 2 -pady 2
00108 }
00109
00110 pack $widgets($w,frefresh) -side right -padx 2 -pady 2
00111
00112 # If the user has provided a show command
00113 if {$opts(-showcmd) ne ""} {
00114 set widgets($w,fshow) [label $w.bf.show -image sidebar_info_show]
00115 bind $widgets($w,fshow) <Button-1> [list ipanel::run_command $w $opts(-showcmd)]
00116 tooltip::tooltip $widgets($w,fshow) [msgcat::mc "Show in Sidebar"]
00117 pack $widgets($w,fshow) -side right -padx 2 -pady 2
00118 }
00119
00120 grid rowconfigure $w 4 -weight 1
00121 grid columnconfigure $w 1 -weight 1
00122 grid $w.blank -row 0 -column 0 -sticky w -padx 2 -pady 4
00123 grid $w.bf -row 0 -column 1 -sticky ne -padx 2 -pady 2
00124 grid $w.preview -row 1 -column 0 -rowspan 4 -padx 2 -pady 2
00125 grid $w.name -row 2 -column 1 -sticky w
00126 grid $w.type -row 3 -column 1 -sticky w
00127
00128 grid remove $w.bf
00129
00130 set row 5
00131 foreach {lbl name copy} [list [msgcat::mc "Modified"] mod 1 [msgcat::mc "Attributes"] attrs 0 \
00132 "MD5" md5 1 "SHA-1" sha1 1 "SHA-224" sha224 1 "SHA-256" sha256 1 \
00133 [msgcat::mc "Counts"] cnts 0 [msgcat::mc "Read Time"] rtime 0 \
00134 [msgcat::mc "Version"] ver 1 [msgcat::mc "Favorite"] fav 0] {
00135 set widgets($w,l,$name) [label $w.l$name -text [format "%s:" $lbl]]
00136 set widgets($w,v,$name) [label $w.v$name -anchor w]
00137 if {$copy} {
00138 bind $widgets($w,v,$name) <Button-1> [list ipanel::copy_info $w $name]
00139 }
00140 grid $widgets($w,l,$name) -row $row -column 0 -sticky e
00141 grid $widgets($w,v,$name) -row $row -column 1 -sticky w
00142 incr row
00143 }
00144
00145 # Insert any file information plugin information
00146 # insert_info_panel_plugins $w
00147
00148 return $w
00149
00150 }
00151
00152 ######################################################################
00153 # Inserts the file information plugin labels into the file information panel.
00154 proc insert_info_panel_plugins {} {
00155
00156 variable widgets
00157
00158 foreach {name w} [array get widgets *,f] {
00159
00160 # Remove any existing plugins
00161 foreach name [array names widgets $w,l,plug*] {
00162 lassign [split $name ,] dummy1 dummy2 pname
00163 grid forget $widgets($w,l,$pname) $widgets($w,v,$pname)
00164 destroy $widgets($w,l,$pname) $widgets($w,v,$pname)
00165 }
00166
00167 # Forget the previous plugin widgets
00168 array unset widgets $w,*,plug*
00169
00170 # Figure out which row we should start inserting
00171 set row [lindex [grid size $w] 1]
00172
00173 # Get the colors
00174 set lfgcolor [$widgets($w,l,mod) cget -foreground]
00175 set lbgcolor [$widgets($w,l,mod) cget -background]
00176 set vfgcolor [$widgets($w,v,mod) cget -foreground]
00177 set vbgcolor [$widgets($w,v,mod) cget -background]
00178
00179 # Get any file information plugin entries
00180 foreach {index title copy} [plugins::get_sidebar_info_titles] {
00181
00182 # Create the widgets
00183 set widgets($w,l,plug$index) [label $w.pl$index -text "$title:" -foreground $lfgcolor -background $lbgcolor]
00184 set widgets($w,v,plug$index) [label $w.pv$index -anchor w -foreground $vfgcolor -background $vbgcolor]
00185
00186 # If the item is copyable, make it so now
00187 if {$copy} {
00188 bind $widgets($w,v,plug$index) <Button-1> [list ipanel::copy_info $w plug$index]
00189 }
00190
00191 # Insert them into the grid
00192 grid $w.pl$index -row $row -column 0 -sticky e
00193 grid $w.pv$index -row $row -column 1 -sticky w -columnspan 3
00194 incr row
00195
00196 }
00197
00198 }
00199
00200 }
00201
00202 ######################################################################
00203 # Updates the file information panel to match the current selections
00204 proc update {w {fname ""}} {
00205
00206 variable widgets
00207 variable current
00208
00209 # Update the current filename
00210 if {$fname ne ""} {
00211 set current($w) $fname
00212 }
00213
00214 # Get the list of attributes
00215 array set attrs [concat {*}[lmap a [preferences::get Sidebar/InfoPanelAttributes] {list $a 1}]]
00216
00217 # Always display the file name
00218 $widgets($w,v,name) configure -text [file tail $current($w)]
00219
00220 # Update all of the fields
00221 update_image $w [info exists attrs(preview)] [info exists attrs(imagesize)]
00222 update_type $w [info exists attrs(syntax)] [info exists attrs(filesize)]
00223 update_attrs $w [info exists attrs(permissions)] [info exists attrs(owner)] [info exists attrs(group)]
00224 update_counts $w [info exists attrs(linecount)] [info exists attrs(wordcount)] [info exists attrs(charcount)]
00225 update_rtime $w [info exists attrs(readtime)]
00226 update_checks $w [info exists attrs(md5)] [info exists attrs(sha1)] [info exists attrs(sha224)] [info exists attrs(sha256)]
00227 update_mod $w [info exists attrs(modified)]
00228 update_version $w [info exists attrs(version)]
00229 update_favorite $w [info exists attrs(favorite)]
00230
00231 # Insert plugin values
00232 foreach {index value} [plugins::get_sidebar_info_values $current($w)] {
00233 $widgets($w,v,plug$index) configure -text $value
00234 if {$value eq ""} {
00235 grid remove $widgets($w,l,plug$index) $widgets($w,v,plug$index)
00236 } else {
00237 grid $widgets($w,l,plug$index) $widgets($w,v,plug$index)
00238 }
00239 }
00240
00241 }
00242
00243 ######################################################################
00244 # Update the preview image and name fields.
00245 proc update_image {w preview imagesize} {
00246
00247 variable widgets
00248 variable current
00249
00250 set fname $current($w)
00251
00252 if {($preview || $imagesize) && [file isfile $fname]} {
00253 if {([file extension $fname] eq ".bmp") && ![catch { image create bitmap -file $fname } orig]} {
00254 $w,bitmap_preview configure -file $fname -foreground [utils::get_default_foreground]
00255 update_info_image $w $orig $w,bitmap_preview $preview $imagesize
00256 } elseif {![catch { image create photo -file $fname } orig]} {
00257 $w,photo_preview blank
00258 ::image_scale $orig 64 64 $w,photo_preview
00259 update_info_image $w $orig $w,photo_preview $preview $imagesize
00260 } else {
00261 grid remove $widgets($w,v,image)
00262 }
00263 } else {
00264 grid remove $widgets($w,v,image)
00265 }
00266
00267 }
00268
00269 ######################################################################
00270 # Handle output to the type field.
00271 proc update_type {w syntax filesize} {
00272
00273 variable widgets
00274 variable current
00275
00276 set fname $current($w)
00277
00278 if {($syntax || $filesize) && [file isfile $fname]} {
00279 if {$syntax} {
00280 lappend typelist [expr {[utils::is_binary $fname] ? [msgcat::mc "Binary"] : [syntax::get_default_language $fname]}]
00281 }
00282 if {$filesize} {
00283 lappend typelist [utils::get_file_size $fname]
00284 }
00285 $widgets($w,v,type) configure -text [join $typelist ", "]
00286 grid $widgets($w,v,type)
00287 } elseif {[file isdirectory $fname]} {
00288 $widgets($w,v,type) configure -text [msgcat::mc "Directory"]
00289 grid $widgets($w,v,type)
00290 } else {
00291 grid remove $widgets($w,v,type)
00292 }
00293
00294 }
00295
00296 ######################################################################
00297 # Update the file attributes field.
00298 proc update_attrs {w permissions owner group} {
00299
00300 variable widgets
00301 variable current
00302
00303 set fname $current($w)
00304
00305 if {$permissions || $owner || $group} {
00306 set attrlist [list]
00307 if {$permissions && ([set perms [utils::get_file_permissions $fname]] ne "")} {
00308 lappend attrlist $perms
00309 }
00310 if {$owner && ([set own [utils::get_file_owner $fname]] ne "")} {
00311 lappend attrlist $own
00312 }
00313 if {$group && ([set grp [utils::get_file_group $fname]] ne "")} {
00314 lappend attrlist $grp
00315 }
00316 if {$attrlist ne [list]} {
00317 $widgets($w,v,attrs) configure -text [join $attrlist ", "]
00318 grid $widgets($w,l,attrs) $widgets($w,v,attrs)
00319 } else {
00320 grid remove $widgets($w,l,attrs) $widgets($w,v,attrs)
00321 }
00322 } else {
00323 grid remove $widgets($w,l,attrs) $widgets($w,v,attrs)
00324 }
00325
00326 }
00327
00328 ######################################################################
00329 # Update line, word and character counts field.
00330 proc update_counts {w line word char} {
00331
00332 variable widgets
00333 variable current
00334
00335 set fname $current($w)
00336
00337 if {$line || $word || $char} {
00338 set attrlist [list]
00339 if {$line && ([set count [utils::get_file_count $fname line]] ne "")} {
00340 lappend attrlist "$count lines"
00341 }
00342 if {$word && ([set count [utils::get_file_count $fname word]] ne "")} {
00343 lappend attrlist "$count words"
00344 }
00345 if {$char && ([set count [utils::get_file_count $fname char]] ne "")} {
00346 lappend attrlist "$count chars"
00347 }
00348 if {$attrlist ne [list]} {
00349 $widgets($w,v,cnts) configure -text [join $attrlist ", "]
00350 grid $widgets($w,l,cnts) $widgets($w,v,cnts)
00351 } else {
00352 grid remove $widgets($w,l,cnts) $widgets($w,v,cnts)
00353 }
00354 } else {
00355 grid remove $widgets($w,l,cnts) $widgets($w,v,cnts)
00356 }
00357
00358 }
00359
00360 ######################################################################
00361 # Updates the readtime field.
00362 proc update_rtime {w readtime} {
00363
00364 variable widgets
00365 variable current
00366
00367 set fname $current($w)
00368
00369 if {$readtime} {
00370 if {[set words [utils::get_file_count $fname word]] ne ""} {
00371 set wpm [preferences::get Sidebar/InfoPanelReadingTimeWordsPerMinute]
00372 set mins [expr round( $words / $wpm.0 )]
00373 $widgets($w,v,rtime) configure -text "$mins minutes"
00374 grid $widgets($w,l,rtime) $widgets($w,v,rtime)
00375 } else {
00376 grid remove $widgets($w,l,rtime) $widgets($w,v,rtime)
00377 }
00378 } else {
00379 grid remove $widgets($w,l,rtime) $widgets($w,v,rtime)
00380 }
00381
00382 }
00383
00384 ######################################################################
00385 # Updates each of the checksum fields.
00386 proc update_checks {w md5 sha1 sha224 sha256} {
00387
00388 variable widgets
00389 variable current
00390
00391 set fname $current($w)
00392
00393 foreach {type enable} [list md5 $md5 sha1 $sha1 sha224 $sha224 sha256 $sha256] {
00394 if {$enable} {
00395 if {[set value [utils::get_file_checksum $fname $type]] ne ""} {
00396 $widgets($w,v,$type) configure -text $value
00397 grid $widgets($w,l,$type) $widgets($w,v,$type)
00398 } else {
00399 grid remove $widgets($w,l,$type) $widgets($w,v,$type)
00400 }
00401 } else {
00402 grid remove $widgets($w,l,$type) $widgets($w,v,$type)
00403 }
00404 }
00405
00406 }
00407
00408 ######################################################################
00409 # Updates the modified field.
00410 proc update_mod {w modified} {
00411
00412 variable widgets
00413 variable current
00414
00415 if {$modified} {
00416 file stat $current($w) finfo
00417 $widgets($w,v,mod) configure -text [clock format $finfo(mtime)]
00418 grid $widgets($w,l,mod) $widgets($w,v,mod)
00419 } else {
00420 grid remove $widgets($w,l,mod) $widgets($w,v,mod)
00421 }
00422
00423 }
00424
00425 ######################################################################
00426 # Updates the version field.
00427 proc update_version {w version} {
00428
00429 variable widgets
00430 variable current
00431
00432 set fname $current($w)
00433
00434 if {$version && [file isfile $fname]} {
00435 set cvs [diff::get_default_cvs $fname]
00436 if {[set ver [diff::${cvs}::get_current_version $fname]] ne ""} {
00437 $widgets($w,v,ver) configure -text $ver
00438 grid $widgets($w,l,ver) $widgets($w,v,ver)
00439 } else {
00440 grid remove $widgets($w,l,ver) $widgets($w,v,ver)
00441 }
00442 } else {
00443 grid remove $widgets($w,l,ver) $widgets($w,v,ver)
00444 }
00445
00446 }
00447
00448 ######################################################################
00449 # Updates the favorite field.
00450 proc update_favorite {w favorite} {
00451
00452 variable widgets
00453 variable current
00454
00455 set fname $current($w)
00456
00457 if {$favorite} {
00458 $widgets($w,v,fav) configure -text [expr {[favorites::is_favorite $fname] ? [msgcat::mc "Yes"]: [msgcat::mc "No"]}]
00459 grid $widgets($w,l,fav) $widgets($w,v,fav)
00460 } else {
00461 grid remove $widgets($w,l,fav) $widgets($w,v,fav)
00462 }
00463
00464 }
00465
00466 ######################################################################
00467 # Updates the file information image and related information.
00468 proc update_info_image {w orig image preview imagesize} {
00469
00470 variable widgets
00471
00472 # Update the image
00473 if {$preview} {
00474 $widgets($w,v,image) configure -image $image
00475 grid $widgets($w,v,image)
00476 } else {
00477 grid remove $widgets($w,v,image)
00478 }
00479
00480 # Calculate the syntax and name values
00481 if {$imagesize} {
00482 $widgets($w,v,name) configure -text "[$widgets($w,v,name) cget -text] ([image width $orig] x [image height $orig])"
00483 }
00484
00485 # Delete the original image
00486 image delete $orig
00487
00488 # Set the syntax to Unsupported
00489 $widgets($w,v,type) configure -text "Unsupported"
00490
00491 }
00492
00493 ######################################################################
00494 # Copies the information from the given label to the clipboard.
00495 proc copy_info {w name} {
00496
00497 variable widgets
00498
00499 # Copy the value to the clipboard
00500 clipboard clear
00501 clipboard append [$widgets($w,v,$name) cget -text]
00502
00503 # Get the information label name
00504 set name [string range [$widgets($w,l,$name) cget -text] 0 end-1]
00505
00506 # Output the copy status
00507 gui::set_info_message [format "%s %s" $name [msgcat::mc "value copied to clipboard"]]
00508
00509 }
00510
00511 ######################################################################
00512 # Returns true if the information panel contains information that can
00513 # be immediately viewed.
00514 proc is_viewable {w} {
00515
00516 variable current
00517
00518 return [expr {$current($w) ne ""}]
00519
00520 }
00521
00522 ######################################################################
00523 # Executes the given close command.
00524 proc close {w} {
00525
00526 variable current
00527
00528 # Clear current
00529 set current($w) ""
00530
00531 }
00532
00533 ######################################################################
00534 # Run the user show command.
00535 proc run_command {w cmd} {
00536
00537 variable current
00538
00539 uplevel #0 {*}$cmd [list $current($w)]
00540
00541 }
00542
00543 ######################################################################
00544 # Update the information panel widgets with the given theme information.
00545 proc update_theme {title_fgcolor value_fgcolor bgcolor active_bgcolor} {
00546
00547 variable widgets
00548
00549 # Colorize the frame widgets
00550 foreach w [array names widgets *,f*] {
00551 $widgets($w) configure -background $bgcolor
00552 }
00553
00554 # Colorize the title labels
00555 foreach w [array names widgets *,l,*] {
00556 $widgets($w) configure -foreground $title_fgcolor -background $bgcolor
00557 }
00558
00559 # Colorize the value labels
00560 foreach w [array names widgets *,v,*] {
00561 $widgets($w) configure -foreground $value_fgcolor -background $bgcolor
00562 if {[bind $widgets($w) <Button-1>] ne ""} {
00563 bind $widgets($w) <Enter> [list %W configure -background $active_bgcolor]
00564 bind $widgets($w) <Leave> [list %W configure -background $bgcolor]
00565 }
00566 }
00567
00568 # Colorize the close button background using the active color
00569 foreach btn [list fshow frefresh fclose] {
00570 foreach w [array names widgets *,$btn] {
00571 bind $widgets($w) <Enter> [list %W configure -background $active_bgcolor]
00572 bind $widgets($w) <Leave> [list %W configure -background $bgcolor]
00573 }
00574 }
00575
00576 # Tell anyone who cares that the theme changed
00577 foreach {name w} [array get widgets *,f] {
00578 event generate $w <<ThemeChange>> -data $bgcolor
00579 }
00580
00581 }
00582
00583 }
00584
