1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
# dommap.tcl --
#
# Apply a mapping function to a DOM structure
#
# Copyright (c) 1998-2003 Zveno Pty Ltd
# http://www.zveno.com/
#
# See the file "LICENSE" in this distribution for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# $Id: dommap.tcl,v 1.5 2003/12/09 04:56:43 balls Exp $
package provide dommap 1.0
# We need the DOM
package require dom 2.6
namespace eval dommap {
namespace export map
}
# dommap::apply --
#
# Apply a function to a DOM document.
#
# The callback command is invoked with the node ID of the
# matching DOM node as its argument. The command may return
# an error, continue or break code to alter the processing
# of further nodes.
#
# Filter functions may be applied to match particular
# nodes. Valid functions include:
#
# -nodeType regexp
# -nodeName regexp
# -nodeValue regexp
# -attribute {regexp regexp}
#
# If a filter is specified then the node must match for the
# callback command to be invoked. If a filter is not specified
# then all nodes match that filter.
#
# Arguments:
# node DOM document node
# cmd callback command
# args configuration options
#
# Results:
# Depends on callback command
proc dommap::apply {node cmd args} {
array set opts $args
# Does this node match?
set match 1
catch {set match [expr $match && [regexp $opts(-nodeType) [::dom::node cget $node -nodeType]]]}
catch {set match [expr $match && [regexp $opts(-nodeName) [::dom::node cget $node -nodeName]]]}
catch {set match [expr $match && [regexp $opts(-nodeValue) [::dom::node cget $node -nodeValue]]]}
if {$match && ![string compare [::dom::node cget $node -nodeType] element]} {
set match 0
foreach {attrName attrValue} [array get [::dom::node cget $node -attributes]] {
set match 1
catch {set match [expr $match && [regexp [lindex $opts(-attribute) 0] $attrName]]}
catch {set match [expr $match && [regexp [lindex $opts(-attribute) 1] $attrValue]]}
if {$match} break
}
}
if {$match && [set code [catch {eval $cmd [list $node]} msg]]} {
switch $code {
0 {}
3 {
return -code break
}
4 {
return -code continue
}
default {
return -code error $msg
}
}
}
# Process children
foreach child [::dom::node children $node] {
switch [catch {eval apply [list $child] [list $cmd] $args} msg] {
0 {
# No action required
}
3 {
# break
return -code break
}
4 {
# continue - skip processing of siblings
return
}
1 -
2 -
default {
# propagate the error message
return -code error $msg
}
}
}
return {}
}
|
