1# treeql.tcl 2# A generic tree query language in snit 3# 4# Copyright 2004 Colin McCormack. 5# You are permitted to use this code under the same license as tcl. 6# 7# 20040930 Colin McCormack - initial release to tcllib 8# 9# RCS: @(#) $Id: treeql84.tcl,v 1.10 2007/06/23 03:39:34 andreas_kupries Exp $ 10 11package require Tcl 8.4 12package require snit 13package require struct::list 14package require struct::set 15 16snit::type ::treeql { 17 variable nodes ;# set of all nodes 18 variable tree ;# tree over which nodes are defined 19 variable query ;# full query - ie: 'parent' of this treeql object 20 21 # low level accessor to tree 22 method treeObj {} { 23 return $tree 24 } 25 26 # apply the [$tree cmd {*}$args] form to each node 27 # returns the list of results of application 28 method apply {cmd args} { 29 set result {} 30 foreach node $nodes { 31 if {[catch { 32 eval [list $tree] $cmd [list $node] $args 33 } application]} { 34 upvar ::errorInfo eo 35 puts stderr "apply: $tree $cmd $node $args -> $application - $eo" 36 } else { 37 #puts stderr "Apply: $tree $cmd $node $args -> $application" 38 foreach a $application {lappend result $a} 39 } 40 } 41 42 return $result 43 } 44 45 # filter nodes by [$tree cmd {*}$args] 46 # returns the list of results of application when application is non nil 47 method filter {cmd args} { 48 set result {} 49 foreach node $nodes { 50 if {[catch { 51 eval [list $tree] $cmd [list $node] $args 52 } application]} { 53 upvar ::errorInfo eo 54 puts stderr "filter: $tree $cmd $node $args -> $application - $eo" 55 } else { 56 #puts stderr "Filter: $tree $cmd $node $args -> $application" 57 if {$application != {}} { 58 lappend result $application 59 } 60 } 61 } 62 return $result 63 } 64 65 # filter nodes by the predicate [$tree cmd {*}$args] 66 # returns the list of results of application when application is true 67 method bool {cmd args} { 68 69 #puts stderr "Bool: $tree $cmd - $args" 70 #set result [::struct::list filter $nodes [list $tree $cmd {*}$args]] 71 #puts stderr "Bool: $tree $cmd - $nodes - $args -> $result" 72 #return $result 73 74 # replaced by tcllib's list filter 75 set result {} 76 foreach node $nodes { 77 if {[catch { 78 eval [list $tree] $cmd [list $node] $args 79 } application]} { 80 upvar ::errorInfo eo 81 puts stderr "filter: $tree $cmd $node $args -> $application - $eo" 82 } else { 83 #puts stderr "bool: $tree $cmd $node $args -> $application - [$tree dump $node]" 84 if {$application} { 85 lappend result $node 86 } 87 } 88 } 89 90 return $result 91 } 92 93 # applyself - map cmd on $self to each node, discarding null results 94 method applyself {cmd args} { 95 96 set result {} 97 foreach node $nodes { 98 if {[catch { 99 eval [list $query] $cmd [list $node] $args 100 } application]} { 101 upvar ::errorInfo eo 102 puts stderr "applyself: $tree $cmd $node $args -> $application - $eo" 103 } else { 104 if {[llength $application]} { 105 foreach a $application {lappend result $a} 106 } 107 } 108 } 109 110 return $result 111 } 112 113 # mapself - map cmd on $self to each node 114 method mapself {cmd args} { 115 116 set result {} 117 foreach node $nodes { 118 if {[catch { 119 eval [list $query] $cmd [list $node] $args 120 } application]} { 121 upvar ::errorInfo eo 122 puts stderr "mapself: $tree $cmd $node $args -> $application - $eo" 123 } else { 124 #puts stderr "Mapself: $query $cmd $node $args -> $application" 125 lappend result $application 126 } 127 } 128 129 return $result 130 } 131 132 # shim to perform operation $op on attribute $attr of $node 133 method do_attr {node op attr} { 134 set attrv [$tree get $node $attr] 135 #puts stderr "$self do_attr node:'$node' op:'$op' attr:'$attr' attrv:'$attrv'" 136 return [eval [linsert $op end $attrv]] 137 } 138 139 # filter nodes by predicate [string $op] over attribute $attr 140 method stringP {op attr args} { 141 set n {} 142 set map [$self mapself do_attr [linsert $op 0 string] $attr] 143 foreach result $map node $nodes { 144 #puts stderr "$self stringP $op $attr -> $result - $node" 145 if {$result} { 146 lappend n $node 147 } 148 } 149 set nodes $n 150 return $args 151 } 152 153 # filter nodes by negated predicate [string $op] over attribute $attr 154 method stringNP {op attr args} { 155 set n {} 156 set map [$self mapself do_attr [linsert $op 0 string] $attr] 157 foreach result $map node $nodes { 158 if {!$result} { 159 lappend n $node 160 } 161 } 162 set nodes $n 163 return $args 164 } 165 166 # filter nodes by predicate [expr {*}$op] over attribute $attr 167 method exprP {op attr args} { 168 set n {} 169 set map [$self mapself do_attr [linsert $op 0 expr] $attr] 170 foreach result $map node $nodes { 171 if {$result} { 172 lappend n $node 173 } 174 } 175 set nodes $n 176 return $args 177 } 178 179 # filter nodes by predicate ![expr {*}$op] over attribute $attr 180 method exprNP {op attr args} { 181 set n {} 182 set map [$self mapself do_attr [linsert $op 0 expr] $attr] 183 foreach result $map node $nodes { 184 if {!$result} { 185 lappend n $node 186 } 187 } 188 set nodes $n 189 return $args 190 } 191 192 # shim to return string values of attributes matching $pattern of a given $node 193 method do_get {node pattern} { 194 set result {} 195 foreach key [$tree keys $node $pattern] { 196 set result [concat $result [$tree get $node $key]] 197 } 198 return $result 199 } 200 201 # Returns list of attribute values of attributes matching $pattern - 202 method get {pattern} { 203 set nodes [$self mapself do_get $pattern] 204 return {} ;# terminate query 205 } 206 207 # Returns list of attribute values of the current node, in an unspecified order. 208 method attlist {} { 209 $self get * 210 return {} ;# terminate query 211 } 212 213 # Returns list of lists of attributes of each node 214 method attrs {glob} { 215 set nodes [$self apply keys $glob] 216 return {} ;# terminate query 217 } 218 219 # shim to find node ancestors by repetitive [parent] 220 # as tcllib tree lacks this 221 method do_ancestors {node} { 222 set ancestors {} 223 set rootname [$tree rootname] 224 while {$node ne $rootname} { 225 lappend ancestors $node 226 set node [$tree parent $node] 227 } 228 lappend ancestors $rootname 229 return $ancestors 230 } 231 232 # path from node to root 233 method ancestors {args} { 234 set nodes [$self applyself do_ancestors] 235 return $args 236 } 237 238 # shim to find $node rootpath by repetitive [parent] 239 # as tcllib tree lacks this 240 method do_rootpath {node} { 241 set ancestors {} 242 set rootname [$tree rootname] 243 while {$node ne $rootname} { 244 lappend ancestors $node 245 set node [$tree parent $node] 246 } 247 lappend ancestors $rootname 248 return [::struct::list reverse $ancestors] 249 } 250 251 # path from root to node 252 method rootpath {args} { 253 set nodes [$self applyself do_rootpath] 254 return $args 255 } 256 257 # node parent 258 method parent {args} { 259 set nodes [$self apply parent] 260 return $args 261 } 262 263 # node children 264 method children {args} { 265 set nodes [$self apply children] 266 return $args 267 } 268 269 # previous sibling 270 method left {args} { 271 set nodes [$self apply previous] 272 return $args 273 } 274 275 # next sibling 276 method right {args} { 277 set nodes [$self apply next] 278 return $args 279 } 280 281 # shim to find left siblings of node, in order of occurrence 282 method do_previous* {node} { 283 if {$node == [$tree rootname]} { 284 set children $node 285 } else { 286 set children [$tree children [$tree parent $node]] 287 } 288 set index [expr {[lsearch $children $node] - 1}] 289 return [lrange $children 0 $index] 290 } 291 292 # previous siblings in reverse order 293 method prev {args} { 294 set nodes [::struct::list reverse [$self applyself do_previous*]] 295 return $args 296 } 297 298 # previous siblings in tree order 299 method esib {args} { 300 set nodes [$self applyself do_previous*] 301 return $args 302 } 303 304 # shim to find next siblings in tree order 305 method do_next* {node} { 306 if {$node == [$tree rootname]} { 307 set children $node 308 } else { 309 set children [$tree children [$tree parent $node]] 310 } 311 set index [expr {[lsearch $children $node] + 1}] 312 return [lrange $children $index end] 313 } 314 315 # next siblings in tree order 316 method next {args} { 317 set nodes [$self applyself do_next*] 318 return $args 319 } 320 321 # generates the tree root 322 method root {args} { 323 set nodes [$tree rootname] 324 return $args 325 } 326 327 # shim to calculate descendants 328 method do_subtree {node} { 329 set nodeset $node 330 set children [$tree children $node] 331 foreach child $children { 332 foreach d [$self do_subtree $child] {lappend nodeset $d} 333 } 334 #puts stderr "do_subtree $node -> $nodeset" 335 return $nodeset 336 } 337 338 # generates proper-descendants of nodes 339 method descendants {args} { 340 set desc {} 341 set nodeset {} 342 foreach node $nodes { 343 foreach d [lrange [$self do_subtree $node] 1 end] {lappend nodeset $d} 344 } 345 set nodes $nodeset 346 return $args 347 } 348 349 # generates all subtrees rooted at node 350 method subtree {args} { 351 set nodeset {} 352 foreach node $nodes { 353 foreach d [$self do_subtree $node] {lappend nodeset $d} 354 } 355 set nodes $nodeset 356 return $args 357 } 358 359 # generates all nodes in the tree 360 method tree {args} { 361 set nodes [$self do_subtree [$tree rootname]] 362 return $args 363 } 364 365 # generates all subtrees rooted at node 366 #method descendants {args} { 367 # set nodes [$tree apply descendants] 368 # return $args 369 #} 370 371 # flattened next subtrees 372 method forward {args} { 373 set nodes [$self applyself do_next*] ;# next siblings 374 $self descendants ;# their proper descendants 375 return $args 376 } 377 378 # synonym for [forward] 379 method later {args} { 380 $self forward 381 return $args 382 } 383 384 # flattened previous subtrees in tree order 385 method earlier {args} { 386 set nodes [$self applyself do_previous*] ;# all earlier siblings 387 $self descendants ;# their proper descendants 388 return $args 389 } 390 391 # flattened previous subtrees in reverse tree order 392 # FIXME - this isn't going to return things in the correct order 393 method backward {args} { 394 set nodes [$self applyself do_previous*] ;# all earlier siblings 395 $self subtree ;# their subtrees 396 set nodes [::struct::list reverse $nodes] ;# reverse order 397 return $args 398 } 399 400 # Returns the node type of nodes 401 method nodetype {} { 402 set nodes [$self apply get @type] 403 return {} ;# terminate query 404 } 405 406 # Reduce to nodes of @type $t 407 method oftype {t args} { 408 return [eval [linsert $args 0 $self stringP [list equal -nocase $t] @type]] 409 } 410 411 # Reduce to nodes not of @type $t 412 method nottype {t args} { 413 return [eval [linsert $args 0 $self stringNP [list equal -nocase $t] @type]] 414 } 415 416 # Reduce to nodes whose @type is one of $attrs 417 # @type values are assumed to be simple strings 418 method oftypes {attrs args} { 419 set n {} 420 foreach result [$self mapself do_attr list @type] node $nodes { 421 if {[lsearch $attrs $result] > -1} { 422 #puts stderr "$self oftypes '$attrs' -> $result - $node" 423 lappend n $node 424 } 425 } 426 set nodes $n 427 return $args 428 } 429 430 # Reduce to nodes with attribute $attr (can be a glob) 431 method hasatt {attr args} { 432 set nodes [$self bool keyexists $attr] 433 return $args 434 } 435 436 # Returns values of attribute attname 437 method attval {attname} { 438 $self hasatt $attname ;# only nodes with attribute 439 set nodes [$self apply get $attname] ;# get the attribute nodes 440 return {} ;# terminate query 441 } 442 443 # Reduce to nodes with attribute $attr of $value 444 method withatt {attr value args} { 445 $self hasatt $attr ;# only nodes with attribute 446 return [eval [linsert $args 0 $self stringP [list equal -nocase $value] $attr]] 447 } 448 449 # Reduce to nodes with attribute $attr of $value 450 method withatt! {attr val args} { 451 return [eval [linsert $args 0 $self stringP [list equal $val] $attr]] 452 } 453 454 # Reduce to nodes with attribute $attr value one of $vals 455 method attof {attr vals args} { 456 457 set result {} 458 foreach node $nodes { 459 set x [string tolower [[$self treeObj] get $node $attr]] 460 if {[lsearch $vals $x] != -1} { 461 lappend result $node 462 } 463 } 464 465 set nodes $result 466 return $args 467 } 468 469 # Reduce to nodes whose attribute $attr string matches $match 470 method attmatch {attr match args} { 471 $self stringP [linsert $match 0 match] $attr 472 return $args 473 } 474 475 # Side Effect: set attribute $attr to $val 476 method set {attr val args} { 477 $self apply set $attr $val 478 return $args 479 } 480 481 # Side Effect: unset attribute $attr 482 method unset {attr args} { 483 $self apply unset $attr 484 return $args 485 } 486 487 # apply string operation $op to attribute $attr on each node 488 method string {op attr} { 489 set nodes [$self mapself do_attr [linsert $op 0 string] $attr] 490 return {} ;# terminate query 491 } 492 493 # remove duplicate nodes, preserving order 494 method unique {args} { 495 set all {} 496 array set keys {} 497 foreach node $nodes { 498 if {![info exists keys($node)]} { 499 set keys($node) 1 500 lappend all $node 501 } 502 } 503 set nodes $all 504 return $args 505 } 506 507 # construct the set of nodes present in both $nodes and node set $and 508 method and {and args} { 509 set nodes [::struct::set intersect $and $nodes] 510 return $args 511 } 512 513 # return result of new query $query, preserving current node set 514 method subquery {args} { 515 set org $nodes ;# save current node set 516 set new [uplevel 1 [linsert $args 0 $query query]] 517 set nodes $org ;# restore old node set 518 519 return $new 520 } 521 522 # perform a subquery and and in the result 523 method andq {q args} { 524 $self and [uplevel 1 [linsert $q 0 $self subquery]] 525 return $args 526 } 527 528 # construct the set of nodes present in $nodes or node set $or 529 method or {or args} { 530 set nodes [::struct::set union $nodes $or] 531 $self unique 532 return $args 533 } 534 535 # perform a subquery and or in the result 536 method orq {q args} { 537 $self or [uplevel 1 [linsert $q 0 $self subquery]] 538 return $args 539 } 540 541 # construct the set of nodes present in $nodes but not node set $not 542 method not {not args} { 543 set nodes [::struct::set difference $nodes $not] 544 return $args 545 } 546 547 # perform a subquery and return the set of nodes not in the result 548 method notq {q args} { 549 $self not [uplevel 1 [linsert $q 0 $self subquery]] 550 return $args 551 } 552 553 # select the first of the nodes 554 method select {args} { 555 set nodes [lindex $nodes 0] 556 return $args 557 } 558 559 # perform a subquery then replace the nodeset 560 method transform {q var body args} { 561 upvar 1 $var iter 562 set new {} 563 foreach n [uplevel 1 [linsert $q 0 $self subquery]] { 564 set iter $n 565 switch -exact -- [catch {uplevel 1 $body} result] { 566 0 { 567 # ok 568 lappend new $result 569 } 570 1 { 571 # pass errors up 572 return -code error $result 573 } 574 2 { 575 # return 576 set nodes $result 577 return 578 } 579 3 { 580 # break 581 break 582 } 583 4 { 584 # continue 585 continue 586 } 587 } 588 } 589 590 set nodes $new 591 592 return $args 593 } 594 595 # replace the nodeset 596 method map {var body args} { 597 upvar 1 $var iter 598 set new {} 599 foreach n $nodes { 600 set iter $n 601 switch -exact -- [catch {uplevel 1 $body} result] { 602 0 { 603 # ok 604 lappend new $result 605 } 606 1 { 607 # pass errors up 608 return -code error $result 609 } 610 2 { 611 # return 612 set nodes $result 613 return 614 } 615 3 { 616 # break 617 break 618 } 619 4 { 620 # continue 621 continue 622 } 623 } 624 } 625 626 set nodes $new 627 628 return $args 629 } 630 631 # perform a subquery $query then map $body over results 632 method foreach {q var body args} { 633 upvar 1 $var iter 634 foreach n [uplevel 1 [linsert $q 0 $self subquery]] { 635 set iter $n 636 uplevel 1 $body 637 } 638 return $args 639 } 640 641 # perform a query, then evaluate $body 642 method with {q body args} { 643 # save current node set, implied reset 644 set org $nodes; set nodes {} 645 646 uplevel 1 [linsert $q 0 $self query] 647 set result [uplevel 1 $body] 648 649 # restore old node set 650 set new $nodes; set nodes $org 651 652 return $args 653 } 654 655 # map $body over $nodes 656 method over {var body args} { 657 upvar 1 $var iter 658 set result {} 659 foreach n $nodes { 660 set iter $n 661 uplevel 1 $body 662 } 663 return $args 664 } 665 666 # perform the query 667 method query {args} { 668 # iterate over the args, treating each as a method invocation 669 while {$args != {}} { 670 #puts stderr "query $self $args" 671 set args [uplevel 1 [linsert $args 0 $query]] 672 #puts stderr "-> $nodes" 673 } 674 675 return $nodes 676 } 677 678 # append the literal $val to node set 679 method quote {val args} { 680 lappend nodes $val 681 return $args 682 } 683 684 # replace the node set with the literal 685 method replace {val args} { 686 set nodes $val 687 return $args 688 } 689 690 # set nodeset to empty 691 method reset {args} { 692 set nodes {} 693 return $args 694 } 695 696 # delete all nodes in node set 697 method delete {args} { 698 699 foreach node $nodes { 700 $tree cut $node 701 } 702 703 set nodes {} 704 return $args 705 } 706 707 # return the node set 708 method result {} { 709 return $nodes 710 } 711 712 constructor {args} { 713 set query [from args -query ""] 714 if {$query == ""} { 715 set query $self 716 } 717 718 set nodes [from args -nodes {}] 719 720 set tree [from args -tree ""] 721 722 uplevel 1 [linsert $args 0 $self query] 723 } 724 725 # Return result, and destroy this query 726 # useful in constructing a sub-query 727 method discard {args} { 728 return [K [$self result] [$self destroy]] 729 } 730 731 proc K {x y} { 732 set x 733 } 734} 735