Commits

Toby Inkster  committed 623bb72

complete reimplementation of overloading, using Tie::Hash and Hash::FieldHash; drops array overloading

  • Participants
  • Parent commits 9f8c2e1

Comments (0)

Files changed (4)

 use vars qw(@ISA);
 @ISA = ('XML::LibXML::Node');
 use XML::LibXML qw(:ns :libxml);
+use XML::LibXML::AttributeHash;
 use Carp;
 
 use overload
     '%{}'  => 'getAttributesHash',
-    '@{}'  => 'childNodes',
     'bool' => sub { 1 },
     ;
 
-sub getAttributesHash {
-    my $self = shift;
-    my %attr;
-    foreach ($self->attributes) {
-        next if $_->isa('XML::LibXML::Namespace');
-        my $ns  = $_->namespaceURI;
-        my $key = $_->localname;
-        $attr{defined $ns ? "{$ns}$key" : $key} = $_->value;
+{
+    # Note that we could generate a new hashref each time this
+    # is called. However, that breaks "each %$element" and
+    # "keys %$element". So instead we consistently return the
+    # same reference to the same (tied) hash. To do that, we
+    # need to use a fieldhash. Hash::FieldHash requires at least
+    # Perl 5.8, but XML-LibXML already dropped support for older
+    # Perls since XML-LibXML-1.77.
+    use Hash::FieldHash qw();
+    my %tiecache;
+    BEGIN { Hash::FieldHash::fieldhash(%tiecache) };
+    sub getAttributesHash {
+        my $self = shift;
+        if (!exists $tiecache{ $self }) {
+            tie my %attr, 'XML::LibXML::AttributeHash', $self;
+            $tiecache{ $self } = \%attr;
+        }
+        return $tiecache{ $self };
     }
-    \%attr
 }
 
 sub setNamespace {

File docs/libxml.dbk

 	  attributes, the attribute name is the hash key, and the attribute
 	  value is the hash value. For namespaced attributes, the hash key
 	  is qualified with the namespace URI, using Clark notation.</para>
-	  <para>XML::LibXML::Element overloads array dereferencing to
-	  provide access to the element's contents - all child text nodes
-	  and elements are included (including text nodes consisting
-	  entirely of whitespace).</para>
+          <para>Perl's "tied hash" feature is used, which means that the
+	  hash gives you read-write access to the element's attributes.
+          For more information, see <olink targetdoc="XML::LibXML::AttributeHash"
+          >XML::LibXML::AttributeHash</olink></para>
 	</sect1>
     </chapter>
 

File lib/XML/LibXML/AttributeHash.pm

+package XML::LibXML::AttributeHash;
+
+use strict;
+use warnings;
+use Tie::Hash;
+our @ISA = qw/Tie::Hash/;
+
+use vars qw($VERSION);
+$VERSION = "1.90"; # VERSION TEMPLATE: DO NOT CHANGE
+
+sub element {
+    return $_[0][0];
+}
+
+sub from_clark {
+    my ($self, $str) = @_;
+    if ($str =~ m! \{ (.+) \} (.+) !x) {
+        return ($1, $2);
+    }
+    return (undef, $str);
+}
+
+sub to_clark {
+    my ($self, $ns, $local) = @_;
+    defined $ns ? "{$ns}$local" : $local;
+}
+
+sub all_keys {
+    my ($self, @keys) = @_;
+    foreach ($self->element->attributes) {
+        next if $_->isa('XML::LibXML::Namespace');
+        push @keys, $self->to_clark($_->namespaceURI, $_->localname);
+    }
+    return sort @keys;
+}
+
+sub TIEHASH {
+    my ($class, $element) = @_;
+    bless [$element], $class;
+}
+
+sub STORE {
+    my ($self, $key, $value) = @_;
+    my ($key_ns, $key_local) = $self->from_clark($key);
+    if (defined $key_ns) {
+        return $self->element->setAttributeNS($key_ns, "xxx:$key_local", "$value");
+    }
+    else {
+        return $self->element->setAttribute($key_local, "$value");
+    }
+}
+
+sub FETCH {
+    my ($self, $key) = @_;
+    my ($key_ns, $key_local) = $self->from_clark($key);
+    if (defined $key_ns) {
+        return $self->element->getAttributeNS($key_ns, "$key_local");
+    }
+    else {
+        return $self->element->getAttribute($key_local);
+    }
+}
+
+sub EXISTS {
+    my ($self, $key) = @_;
+    my ($key_ns, $key_local) = $self->from_clark($key);
+    if (defined $key_ns) {
+        return $self->element->hasAttributeNS($key_ns, "$key_local");
+    }
+    else {
+        return $self->element->hasAttribute($key_local);
+    }
+}
+
+sub DELETE {
+    my ($self, $key) = @_;
+    my ($key_ns, $key_local) = $self->from_clark($key);
+    if (defined $key_ns) {
+        return $self->element->removeAttributeNS($key_ns, "$key_local");
+    }
+    else {
+        return $self->element->removeAttribute($key_local);
+    }
+}
+
+sub FIRSTKEY {
+    my ($self) = @_;
+    my @keys = $self->all_keys;
+    $self->[1] = \@keys;
+    if (wantarray) {
+        return ($keys[0], $self->FETCH($keys[0]));
+    }
+    $keys[0];
+}
+
+sub NEXTKEY {
+    my ($self, $lastkey) = @_;
+    my @keys = defined $self->[1] ? @{ $self->[1] } : $self->all_keys;
+    my $found;	
+    foreach my $k (@keys) {
+        next if $k le $lastkey;
+        $found = $k and last;
+    }
+    if (!defined $found) {
+        $self->[1] = undef;
+        return;
+    }
+    if (wantarray) {
+        return ($found, $self->FETCH($found));
+    }
+    return $found;
+}
+
+sub SCALAR {
+    my ($self) = @_;
+    return $self->element;
+}
+
+sub CLEAR {
+    my ($self) = @_;
+    foreach my $k ($self->all_keys) {
+        $self->DELETE($k);
+    }
+    return $self;
+}
+
+__PACKAGE__
+__END__
+
+=head1 NAME
+
+XML::LibXML::AttributeHash - tie an XML::LibXML::Element to a hash to access its attributes
+
+=head1 SYNOPSIS
+
+ tie my %hash, 'XML::LibXML::AttributeHash', $element;
+ $hash{'href'} = 'http://example.com/';
+ print $element->getAttribute('href') . "\n";
+
+=head1 DESCRIPTION
+
+This class allows an element's attributes to be accessed as if they were a
+plain old Perl hash. Attribute names become hash keys. Namespaced attributes
+are keyed using Clark notation.
+
+ my $XLINK = 'http://www.w3.org/1999/xlink';
+ tie my %hash, 'XML::LibXML::AttributeHash', $element;
+ $hash{"{$XLINK}href"} = 'http://localhost/';
+ print $element->getAttributeNS($XLINK, 'href') . "\n";
+
+There is rarely any need to use XML::LibXML::AttributeHash directly. In
+general, it is possible to take advantage of XML::LibXML::Element's
+overloading. The example in the SYNOPSIS could have been written:
+
+ $element->{'href'} = 'http://example.com/';
+ print $element->getAttribute('href') . "\n";
+

File t/71overloads.t

 use strict;
 use warnings;
-use Test::More tests => 6;
+use Test::More tests => 16;
 use XML::LibXML;
 
 my $root = XML::LibXML->load_xml( IO => \*DATA )->documentElement;
 
+# TEST
+ok
+	tied %$root,
+	'elements can be hash dereffed to a tied hash';
+
+# TEST
 isa_ok
-	$root->[0],
-	'XML::LibXML::Text',
-	'text nodes in array deref';
+	tied %$root,
+	'XML::LibXML::AttributeHash',
+	'tied %$element';
 
-isa_ok
-	$root->[1],
-	'XML::LibXML::Element',
-	'element nodes in array deref';
+# TEST
+ok
+	exists $root->{'attr1'},
+	'EXISTS non-namespaced';
 
+# TEST
 is
-	$root->[1]{'attr1'},
+	$root->{'attr1'},
 	'foo',
-	'non-namespaced attribute';
+	'FETCH non-namespaced';
 
+$root->{attr1} = 'bar';
+# TEST
+is 
+	$root->getAttribute('attr1'),
+	'bar',
+	'STORE non-namespaced';
+
+$root->{attr11} = 'baz';
+# TEST
+is 
+	$root->getAttribute('attr11'),
+	'baz',
+	'STORE (and create) non-namespaced';
+
+delete $root->{attr11};
+# TEST
+ok 
+	!$root->hasAttribute('attr11'),
+	'DELETE non-namespaced';
+
+while (my ($k, $v) = each %$root) {
+	if ($k eq 'attr1') {
+		# TEST
+		ok 1, 'FIRSTKEY/NEXTKEY non-namespaced'
+	}
+}
+
+# TEST
+ok
+	exists $root->{'{http://localhost/}attr2'},
+	'EXISTS namespaced';
+
+# TEST
 is
-	$root->[1]{'{http://localhost/}attr2'},
+	$root->{'{http://localhost/}attr2'},
 	'bar',
-	'namespaced attribute';
+	'FETCH namespaced';
 
+$root->{'{http://localhost/}attr2'} = 'quux';
+# TEST
 is
-	$root->[3][0]->textContent,
-	'Hello world',
-	'more deeply nested';
+	$root->getAttributeNS('http://localhost/', 'attr2'),
+	'quux',
+	'STORE namespaced';
 
+$root->{'{http://localhost/}attr22'} = 'quuux';
+# TEST
 is
-	$root->[3]{'attr1'},
-	'baz',
-	'things can overload @{} and %{} simultaneously';
+	$root->getAttributeNS('http://localhost/', 'attr22'),
+	'quuux',
+	'STORE (and create) namespaced';
+
+$root->{'{http://localhost/another}attr22'} = 'xyzzy';
+# TEST
+is
+	$root->getAttributeNS('http://localhost/another', 'attr22'),
+	'xyzzy',
+	'STORE (and create) namespaced, in new namespace';
+
+delete $root->{'{http://localhost/another}attr22'};
+# TEST
+ok 
+	!$root->hasAttributeNS('http://localhost/another', 'attr22'),
+	'DELETE namespaced';
+
+while (my ($k, $v) = each %$root) {
+	if ($k eq '{http://localhost/}attr22') {
+		# TEST
+		ok 1, 'FIRSTKEY/NEXTKEY namespaced'
+	}
+}
+
+# TEST
+like
+	$root->toStringEC14N,
+	qr{<root xmlns:x="http://localhost/" attr1="bar" x:attr2="quux" x:attr22="quuux"></root>},
+	'!!! toStringEC14N';
 
 __DATA__
-<root>
-	<elem1 attr1="foo" xmlns:x="http://localhost/" x:attr2="bar" />
-	<elem2 attr1="baz">Hello world</elem2>
-</root>
+<root attr1="foo" xmlns:x="http://localhost/" x:attr2="bar" />