NetNews Usenet Archive 1993 #3/NN_1993_3.iso/spool/comp/lang/tcl/2470

Text File | 1993-01-25 | 12.3 KB | 437 lines

Newsgroups: comp.lang.tcl
Path: sparky!uunet!eco.twg.com!twg.com!news
From: "David Herron" <[e-mail]>
Subject: File browser `object' and new version of interp module
Message-ID: <[e-mail]>
Sensitivity: Personal
Encoding:  417 TEXT , 4 TEXT
Sender: [e-mail] (USENET News System)
Conversion: Prohibited
Organization: The Wollongong Group, Inc., Palo Alto, CA
Conversion-With-Loss: Prohibited
Date: Mon, 25 Jan 1993 18:02:40 GMT
Lines: 422

Greetings!  I'd been planning on posting this anyway, regardless of
my message last week.  Included in this posting is the file browser
module I've written over the last week or so.  The current source for the
interp module is large enough I want to hold off until a couple people
request its posting (it's >30K of source right now -- compiles to ~8K
of object on a SPARC with gcc v2.3.1; one job to do soon is seeing how
much of that is *necessary*).

My scheme for doing objects is as follows:

- The class definition is stored in its own interpretor.  It contains
  the procedures defining the class, and any variables/constants necessary
  to the class.

- When creating a new instance of a class you call the `new' procedure
  in the class.  This is/should-be the only time that interpretor is
  used for any execution.

- `new' creates a new interpretor.  Then to copy the `methods' over
  it creates a command in the new interpretor which `chains' to the
  command in the `class' interpretor (except that the execution happens
  within the context of the current (new) interpretor).

- A few new commands are created, and `exit' is overriden to just
  kill the interpretor rather than exit the process.
  The `unknown' command passes anything unknown either to the "parent"
  interpretor (allows for creating aggregate objects) or the "main"
  interpretor.  Since I expect that `unknown' will happen frequently
  it is coded in C.

- PROBLEM: Since callbacks from widgets happen in the "main" interpretor
  there must be easy access to there so that the widgets can be created
  over there.  A command, MainInterp, exists to pass commands there.

The above should be enough for y'all to appreciate the following source.
I have created a mailing list for discussing the interp module.  To
subscribe, send mail to [e-mail] and set your Subject:
line to "listserv subscribe interp".  I will soon make these file available
from an e-mailable archive server at the same address.  Thanks to the
guys at EITech for creating such a nifty tool (servicemail)!

First is my test program which also shows how to use the file
browser object:

-----------------------------> Begin `tfb'
source fileBrowserC.tcl

option add *Listbox.relief      sunken
option add *Entry.relief        sunken
option add *Text.relief         sunken
option add *Scrollbar.relief    sunken

option add *Listbox.exportSelection     false
option add *Entry.exportSelection       false
option add *Radiobutton.anchor          w

wm minsize . 1 1

interp MainInterp

set fb1 [FileBrowserClass new]
$fb1 MakeWidgets .fb
pack append . .fb { top fill expand }
$fb1 {
        setDirectory "/tmp"
        setPattern   "*"
        changeDirectory
#       MainInterp destroy $hlpBtn

proc okCommand {} {
        global pathEntry filEntry
        set f "[MainInterp $pathEntry get]/[MainInterp $filEntry get]"
        if {$f != "/"} { puts stdout "$f" }
        MainInterp destroy .
}

proc cancelCommand {} { MainInterp destroy . }
}
------------------------------> End `tfb'

And second is the object itself (a convention which might be useful
is to end files which define a `class' with C.tcl rather than
just .tcl):

------------------------------> Begin fileBrowserC.tcl

# $Id: fileBrowserC.tcl,v 1.1 1993/01/25 06:32:14 david Exp $
# fileBrowserC.tcl - File Browser class definition.
#
# AUTHOR: David Herron <[e-mail] (home)>, <[e-mail] (work)>
#
# $Log: fileBrowserC.tcl,v $
# Revision 1.1  1993/01/25  06:32:14  david
# Initial revisions of the interp module, documentation, and file browser.
#
#
#
# The file browser continually presents the contents of a particular
# directory, with the goal of selecting a file.  The user is able to
# change the current directory at will.  The current list of files can
# be limited with a pattern, and the pattern can be modified at any
# time by the user.  Once a file is selected the browser goes away,
# and calls the okCommand.  The cancel button calls cancelCommand, and
# the help button calls helpCommand.
#
# Each place where a path name is shown there are two entry
# boxes.  One for the path component, and the other for
# the file component.  Two such places are shown, one for
# the current directory and file pattern.  The other for
# the last selected file.
#
# METHODS:
#
# new
#
#    Create a new fileBrowser instance.
#
# delete
#
#    Delete a fileBrowser.
#
# MakeWidgets
#
#    Create the visual components.
#
# setDirectory dirString
#
#    Change directory to the named one.  If dirString ends in ".."
#    then go to the parent.
#
# changeDirectory
#
#    Changes directory to the one stored in $dirEntry.  Finds
#    the files matching the pattern in $patEntry.  Displays
#    all directories there in the directory list, and all matching
#    files in the file list.
#
# setPattern newpat
#
#    Sets the text in $patEntry.
#
# setFile file
#
#    Sets the selected file to be the path from the current
#    directory, and the file name passed in.
#
#

