Version 1 of TreeQL adaptor

Updated 2004-10-07 20:53:51

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 eo]} {
               puts stderr "Error: $eo"
           } 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]]"

   }