Another little file search

Some problems:

  • speed
  • progressVar is not updated if level > 0 (recursive search)
  • it has to work with tcl 8.0

 ########################################################################################################
 # proc       : GetFileList
 # written by : Enrico Herzke
 # Datum      : 2001
 ########################################################################################################
 # Funktion: Liefert Liste aller Dateien in einem Verzeichnis inkl. Unterverzeichnisse
 #   Aufruf: GetFileList path ?args?
 #  Eingabe: [I]       path  - zu durchsuchendes Verzeichnis
 #           [I]       -ext  - Liste von einer oder mehreren Extensions ohne Punkt,
 #                             nach denen gesucht wird
 #                             z.B.: '-ext h' oder '-ext "h cpp"'
 #           [I]    -relPath -  0 -> liefere kompletten Pfad
 #                              1 -> liefere relativen Pfad (default)
 #           [I]   -recursiv -  0 -> nur den uebergebenen Pfad durchsuchen
 #                              1 -> alle Unterverzeichnisse durchsuchen (default)
 #  Ausgabe: keine
 # Rückgabe: Fileliste
 #  Hinweis: - wird keine Extension (Option -ext) angegeben, werden alle Dateien zurueckgeliefert,
 #             es werden nur relative Pfadangaben der gefundenen Dateien zurueckgegeben
 #           - gibt man den Pfad mit abschließendem Slash an, wird der komplette Pfad zurueckgeliefert
 # Beispiel:
 #
 proc GetFileList {path args} {
        if {[lindex $args 0] != 0 && [lindex $args 0] != 1} {
                set level 0
        } else {
                set level [lindex $args 0]
                set args [lrange $args 1 end]
                if {$level == 1} {
                        set searchRecursiv 1
                        while {[llength $args] > 0} {
                                set opt [lindex $args 0]
                                switch -- $opt {
                                        -progressVar {
                                                upvar #0 [lindex $args 1] progressVar
                                                set args [lrange $args 2 end]
                                        }
                                        default {
                                                return -code error "unknown option '$opt'"
                                        }
                                }
                        }
                }
        }
        if {$level == 0} {
                set extOK 0
                set relPath 1
                set searchRecursiv 1
                set regExp ".*"
                #puts stderr "args'$args' -> '[llength $args]'"
                while {[llength $args] > 0} {
                        set opt [lindex $args 0]
                        switch -- $opt {
                                -ext {
                                        set ext [lindex $args 1]
                                        set extOK 1
                                        set args [lrange $args 2 end]
                                }
                                -relPath {
                                        set relPath [lindex $args 1]
                                        set args [lrange $args 2 end]
                                }
                                -recursiv {
                                        set searchRecursiv [lindex $args 1]
                                        set args [lrange $args 2 end]
                                }
                                -progressVar {
                                        upvar #0 [lindex $args 1] progressVar
                                        set args [lrange $args 2 end]
                                }
                                -regExp {
                                        set regExp [lindex $args 1]
                                        set args [lrange $args 2 end]
                                }
                                default {
                                        return -code error "unknown option '$opt'"
                                }
                        }
                        #puts stderr "args'$args' -> '[llength $args]'"
                }
        }
        set fileList ""
        set fL ""
        set path [Backslash2Slash $path]
        set all [glob -nocomplain $path/*]
        dputs "all 'glob -nocomplain $path/*' -> '$all'"
        foreach f $all {
                update idletasks
                if {[file isdirectory $f]} {
                        set progressVar $f;update
                        if $searchRecursiv {
                                set temp [GetFileList $f 1 -progressVar progressVar]
                                foreach t $temp {
                                        lappend fL $t
                                }
                        }
                } else {
                        lappend fL $f
                }
        }
        if {$level == 0} {
                foreach f $fL {
                        if {![regexp $regExp $f]} {continue}
                        if $extOK {
                                dputs "checke extension '$ext' bei '$f' -> '[file extension $f]'"
                                set isExt [string range [file extension $f] 1 end]
                                if {[lsearch [string tolower $ext] [string tolower $isExt]] == -1} {
                                        continue
                                }
                        }
                        if $relPath {
                                regsub -- "$path/" $f "" f
                        }
                        lappend fileList $f
                }
        } else {
                set fileList $fL
        }
        return $fileList
 }

MHo: You may also take a look at Matthias Hoffmann - Tcl-Code-Snippets - misc - globx.


globx is ok, but works not on tcl 8.0 which I need!