if ![interp exists FileBrowserClass] {

interp new FileBrowserClass

FileBrowserClass {

proc new {} {
    global fileb_count
    if ![info exists fileb_count] {set fileb_count 0}
    incr fileb_count
    set name "fileb$fileb_count"
    interp new $name

    foreach cmd {    new delete MakeWidgets isModal setDirectory
            changeDirectory
            setPattern setFile rescan getDirectory
            getPattern getFile doubleCommand okCommand
            cancelCommand helpCommand
        } { $name -chainCommand FileBrowserClass $cmd }

    return $name
}

proc delete {} { exit }

proc MakeWidgets top {
    global topFrame patFrame lstFrame filFrame cmdFrame \
        patLabel dirEntry slashLabel patEntry \
        dirList dirScroll filList filScroll \
        filLabel pathEntry filslashLabel filEntry \
        okBtn canBtn travBtn hlpBtn

    global thisInterpretor

    set topFrame ${top}
    set patFrame ${top}.pat
    set lstFrame ${top}.lst
    set filFrame ${top}.fil
    set cmdFrame ${top}.cmd

    MainInterp frame $topFrame
    MainInterp frame $patFrame
    MainInterp frame $lstFrame
    MainInterp frame $filFrame
    MainInterp frame $cmdFrame
    MainInterp pack append  $topFrame \
                $patFrame {top fillx} \
                $lstFrame {top fill expand} \
                $filFrame {top fillx} \
                $cmdFrame {top fillx}

    set patLabel   ${patFrame}.l
    set dirEntry   ${patFrame}.dir
    set slashLabel ${patFrame}.slash
    set patEntry   ${patFrame}.pat

    MainInterp label $patLabel -text "Pattern"
    MainInterp entry $dirEntry
    MainInterp label $slashLabel -text "/"
    MainInterp entry $patEntry
    MainInterp pack append  $patFrame \
                $patLabel   {left fillx} \
                $dirEntry   {left fillx expand} \
                $slashLabel {left fillx} \
                $patEntry   {left fillx expand}

    set dirList    ${lstFrame}.dl
    set dirScroll    ${lstFrame}.ds
    set filList    ${lstFrame}.fl
    set filScroll    ${lstFrame}.fs

    MainInterp scrollbar $dirScroll -command        "$dirList   yview"
    MainInterp listbox   $dirList     -yscrollcommand "$dirScroll set"
    MainInterp scrollbar $filScroll -command        "$filList   yview"
    MainInterp listbox   $filList     -yscrollcommand "$filScroll set"

    MainInterp pack append  $lstFrame \
                $dirList   {left fill expand} \
                $dirScroll {left filly} \
                $filList   {left fill expand} \
                $filScroll {left filly}

    set filLabel ${filFrame}.l
    set pathEntry ${filFrame}.p
    set filslashLabel ${filFrame}.sl
    set filEntry ${filFrame}.e

    MainInterp label $filLabel -text "File"
    MainInterp entry $pathEntry
    MainInterp label $filslashLabel -text "/"
    MainInterp entry $filEntry
    MainInterp pack append  $filFrame \
                $filLabel {left fillx} \
                $pathEntry {left fillx expand} \
                $filslashLabel {left fillx} \
                $filEntry {left fillx expand}

    set okBtn   ${cmdFrame}.ok
    set canBtn  ${cmdFrame}.can
    set travBtn ${cmdFrame}.trav
    set hlpBtn  ${cmdFrame}.hlp

    MainInterp button $okBtn   -text "OK" \
                   -command "$thisInterpretor okCommand"
    MainInterp button $canBtn  -text "Cancel" \
                   -command "$thisInterpretor cancelCommand"
    MainInterp button $travBtn -text "Change Directory" \
                   -command "$thisInterpretor changeDirectory"
    MainInterp button $hlpBtn  -text "Help" \
                   -command "$thisInterpretor helpCommand"

    MainInterp pack append  $cmdFrame \
                $okBtn   {left fillx expand} \
                $canBtn  {left fillx expand} \
                $travBtn {left fillx expand} \
                $hlpBtn  {left fillx expand}


    bind $dirEntry <Return> "$thisInterpretor {
            setDirectory \[$dirEntry get\]
            changeDirectory
        }
        $travBtn flash
        "
    bind $patEntry <Return> \
        "$thisInterpretor changeDirectory; $travBtn flash"

    bind $filEntry <Return> \
        "$okBtn flash; update; $thisInterpretor okCommand"


    # Override the unaddorned <1> bindings so that we get
    # notified of any clicks.  This unfortunately means that
    # if the default binding were to change we'd have to be
    # aware of that and change it here.

    MainInterp bind $dirList <1> "
        %W select from \[%W nearest %y\]
        $thisInterpretor setDirectory \
            \[%W get \[lindex \[%W curselection\] 0\]\]
    "
    MainInterp bind $dirList <Double-Button-1> "
        %W select from \[%W nearest %y\]
        $thisInterpretor setDirectory \
            \[%W get \[lindex \[%W curselection\] 0\]\]
        $thisInterpretor changeDirectory
        $travBtn flash
    "
    MainInterp bind $filList <1> "
        %W select from \[%W nearest %y\]
        $thisInterpretor setFile \
            \[%W get \[lindex \[%W curselection\] 0\]\]
    "
    MainInterp bind $filList <Double-Button-1> "
        %W select from \[%W nearest %y\]
        $thisInterpretor setFile \
            \[%W get \[lindex \[%W curselection\] 0\]\]
        $thisInterpretor okCommand
    "

    return $topFrame
}

# setDirectory - Set the given directory into $dirEntry.  If the last
# component is ".." then strip it & its parent off.  If the length of
# the whole thing is too short when stripping away the ".."  then assume
# we've gone to/through the root and change to `/'.
#
# If the first component is "." then we expand that to be [pwd].
#
# BUG(let): If the string is something weird (like `a/..') then
# the result is `/'.


proc setDirectory dir {
    global dirEntry
 catch {MainInterp $dirEntry delete 0 end}
    set dl [split $dir "/"]
    if {[lindex $dl 0] == "."} {
        set s [split [pwd] "/"]
        foreach d [lrange $dl 1 end] {lappend s $d}
        set dl $s
        set dlen [llength $dl]
        set dir "/[join [lrange $dl 1 [expr $dlen-1]] /]"
    } else {
        set dlen [llength $dl]
    }
    if {[lindex $dl [expr $dlen-1]] == ".."} {
        if {$dlen <= 3} {
            set dir "/"
        } else {
            set dir "/[join [lrange $dl 1 [expr $dlen-3]] /]"
        }
    }
    MainInterp $dirEntry insert end $dir
}

proc changeDirectory {} {
    global dirEntry patEntry dirList filList

    set newDir  [MainInterp $dirEntry get]
    set pattern [MainInterp $patEntry get]

    if {[catch {set list [glob "${newDir}/*"]}] != 0} {
            set list ""
    }
    if {$newDir == "/"} {
        set dirs [list "/.."]
    } else {
        set dirs [list "$newDir/.."]
    }
    set files ""
    foreach f $list {
        if {[file isdirectory $f]}      {
            lappend dirs  $f
            continue
        }
        if {[string match $pattern $f]} {
            set fl [split $f "/"]
            # This should've been just [lindex $fl end]
            set end [expr [llength $fl]-1]
            lappend files [lindex $fl $end]
        }
    }

    catch         {MainInterp $dirList delete 0 end}
    foreach d $dirs  {MainInterp $dirList insert end $d}
    catch          {MainInterp $filList delete 0 end}
    foreach f $files {MainInterp $filList insert end $f}
}

proc setPattern newpat {
    global patEntry
 catch {MainInterp $patEntry delete 0 end}
    MainInterp $patEntry insert end $newpat
    changeDirectory
}

proc setFile file {
    global filEntry pathEntry dirEntry
 catch {MainInterp $filEntry delete 0 end}
    MainInterp $filEntry insert end $file
 catch {MainInterp $pathEntry delete 0 end}
    MainInterp $pathEntry insert end [MainInterp $dirEntry get]
}

# proc getDirectory {} {
# }

# proc getPattern {} {
# }

# proc getFile {} {
# }

proc okCommand {} {
}

proc cancelCommand {} {
}

proc helpCommand {} {
}

}
}
# END: if ![interp exists FileBrowserClass]

------------------------------> End `fileBrowserC.tcl'

<- David Herron <[e-mail]> (work) <[e-mail]> (home)
<-
<- "That's our advantage at Microsoft; we set the standards and we can change them."
<- Karen Hargrove of Microsoft quoted in the Feb 1993 Unix Review editorial.