TreeQL adaptor

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