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