JOB - 2016-07-12 20:22:35Purpose:
- Search for files in a given directory matching a specified pattern.
- The procedure recursively traverses the tree structure and as well creates a cache file, which is stored in the given root directory.
- The cache file holds all the file references which can then be used for another search (using the same search pattern).
# -----------------------------------------------------------------------------
# getfiles.tcl ---
# -----------------------------------------------------------------------------
# (c) 2016, Johann Oberdorfer - Engineering Support | CAD | Software
# johann.oberdorfer [at] googlemail.com
# www.johann-oberdorfer.eu
# -----------------------------------------------------------------------------
# This source file is distributed under the BSD license.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
# See the BSD License for more details.
# -----------------------------------------------------------------------------
# Credits:
# The code is heavily based on http://wiki.tcl.tk/19762 - [AQI] rglob procedure
#
# Purpose:
# Search for files in a given directory matching a specified pattern.
#
# The procedure recursively traverses the tree structure and creates
# a chache file, which is stored in the given root directory.
# The cache file holds all the file references which can then be used
# for another search (using the same search pattern).
#
# -----------------------------------------------------------------------------
# -----------------------------------------------------------------------------
# Revision history:
# June, 16: J.Oberdorfer, initial release
# -----------------------------------------------------------------------------
# -----------------------------------------------------------------------------
package provide getfiles 0.1
namespace eval getfiles {
namespace export \
set_excluded_names \
set_cachefilename \
get_cachefilename \
delete_cachfile \
getfiles_cached
variable cache_file_name
variable excluded_dirnames
set cache_file_name ".getfile.cache"
set excluded_dirnames {
"tmp"
"Archiv" "Backup"
}
proc set_excluded_names {names_list} {
variable excluded_dirnames
foreach name $names_list {
if { [lsearch $excluded_dirnames $name] == -1} {
lappend excluded_dirnames $name
}
}
}
proc set_cachefilename {fname} {
variable cache_file_name
set cache_file_name $fname
}
proc get_cachefilename {} {
variable cache_file_name
return $cache_file_name
}
proc GetFiles { dir pattern searchcmd } {
variable excluded_dirnames
set file_list {}
# fix the directory name...
set basedir [string trimright [file join [file normalize $dir] { }]]
# search in the current directory for matching files...
foreach fname [glob -nocomplain -type {f r} -path $basedir $pattern] {
# evaluate command in parent namespace:
if {$searchcmd != ""} {
catch {uplevel $searchcmd $fname}
}
lappend file_list $fname
}
# now search for any sub direcories in the current directory...
foreach dir_name [glob -nocomplain -type {d r} -path $basedir "*"] {
set is_valid_dir 1
foreach item $excluded_dirnames {
if { [string first [string tolower $item] [string tolower $dir_name]] != -1 } {
set is_valid_dir 0
break
}
}
if {$is_valid_dir == 1} {
# recusive call ...
set subdir_list [GetFiles $dir_name $pattern $searchcmd]
if { [llength $subdir_list] > 0 } {
foreach fname $subdir_list {
lappend file_list $fname
}
}
}
}
return $file_list
}
proc ReadCacheFile {cache_file} {
set rlist {}
set fp [open $cache_file "r"]
while { ![eof $fp] } {
gets $fp item
if { [set str [string trim $item]] != "" } {
lappend rlist $str
}
}
close $fp
return $rlist
}
proc delete_cachfile { root_dir } {
variable cache_file_name
set cache_file [file join $root_dir $cache_file_name]
if { [file exists $cache_file] } {
if { ![file writable $cache_file] } {
tk_messageBox \
-title "Error while attempting to delete cache file." \
-icon "warning" \
-message "Unable to remove cache file: $msg" \
-type ok
} else {
# delete previous cache file...
file delete -force $cache_file
}
}
}
proc getfiles_cached { root_dir pattern cachefile_created {searchcmd ""} } {
upvar $cachefile_created file_created
variable cache_file_name
set file_list {}
set file_created 0
set cache_file [file join $root_dir $cache_file_name]
if { ![file exists $cache_file] ||
[llength [set file_list [ReadCacheFile $cache_file]]] == 0 } {
# read files...
set file_list [GetFiles $root_dir $pattern $searchcmd]
# and initially write cache file...
if { ![catch {set ofile [open $cache_file "w"]} msg] } {
foreach f $file_list {
puts -nonewline $ofile "$f\n"
}
close $ofile
set file_created 1
} else {
tk_messageBox \
-title "Error while attempting to write cache file." \
-icon "warning" \
-message "Unable to write cache file: $msg" \
-type ok
set file_created 99
}
}
return $file_list
}
}Demo Code:
lappend auto_path [file join [file dirname [info script]]]
package require Tk
catch {console show}
package require getfiles
# testing the code...
proc SearchCommand {args} {
set fname [lindex $args 0]
puts $fname
update
}
set root_dir "Z:/projects/whatever"
set pattern "*.pdf*"
set cachefile_created 0
# force cache file to be re-created !
# -----------------------------------
getfiles::delete_cachfile $root_dir
# -----------------------------------
getfiles::set_excluded_names {
"Archiv" "Backup" "tmp"
}
set rlist [getfiles::getfiles_cached \
$root_dir $pattern cachefile_created \
SearchCommand]
if {$cachefile_created} {
puts "*** Cache file has been created:"
puts " [file join $root_dir [getfiles::get_cachefilename]]"
}
# try to find ".pdf"
# ------------------
set t0 [clock milliseconds]
set file_list {}
set part_num "find_something"
foreach f $rlist {
if { [file extension $f] == ".pdf" && [string first $part_num $f] != -1 } {
lappend file_list $f
}
}
# print result
puts "Search Result:"
switch -- [llength $file_list] {
0 { puts "No PDF available matching: $pattern" }
1 { puts "--> [lindex $file_list 0]" }
default {
puts "More than one CATParts found, please choose the associated model:"
foreach f $file_list {
puts $f
}
}
}
puts "*** [expr ( [clock milliseconds] - $t0 ) / 1000.0] sec"
# try to find another pdf (cached)
# --------------------------------
set t0 [clock milliseconds]
set file_list {}
set part_num "find_something_else_cached"
foreach f $rlist {
if { [file extension $f] == ".pdf" && [string first $part_num $f] != -1} {
lappend file_list $f
}
}
# print result:
switch -- [llength $file_list] {
0 { puts "No CATDrawing available matching: $pattern" }
1 { puts "--> [lindex $file_list 0]" }
default {
puts "More than one CATDrawing found, please choose the associated model:"
foreach f $file_list {
puts $f
}
}
}
puts "*** [expr ( [clock milliseconds] - $t0 ) / 1000.0] sec"
