GeniXML.pm.in 7.8 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
#!/usr/bin/perl -w
#
# GENIPUBLIC-COPYRIGHT
# Copyright (c) 2010 University of Utah and the Flux Group.
# All rights reserved.
#
package GeniXML;

use strict;
use Exporter;
use vars qw(@ISA @EXPORT);

@ISA = "Exporter";
14
@EXPORT = qw(Parse ParseFile FindNodes FindNodesNS FindFirst FindElement FindAttr IsLanNode IsLocalNode GetNodeId GetVirtualId GetManagerId SetText GetText CreateDocument AddElement);
15
16
17

use English;
use XML::LibXML;
18
19
use XML::LibXML::XPathContext;
use XML::LibXML::NodeList;
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
use GeniHRN;
use Carp qw(cluck carp);

# Configure variables
# Configure variables
my $TB		   = "@prefix@";
my $TBOPS          = "@TBOPSEMAIL@";

# Returns the document element by parsing a given string. If the
# string fails to parse, returns undefined.
sub Parse($)
{
    my ($xml) = @_;
    my $parser = XML::LibXML->new;
    my $doc;
    eval {
        $doc = $parser->parse_string($xml);
    };
    if ($@) {
39
	carp("Failed to parse xml string: $@\nXML: $xml\n\n");
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
	return undef;
    } else {
	return $doc->documentElement();
    }
}

sub ParseFile($)
{
    my ($file) = @_;
    my $parser = XML::LibXML->new;
    my $doc;
    eval {
        $doc = $parser->parse_file($file);
    };
    if ($@) {
55
	carp("Failed to parse xml string: $@");
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
	return undef;
    } else {
	return $doc->documentElement();
    }
}

# Returns a NodeList for a given XPath using a given node as
# context. 'n' is defined to be the prefix for the namespace of the
# node.
sub FindNodes($$)
{
    my ($path, $node) = @_;
    my $result = undef;
    my $ns = undef;
    eval {
	my $xc = XML::LibXML::XPathContext->new();
	$ns = $node->namespaceURI();
	if (defined($ns)) {
74
	    $xc->registerNs('n', $ns);
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
	} else {
	    $path =~ s/\bn://g;
	}
	$result = $xc->findnodes($path, $node);
    };
    if ($@) {
	if (! defined($ns)) {
	    $ns = "undefined";
	}
        cluck "Failed to find nodes using XPath path='$path', ns='$ns': $@\n";
	return XML::LibXML::NodeList->new();
    } else {
	return $result;
    }
}

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
# Returns a NodeList for a given XPath using a given namespace as
# context. 'n' is defined to be the prefix for the given namespace.
sub FindNodesNS($$$)
{
    my ($path, $node, $nsURI) = @_;
    my $result = undef;
    eval { 
  my $xc = XML::LibXML::XPathContext->new();
  if (defined($nsURI)) {
      $xc->registerNs('n', $nsURI);
  } else {
      $path =~ s/\bn://g;
  }
  $result = $xc->findnodes($path, $node);
    };
    if ($@) {
  if (! defined($nsURI)) {
      $nsURI = "undefined";
  }
        cluck "Failed to find nodes using XPath path='$path', nsURI='$nsURI': $@\n";        
  return XML::LibXML::NodeList->new();
    } else { 
  return $result;
    } 
}


118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
# Returns the first Node which matches a given XPath against a given
# node. If that node is not of the specified type, returns
# undefined. Works like FindNodes.
sub FindNodeType($$$)
{
    my ($path, $node, $type) = @_;
    my $result = FindNodes($path, $node)->pop();
    if (defined($result) && $result->nodeType() != $type) {
	$result = undef;
    }
    return $result;
}

# Returns the first Node which matches a given XPath.
sub FindFirst($$)
{
    my ($path, $node) = @_;
    return FindNodes($path, $node)->pop();
}

# Returns the first Element which matches a given XPath.
sub FindElement($$)
{
    my ($path, $node) = @_;
    return FindNodeType($path, $node, XML_ELEMENT_NODE);
}

# Returns the first Attribute which matches a given XPath.
sub FindAttr($$)
{
    my ($path, $node) = @_;
    return FindNodeType($path, $node, XML_ATTRIBUTE_NODE);
}

# Returns true if a given XML Node is an RSpec node and is of type lan
sub IsLanNode($)
{
    my ($node) = @_;
    my $result = 0;
    if (defined($node) && $node->localname() eq "node") {
158
159
160
	foreach my $lan (FindNodes("n:node_type", $node)->get_nodelist()) {
	    my $typeName = GetText("type_name", $lan);
	    if (defined($typeName) && $typeName eq "lan") {
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
		$result = 1;
		last;
	    }
	}
    }
    return $result;
}

