** Directory entry megawidget **

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.

<<discussion>>Change Log
[bll] 2017-10-6: 1.2: fixed bug

[bll] 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.
<<discussion>>

======
#!/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
======

<<categories>>Widget | Megawidget