Updated 2011-12-11 17:13:15 by dkf

Richard Suchenwirth 2003-03-03 - Here is an enhanced development snapshot of iFile: a little file system browser - see that page for detailed explanations - I stripped lengthy comments from the source for faster editing. Many new features, the biggest chunk being proc introspection. No warranties, but enjoy!

In place of the files font_ce.txt (see Font families workaround) and puts_ce.txt (see puts workaround) sourced below, one might of course just include them here:
 if ![llength [info command ::tk::font]] {
    rename font ::tk::font
    proc font {cmd args} {
       switch -- $cmd {
          f - fa - fam - families {
            list Bookdings {Courier New}\
              Frutiger Tahoma\
              {Bitstream Cyberbit}\
              {MS Gothic} Sorawin
          default {
             eval ::tk::font $cmd $args
 proc redef_puts w {
    set ::putsw $w
    if ![llength [info command ::tcl::puts]] {
       rename puts ::tcl::puts
       proc puts args {
          set la [llength $args]
          if {$la<1 || $la>3} {
             error "usage: puts ?-nonewline? ?channel? string"
          set nl \n
          if {[lindex $args 0]=="-nonewline"} {
             set nl ""
             set args [lrange $args 1 end]
          if {[llength $args]==1} {
             set args [list stdout $args]
          foreach {channel s} $args break
          set s [join $s] ;# (1) prevent braces at leading/tailing spaces
          if {$channel=="stdout" || $channel=="stderr"} {
             $::putsw insert end $s$nl
          } else {
             set cmd ::tcl::puts
             if {$nl==""} {lappend cmd -nonewline}
             lappend cmd $channel $s
             eval $cmd

#Title: iFile - a little file system browser
 set version 1.0
 set g(about) " iFile $version:
   a little file system explorer

 Richard Suchenwirth, Konstanz 2003
 Tcl/Tk:    [info patchlevel]
 Exec:      [info nameofexecutable]
 BWidget: [package require BWidget]
 #set dir [file dir [info script]]
 #source [file join $dir font_ce.txt]
 #source [file join $dir puts_ce.txt]
 set g(font) {Tahoma 7}
 option add *Font $g(font)
 set g(ufont) {{Bitstream Cyberbit} 10}
 option add *BorderWidth 1
 option add *padY 0
 set g(sortedby) [set g(sortby) Name]

 proc drawTree {w} {
    $w insert end root _ -text / \
       -drawcross allways -image $::g(folder)
    openDir $w _
    $w itemconfigure _ -open 1
 proc openDir {w node} {
    set dc [$w itemcget $node -drawcross]
    if {$dc=="allways"} {
       set path [getPath $w $node]
       cd $path
       set dirs [glob -nocomp -type d * .??*]
       set parent $node
       foreach dir [lsort -unique -dic $dirs] {
          regsub -all {[^A-Za-z0-9]}\
             $path/$dir _ node
          if [llength [glob -noc -type d \
                [file join $path $dir *]]] {
             set dc allways
          } else {set dc never}
          $w insert end $parent $node -text $dir\
             -drawcross $dc -image $::g(folder)
       $w itemconfigure $parent \
          -drawcross auto
    set g(marked) ""
 proc getPath {w node} {
   set res ""
   while {$node != "root"} {
         set res [$w itemcget $node -text]/$res
         set node [$w parent $node]
   string range $res 1 end ;# avoid leading //
 proc selectDir {w dir} {
    global g
    if ![file exists $dir] {
       set dir [getPath $w $dir]
    cd  $dir
    wm title . [set g(2) [pwd]]
    $g(lb) delete [$g(lb) items]
    set mode -dic
    switch -- $g(sortby) {
        Name {set index 1}
        Type {set index 0}
        Size {set index 3; set mode -integer}
        Date {set index 5}
    set n -1
    set dirs ""
    foreach i [glob -noc -type d *] {
       set t [list . [format %-14s $i] -]
       lappend t [llength [glob -noc $i/*]] files
       lappend t [dateTime [file mtime $i]]
       lappend dirs $t
    foreach i [lsort $mode $g(dir) -index $index $dirs] {
       set t [join [lrange $i 1 end]]
       $g(lb) insert end  [incr n] \
          -image $g(folder) -text [string map {" - " \t} $t]
    set files {}
    foreach i [glob -noc -type f $g(filter)] {
       set size [format %5d [file size $i]]
       lappend files [list [file extension $i] \
            [format %-14s $i] - $size B\
            [dateTime [file mtime $i]]]
    foreach i [lsort $mode $g(dir) -index $index $files] {
       set t [join [lrange $i 1 end]]
       $g(lb) insert end [incr n]\
          -image $g([fileimage [lindex $i 0]]) \
          -text [string map {" - " \t} $t]
    .n raise 2
 $g(lb) bindImage <1> [list  after 9 selectFile $g(lb)]
 $g(lb) bindText <ButtonRelease-1> [list  after 9 markFile $g(lb)]
 $g(lb) bindText    <Double-1> [list  after 9 selectFile $g(lb)]
   set g(filterCmd) selectDir
 proc fileimage f {
    switch -- [file extension $f] {
    .gif - .ppm - .xbm {return palette}
    default {return file}

When a file is tapped on, a displayer is selected depending on directory attribute or extension:
 proc selectFile {w item} {
    global g
    set fn [$w itemcget $item -text]
    regexp {(.+?) *\t} $fn -> fn
    if [file isdir $fn] {
       set g(filter) *
       selectDir $g(tree) [file join [pwd] $fn]
    $g(text) delete 1.0 end
    switch -- [file extension $fn] {
       .txt - .tcl - .cfg - .htm {set t [readFile $fn]}
       .gif - .ppm {
         set t [render $fn $g(text) photo]
       .xbm {
       set t [render $fn $g(text) bitmap]
       default {set t [$g(unk) $fn]}
    if {$g(enc) != [encoding system]} {
       $g(text) config -font $g(ufont) \
          -height 14 -width 30
    } else {
       $g(text) config -font $g(font) \
          -height 21 -width 43
    $g(text) insert end $t
    focus $g(text)
    wm title . [set g(3) $fn]
    .n raise 3
 proc hexdump fn {
    set res ""
    set fp [open $fn]
    fconfigure $fp -translation binary
    for {set i 0} {$i<64} {incr i} {
       set s [read $fp 16]
       if {$s==""} break
       binary scan $s H* hex
       regsub -all (..) $hex {\1 } hex
       regsub -all {[^ -~]} $s . asc
       set hexpos [format %.3X0 $i]
       append res $hex \t\
          [format %-16s $asc] \t\
          $hexpos \n
    close $fp
    set res
 proc copyFile fn {
    if {$fn==""} return
    set n [llength [glob -noc "Copy*$fn"]]
    set no [expr {$n? " [incr n]": ""}]
    file copy $fn "Copy$no of $fn"
    selectDir - .
 proc deleteFile fn {
    if {$fn==""} return
    set msg "OK to delete file\n[infoFile $fn 1]?"
    set answer [tk_messageBox -type yesno -default no -icon question -message $msg]
    if {$answer} {
       file delete -force $fn
       selectDir - .
 proc markFile {w item} {
    global g
    set fn [$w itemcget $item -text]
    regexp {(.+?) *\t} $fn -> fn
    if ![file exists $fn] return
    set g(marked) $fn
    $g(props) delete 1.2 end ;# keep icon
    $g(props) insert end [infoFile $fn]
 proc readFile fn {
    set fp  [open $fn]
    set t [read $fp 2]
    if {$t=="\xff\xfe"} {
       set ::g(enc) unicode
    } else {seek $fp 0}
    fconfigure $fp -encoding $::g(enc)
    set res [read $fp]
    close $fp
    set res
 proc newFolder w {
    file mkdir "New Folder"
    selectDir - .
 proc renameFile w {
    set item [$w selection get]
    set fn [$w itemcget $item -text]
    regexp {(.+?) *\t} $fn -> fn
    set fn2 [$w edit $item $fn newname]
    if {$fn2!=""} {
       file rename $fn $fn2
       selectDir - .
 proc newname fn {expr ![file exists $n]}

 proc listProcs {w {filt ""}}  {
    global g
    if {$filt !=""} {set g(filter) $filt}
    $w delete [$w items]
    set n -1
    foreach i [lsort [info procs $g(filter)]] {
       $w insert end [incr n] -text $i
    $w bindText <ButtonRelease-1> [list  after 9 selectProc $w]
   set g(2) "iFile: procs"
   .n raise 2
   set g(filterCmd) listProcs
 proc selectProc {w item} {
    global g
    set t [$w itemcget $item -text]
    $g(text) delete 1.0 end
    $g(text) insert end [showProc $t]
    set g(3) "iFile: proc $t"
    .n raise 3    
 proc showProc name {
    set args {}
    foreach arg [info args $name] {
       if [info default $name $arg t] {
          lappend arg $t
       lappend args $arg
    set body [expr {[info exists ::auto_index($name)]?
      "\n# $::auto_index($name)\n"
      : ""}]
    append body [info body $name]
    list proc $name $args $body
 proc render {fn w type} {
    global g
    catch {image delete $g(i)}
    set i [image create $type -file $fn]
    $w image create end -image $i
    set g(i) $i
    return [image width $i]x[image height $i]
 proc infoFile {fn {brief 0}} {
    set res $fn\n\n
    append res "Folder:\t[pwd]\n"
    append res "Size:\t"
    append res "[file size $fn] Bytes\n"
    foreach i {atime mtime} {
       append res \
         "$i:\t[dateTime [file $i $fn]]\n"
    if {!$brief} {
      foreach {key val} [file attr $fn] {
        set k [format %-12s $key:]
        append res \n$k\t$val
    set res
 proc dateTime t {
    clock format $t \
      -format %y-%m-%d,%H:%M:%S
#------------------------- Image scaling
 proc scaleImage {im xfactor {yfactor 0}} {
    set mode -subsample
    if {abs($xfactor) < 1} {
       set xfactor [expr round(1./$xfactor)]
    } elseif {$xfactor>=0 && $yfactor>=0} {
        set mode -zoom
    if {$yfactor == 0} {set yfactor $xfactor}
    set t [image create photo]
    $t copy $im
    $im blank
    $im copy $t -shrink $mode $xfactor $yfactor
    image delete $t
 #------ borrow images from BWidget:
 set g(images) {folder info palette}
 foreach i $g(images) {
    set g($i) [image create photo -file $BWIDGET::LIBRARY/images/$i.gif]
 set g(file) [image create photo -data {

#-------- The notebook and its pages:
 NoteBook .n -internalborderwidth 0
 pack .n
 set 1 [.n insert end 1 -text Tree -raisecmd {wm title . iFile}]
 set 2 [.n insert end 2 -text Files -raisecmd {wm title . $g(2)}]
 set 3 [.n insert end 3 -text File -raisecmd {wm title . $g(3)}]
 set g(3) "iFile - No file selected"
 set 4 [.n insert end 4 -text Props -raisecmd {wm title . "iFile properties"}]
 set 5 [.n insert end 5 -text % -raisecmd {
   wm title . "iFile console"
   focus $g(ce)
 set 6 [.n insert end 6 -text Setup -raisecmd {wm title . "iFile setup"}]
#-----------------------------Tree page
 set g(tree) [Tree $1.t -width 27 -height 19 \
   -deltax 16 -deltay 13 \
   -yscrollcommand "$1.y set" \
   -opencmd [list openDir $1.t]]
 scrollbar $1.y -command "$1.t yview"
 grid $1.t $1.y -sticky ns
 $1.t bindImage <1> [list + after 9 selectDir $1.t]
 $1.t bindText    <1> [list + after 9 selectDir $1.t]

#----------------------------- Files page
 frame $2.f
 label $2.f.0 -text "Filter: "
 entry $2.f.e -textvar g(filter) -width 5
 bind $2.f.e <Return> {$g(filterCmd) $g(lb) .}
 set g(filter) *
 button $2.f.c -text * -command {set g(filter) *}
 button $2.f.up -text Up -command {
    if {[pwd]!="\\"} {
        set g(filter) *
        selectDir $g(tree) ..
 set g(ab) [ArrowButton $2.f.ab -fg blue -activeforeground blue \
          -command toggleOrder -relief flat]
 label $2.f.1 -text "Sort by: "
 ComboBox $2.f.cb -width 5 -editable 0 -textvariable g(sortby) -values {Name Type Size Date}
 set g(dir) -incr
 proc toggleOrder {} {
    global g
    switch -- [$g(ab) cget -dir] {
       top {set g(dir) -decr; set t bottom}
       bottom {set g(dir) -incr; set t top}
    $g(ab) configure -dir $t
    after 50 {selectDir - .}
 eval pack [winfo children $2.f] -side left
 grid $2.f - -sticky news
 set g(lb) [ListBox $2.l -bg white -height 15 -padx 18 \
    -width 27 -yscrollcommand "$2.y set" -selectmode single]
 scrollbar $2.y -command "$2.l yview"
 grid $2.l $2.y -sticky ns
#------------------------------- File page
 grid [ScrolledWindow $3.sw -auto both] -sticky news
 set g(text) [text $3.sw.t -wrap word -height 21 -width 43] 
 $3.sw setwidget $3.sw.t

 proc saveText {w {name ""}} {
    if {$name==""} {set name [tk_getSaveFile]}
    if {$name!=""} {
        set fp [open $name w]
        fconfigure $fp -encoding $::g(enc)
        if {$::g(enc)=="unicode"} {puts -nonewline $fp \ufeff}
        puts $fp [$w get 1.0 end-1c]
        close $fp
           selectDir - .
#--------------------- Prop(ertie)s page
 set g(props) [text $4.t -bg [.n cget -bg] \
    -height 20 -width 45 -relief flat]
 grid $4.t -sticky news
 $4.t image create 1.0 -image $g(info)
 $4.t insert end $g(about)
#-------------------- % (Console) page
 set g(ce) [ComboBox $5.e -textvariable g(cmd)]
 set g(chist) {{}}
 $5.e bind <Return> "ceval $5.t"
 set g(ct) [text $5.t -height 14 -width 43 -yscrollcommand "$5.y set"]
 foreach c {red blue black} {
    $5.t tag config $c -foreground $c
 redef_puts $g(ct)
 scrollbar $5.y -command "$5.t yview"
 label $5.l -text "\n\nIntentionally\nleft\nblank\n\n"
 grid $5.e -     -sticky ew
 grid $5.t $5.y -sticky ns
 grid $5.l
 proc ceval {text} {
    global g
    set cmd $g(cmd)
    $text insert end $cmd\n blue
    if [catch {uplevel #0 $cmd} res] {
       set tag red
    } else {
       set tag black
       if {[lsearch -exact $g(chist) $cmd]<0} {
         set g(chist) [lrange \
          [linsert $g(chist) 1 $cmd] 0 511]
         $g(ce) configure -values $g(chist)
         set g(cmd) ""
    set dir [file tail [pwd]]
    if {$res!=""} {$text insert end $res\n $tag}
    $text insert end "($dir) % " blue
    $text see end
#---------------------------- Setup page
 label $6.info -image $g(info)
 message $6.00 -text $g(about) -aspect 1000
 grid $6.info $6.00 - -sticky nw

 label $6.0 -text Encoding 
 ComboBox $6.enc -text Encoding \
    -textvariable g(enc) \
    -values [lsort -dic [encoding names]] -editable 0
 set g(enc) [encoding system]
 button $6.c -text system -command {
    set g(enc) [encoding system]
 grid $6.0 $6.enc $6.c -sticky news

 label $6.1 -text "ASCII font"
 entry $6.af -textvariable g(font)
 grid $6.1 $6.af -sticky ew

 label $6.2 -text "Unicode font"
 entry $6.uf -textvariable g(ufont)
 grid $6.2 $6.uf -sticky ew

 label $6.3 -text Unknown?
 ComboBox $6.uk -values {
   readFile hexdump
 } -textvariable g(unk) -editable 0
 set g(unk) hexdump
 grid $6.3 $6.uk -sticky ew
 trace variable g(sortby) w "selectDir $1.t .;#"

 label $6.4 -text File/wrap
 checkbutton $6.wr -onvalue word \
    -offvalue none -command {
    $g(text) config -wrap $g(wrap)
    after 10 .n raise 3
 } -variable g(wrap)
 set g(wrap) word
 grid $6.4 $6.wr -sticky w
 #---- place-holder to push others up:
 grid [label $6.end -text \n\n\n\n]
 proc m+ {menu label cmd} {
  .m.$menu add command -label $label -command $cmd
 proc m++ {menu label} {
    .m add casc -label $label -menu \
         [menu .m.$menu -tearoff 0]
 . config -menu [menu .m]
 m++ file File
 m+ file Hexdump {
    $g(text) delete 1.0 end
    $g(text) insert end [hexdump $g(marked)]
    .n raise 3
 m+ file "New Folder" {newFolder $g(lb)}
 m+ file Rename {renameFile $g(lb)}
 m+ file Run {exec wish $g(marked) &}
 m+ file Copy {copyFile $g(marked)}
 m+ file Delete {deleteFile $g(marked)}
 .m.file add separator
 m+ file Restart {exec wish $argv0 &; exit}
 m+ file Exit exit

 m++ image Image
 foreach i {3 2 0.5 0.33} {
    m+ image "Zoom x $i" "scaleImage \$g(i) $i"
 .m.image add separator
 m+ image "Flip LR" {scaleImage $g(i) -1 1}
 m+ image "Flip TB" {scaleImage $g(i) 1 -1}
 m+ image "Flip both" {scaleImage $g(i) -1 -1}

 m++ text Text
 m+ text "Save as..." {saveText $g(text)}
 m+ text Clear {$g(text) delete 1.0 end}
 m+ text Eval {
        set g(cmd) [$g(text) get 1.0 end-1c]
        ceval $g(ct)
        .n raise 5
 m++ sel Select
 m+ sel Color {append $g(cmd) " " [SelectColor .c]}
 m+ sel Font {append $g(cmd) " {[SelectFont .f]}"}
 m+ sel Proc {listProcs $g(lb) *}
 #----------- Final steps to get started:
 selectDir - /
 drawTree $1.t
 .n raise 1
 wm geometry . +0+1
# 8.4a2 workaround: transparency
 lappend g(images) file
 foreach i $g(images) {
   $g(text) image create end -image $g($i)
   scaleImage $g($i) 2
   scaleImage $g($i) 0.5