Version 4 of TreeQL adaptor

Updated 2005-03-02 17:36:34

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 {expand}[$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 {expand}$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.

CMcC I'm totally guessing here, the traceback would be useful, but what happens if you change the initial directory to something other than ~, for the case that HOME isn't set up correctly? My guesswork revolves around the fact that \ is a path separator, and this might be a result of some empty directory name ... but it's impossible to tell without the traceback. If you feel like it, you could email me at colin at sharedtech dog dyndns dog org

See also Snit


Category Data Structure Category Example