Although inspired by [Cost], [treeql] is generally useful for any tree-like structure which has properties/attributes/keys. This includes filesystems, xml and html documents, parse trees, etc. This page contains some treeql adaptors. ---- '''dirtree.tcl''' # this implements a treecl API for directories. package require snit snit::type dirtree { variable stat_names {} # Structural generators - used by apply # return all descendants of $node - redundant for treecl method descendants {node} { set children [$self children $node] foreach child $children { lappend children {*}[$self descendants $child] } #puts stderr "$self descendants $node -> $children" return $children } # return all immediate children of $node method children {node} { if {[catch {glob -nocomplain [file join $node *]} result]} { puts stderr "Error: $result" } else { #puts stderr "$self children $node -> $result" if {[string equal windows $::tcl_platform(platform)]} { # escape blanks in filenames regsub -all { } $result {\\ } result } return $result } } # return next right sibling of $node method next {node} { set glob [$self children [file dirname $node]] set index [lsearch $glob [file tail $node]] if {$index == -1} { set result {} } else { set result [lindex $glob [expr {$index + 1}]] } #puts stderr "$self next $node -> $result" return $result } # return $node's parent method parent {node} { #puts stderr "$self parent $node -> [file dirname $node]" return [file dirname $node] } # return left sibling of $node method previous {node} { set glob [$self children [file dirname $node]] set index [lsearch $glob [file tail $node]] if {$index == -1} { set result {} } else { set result [lindex $glob [expr {$index - 1}]] } #puts stderr "$self previous $node -> $result" return $result } # Property generators - used by apply # get value of attribute named $key method get {node key} { switch -glob -- $key { -* { # a file attribute return [file attributes $node $key] } @name { # we create a pseudo key called @name # since we use name as node id, return that return $node } default { # must be stat file stat $node stat return $stat($key) } } } # get all $node attribute names whose keys match $glob (default *) method keys {node glob} { if {$stat_names == {}} { # cache the results of [file stat] # so we know what names stat returns file stat $node stat set stat_names [array get stat] } set result {} set attrs [file attributes $node] lappend attrs {*}$stat_names @name "" foreach {attr val} $attrs { if {[string match $glob $attr]} { lappend result $attr } } return $result } # set $node $key to $value method set {node attr val} { file attributes $node $attr $val } # predicates - used by bool # $node has attribute $key method keyexists {node key} { return [expr {[lsearch [file attributes $node] $key] > -1}] } # rootname - returns the doc root method rootname {} { return / } } if {[info script] == $argv0} { package require treeql set dir [dirtree %AUTO%] ;# create the directory shim set qd [treeql %AUTO% -tree $dir] ;# create the tree query # start somewhere in the file system #$qd quote [file normalize /usr/lib/tclhttpd] $qd quote [file normalize ~] $qd descendants ;# get all descendants of the starting point # from here on we use subquery - to preserve the current nodeset # (query would overwrite it.) puts "All my files: [$qd subquery withatt -owner $tcl_platform(user)]" puts "All file sizes: [$qd subquery get size]" puts "Files longer than 10K: [$qd subquery exprP {10240 <} size]" set age_y [clock scan "last year"] puts "Files older than a year: [$qd subquery exprP [list $age_y >] mtime]" set age_m [clock scan "last month"] puts "Files older than a month: [$qd subquery exprP [list $age_m >] mtime]" set age_f [clock scan "last fortnight"] puts "Files older than two weeks: [$qd subquery exprP [list $age_f >] mtime]" set age_w [clock scan "last week"] puts "Files older than a week: [$qd subquery exprP [list $age_w >] mtime]" # here we do a boolean query. puts "Files between one and two weeks old: [$qd subquery exprP [list $age_w >] mtime andq [list exprP [list $age_f < ] mtime]]" } ---- [UKo] 2005-03-01: this doesn't work for me (besides the syntax error with catch, I have corrected). On windows I get the error: list element in braces followed by "\" instead of space with a very lengthy errorInfo. NH 2009-04-16: The error was caused by [{expand}] in the dirtree methods. I have changed this to [{*}] for Tcl 8.5+ See also [Snit] ---- [Category Data Structure] [Category Example]