Directory entry megawidget edit
2018-5-18: Now on SourceForge: https://sourceforge.net/p/tcl-direntry/code/ci/default/tree/
bll 2017-9-20 This widget keeps the native directory name and the normalized directory name separate so that the native name is displayed and the normalized name is used in the -textvariable variable.Update: Figured out how to display the Mac OS X localized names. Mac OS X has some localized files such as 'French.strings' instead of 'fr.strings' (See $HOME/Music/iTunes/iTunes Media/Automatically Add to iTunes.localized/.localized/). I put a list of some of those names in, but don't know if it is complete. It is rather inefficient, but there doesn't seem to be a programmatic way to get these localized names from a command line program. I also plan on adjusting my file/directory choosers to use the routines made available here to display the localized names.Ideally, I would like a file normalize -keepsymlinks function so that the entered path stays intact on re-display. But hopefully that won't be a major problem. Change Logbll 2017-10-6: 1.2: fixed bugbll 2017-10-4: 1.1: added a check to make sure /usr/bin/plutil exists on the mac.bll 2017-9-21 I recommend using this widget with .widget state readonly and using a localized directory selection widget.
#!/usr/bin/tclsh
#
# Copyright 2017 Brad Lanam Walnut Creek CA
#
package require Tcl 8.5-
package require Tk
# direntry is a directory entry widget
# it will always display the native directory name,
# but will return the semi-normalized directory name.
proc ::direntry { nm args } {
direntryclass new $nm {*}$args
return $nm
}
namespace eval ::direntry {
variable vars
proc handler { entry args } {
$entry {*}$args
}
proc _parseplutil { fn dictv } {
upvar $dictv dict
set data [exec /usr/bin/plutil -p $fn]
set dataitems [split $data "\n"]
foreach {di} $dataitems {
if { [regexp {\s*"([^"]*)"\s=>\s"([^"]*)"$} $di all nm lnm] } {
dict set dict $nm $lnm
}
}
}
proc _localize { d tail } {
variable vars
set lfn [file join $d .localized]
set ltail $tail
if { [file exists $lfn] } {
if { [file isfile $lfn] } {
if { [dict exists $vars(sysdirmap) $tail] } {
set ltail [dict get $vars(sysdirmap) $tail]
}
} else {
set llist [list $vars(locale) $vars(mainlocale)]
if { [dict exists $vars(localenames) $vars(mainlocale)] } {
lappend llist [dict get $vars(localenames) $vars(mainlocale)]
}
set locale {}
foreach {l} $llist {
set lsfn [file join $lfn $l.strings]
if { [file exists $lsfn] } {
set locale $l
break
}
} ; # search for a locale file
if { $locale ne {} } {
set vars(tdict) [dict create]
::direntry::_parseplutil $lsfn vars(tdict)
regsub {\.localized$} $tail {} stail
if { [dict exists $vars(tdict) $stail] } {
set ltail [dict get $vars(tdict) $stail]
}
} ; # found a matching locale
} ; # the localization file is a directory
} ; # if there is a localization file
return $ltail
}
proc _macosxDispProcess { d } {
variable vars
if { $d eq "/" || $d eq {} || $d eq "." } {
return $d
}
if { [dict exists $vars(cache) $d] } {
return [dict get $vars(cache) $d]
}
set dn [file dirname $d]
set tail [file tail $d]
set dd [file join [direntry::_macosxDispProcess $dn] \
[direntry::_localize $d $tail]]
dict set vars(cache) $d $dd
return $dd
}
proc display { d } {
variable vars
set tslash false
if { [string length $d] > 1 && [string match {*[/\\]} $d] } {
# file nativename strips trailing slashes
set tslash true
}
set d [file nativename $d]
if { $tslash && ! [string match {*[/\\]} $d] } {
append d $vars(sep)
}
if { $::tcl_platform(os) eq "Darwin" &&
[file exists /usr/bin/plutil] } {
set d [::direntry::_macosxDispProcess $d]
} ; # if mac os x
return $d
}
proc init { } {
variable vars
set vars(sysdirmap) [dict create]
set vars(cache) [dict create]
set vars(localenames) [dict create]
set vars(sep) /
if { $::tcl_platform(platform) eq "windows" } {
set vars(sep) \\
}
# only mac os x has a brain-dead method of localization
if { $::tcl_platform(os) eq "Darwin" } {
set locale {}
if { $locale eq {} } {
# get the list of the user's preferred languages
set data [exec defaults read NSGlobalDomain AppleLanguages]
# only want the first
regsub {^[^"]*"} $data {} locale
regsub {".*} $locale {} locale
regsub -- {-} $locale {_} locale
# don't know if it possible for this list to by empty.
# defaults read -g AppleLocale could also be used to
# get the system locale.
}
regsub {\.UTF-8$} $locale {} vars(locale)
set vars(mainlocale) [string range $locale 0 1]
# get the list of system translations
set sfldir {/System/Library/CoreServices/SystemFolderLocalizations}
set sflocale {}
foreach {l} [list $vars(locale) $vars(mainlocale)] {
if { [file exists [file join $sfldir $l.lproj]] } {
set sflocale $l.lproj
break
}
}
if { $sflocale ne {} } {
set sflsfn [file join $sfldir $sflocale SystemFolderLocalizations.strings]
::direntry::_parseplutil $sflsfn vars(sysdirmap)
}
# mac os x also has some non-locale based naming
# no idea if this list is complete.
dict set vars(localenames) nl Dutch
dict set vars(localenames) en English
dict set vars(localenames) fr French
dict set vars(localenames) de German
dict set vars(localenames) it Italian
dict set vars(localenames) ja Japanese
dict set vars(localenames) sp Spanish
}
}
init
}
::oo::class create ::direntryclass {
constructor { nm args } {
my variable vars
set vars(entry.disp) {}
set vars(widget) [ttk::entry $nm]
$vars(widget) configure -textvariable [self]::vars(entry.disp)
set vars(entry) ${nm}_direntry
rename $vars(widget) ::$vars(entry)
interp alias {} $vars(widget) {} ::direntry::handler [self]
set nm $vars(widget)
uplevel 2 [list $nm configure {*}$args]
bind $vars(widget) <Destroy> [list [self] destruct]
}
method destruct { } {
my variable vars
interp alias {} $vars(widget) {}
my _stoptexttrace
my _stopdisptrace
[self] destroy
}
method startdisptrace { args } {
my variable vars
trace add variable vars(entry.disp) write [list [self] settextvar]
}
method _stopdisptrace { } {
my variable vars
trace remove variable vars(entry.disp) write [list [self] settextvar]
}
method _starttexttrace { args } {
my variable vars
set k -textvariable
if { [info exists vars($k)] && [info exists $vars($k)] } {
trace add variable $vars($k) write [list [self] setdispvar]
}
}
method _stoptexttrace { } {
my variable vars
set k -textvariable
if { [info exists vars($k)] && [info exists $vars($k)] } {
trace remove variable $vars($k) write [list [self] setdispvar]
}
}
method get { } {
my variable vars
if { [info exists vars(-textvariable)] &&
[info exists $vars(-textvariable)] } {
set rv [set $vars(-textvariable)]
}
}
method setdispvar { args } {
my variable vars
my _stopdisptrace
set vars(entry.disp) [::direntry::display [set $vars(-textvariable)]]
my startdisptrace
}
method settextvar { args } {
my variable vars
if { [info exists vars(-textvariable)] } {
my _stoptexttrace
set $vars(-textvariable) [file normalize $vars(entry.disp)]
my _starttexttrace
}
}
method unknown { args } {
my variable vars
set nm $vars(entry)
return [uplevel 2 [list $nm {*}$args]]
}
method cget { key } {
my variable vars
set rv {}
if { $key eq "-textvariable" } {
if { [info exists vars($key)] } {
set rv $vars($key)
}
} else {
set rv [$vars(entry) cget $key]
}
return $rv
}
method configure { args } {
my variable vars
foreach {k v} $args {
if { $k eq "-textvariable" } {
set fqv {}
if { [string match {::*} $v] } {
set fqv $v
}
if { $fqv eq {} } {
set fqv [uplevel 2 [list namespace which -variable $v]]
if { $fqv eq {} } {
set ns [uplevel 2 [list namespace current]]
set fqv $ns$v
if { [string match ::::* $fqv] } {
set fqv [string range $fqv 2 end]
}
}
}
if { [info exists vars($k)] && $vars($k) ne $fqv } {
my _stoptexttrace
}
set vars($k) $fqv
if { ! [info exists $vars($k)] } {
set $vars($k) {}
}
my setdispvar
my _starttexttrace
} else {
set nm $vars(entry)
uplevel 2 [list $nm configure $k $v]
}
}
return -code ok
}
}
package provide direntry 1.2