# Returns true if a given XML Node is an RSpec node and either has
# the current CM as a 'component_manager_urn' or
# 'component_manager_uuid or no component_manager defined.
sub IsLocalNode($)
{
    my ($node) = @_;
    my $result = 0;
    if (defined($node) && $node->localname() eq "node") {
177
	my $manager_uuid  = GetManagerId($node);
178
179
180
181
182
183
184
185
186
187
188
189
190
191
	if (! defined($manager_uuid) ||
	    GeniHRN::Equal($manager_uuid, $ENV{'MYURN'}) ||
	    $manager_uuid eq $ENV{'MYUUID'}) {

	    $result = 1;
	}
    }
    return $result;
}

# Returns the uuid or urn of an RSpec node or undef if it is not a node.
sub GetNodeId($)
{
    my ($node) = @_;
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
    return GetText("component_uuid", $node) ||
	GetText("component_urn", $node) ||
	GetText("uuid", $node);
}

sub GetVirtualId($)
{
    my ($node) = @_;
    return GetText("virtual_id", $node) ||
	GetText("nickname", $node);
}

sub GetManagerId($)
{
    my ($node) = @_;
    return GetText("component_manager_uuid", $node) ||
	GetText("component_manager_urn", $node);
209
210
211
212
213
214
215
216
217
218
219
}

# Takes an attribute/element name, *NOT AN XPATH* and a node and sets
# the text of that node to a particular value. If the node is an
# attribute, the value is set. If it is an element with just a text
# node child, that node is replaced.
# Returns 1 on success and 0 on failure.
sub SetText($$$)
{
    my ($name, $node, $text) = @_;
    my $result = 0;
220
221
222
223
    my $child = FindFirst('@n:'.$name, $node);
    if (! defined($child)) {
	$child = FindFirst('@'.$name, $node);
    }
224
225
226
227
    if (defined($child)) {
	if ($child->nodeType() == XML_ATTRIBUTE_NODE) {
	    $child->setValue($text);
	    $result = 1;
228
229
	}
    } else {
230
	$child = FindFirst('n:'.$name, $node);
231
	if (defined($child)) {
232
233
234
235
236
237
238
239
	    my @grand = $child->childNodes();
	    if (scalar(@grand) == 1
		&& $grand[0]->nodeType() == XML_TEXT_NODE) {
		$grand[0]->setData($text);
		$result = 1;
	    } elsif (scalar(@grand) == 0
		     && $child->nodeType() == XML_ELEMENT_NODE) {
		$child->appendText($text);
240
		$result = 1;
241
	    }
242
	} elsif ($node->nodeType() == XML_ELEMENT_NODE) {
243
244
	    my $ns = $node->namespaceURI();
	    if (defined($ns)) {
245
246
247
# TODO: Submit bug report for the library. This call is bugged.
#		$node->setAttributeNS($ns, "rs:$name", $text);
		$node->setAttribute($name, $text);
248
249
250
	    } else {
		$node->setAttribute($name, $text);
	    }
251
	    $result = 1;
252
253
254
255
256
	}
    }
    return $result;
}

257
258
# Get the text contents of a child of a node with a particular
# name. This can be either an attribute or an element.
259
260
sub GetText($$)
{
261
    my ($name, $node) = @_;
262
    my $result = undef;
263
264
265
266
    my $child = FindFirst('@n:'.$name, $node);
    if (! defined($child)) {
	$child = FindFirst('@'.$name, $node);
    }
267
268
269
    if (! defined($child)) {
	$child = FindFirst('n:'.$name, $node);
    }
270
271
272
273
274
275
    if (defined($child)) {
	$result = $child->textContent();
    }
    return $result;
}

276
277
278
279
280
281
282
283
284
285
286
# Converts the XML representation of a node to a UTF-8 string and
# outputs it as a complete XML document.
sub Serialize($)
{
    my ($node) = @_;
    my $newnode = $node->cloneNode(1);
    return $newnode->toString();
}

# Create a new XML document with a given namespace URI and document
# element name.
287
288
289
290
sub CreateDocument($$)
{
    my ($ns, $name) = @_;
    my $doc = XML::LibXML::Document->createDocument("1.0", "UTF-8");
291
292
293
    my $root = $doc->createElementNS($ns, "rs:$name");
    $doc->setDocumentElement($root);
    return $doc;
294
295
}

296
297
# Add a new element to a node. The new element will have the given
# name and be otherwise empty.
298
299
300
sub AddElement($$)
{
    my ($name, $node) = @_;
301
302
303
    my $ns = $node->namespaceURI();
    my $child = $node->addNewChild($ns, "rs:$name");
    return $child;
304
305
}

306
307
# Remove a node with a given name from a node. It will be removed
# whether it is an attribute or an element. The name is not an xpath.
308
309
310
311
312
313
314
315
316
317
318
319
sub RemoveChild($$)
{
    my ($name, $node) = @_;
    my $child = FindFirst('@n:'.$name, $node);
    if (! defined($child)) {
	$child = FindFirst('n:'.$name, $node);
    }
    if (defined($child)) {
	$node->removeChild($child);
    }
}

320
321
# _Always_ make sure that this 1 is at the end of the file...
1;