Message/DOM/Attr.pm

package Message::DOM::Attr;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
push our @ISA, 'Message::DOM::Node', 'Message::IF::Attr';
require Message::DOM::Node;

sub ____new ($$$$$$) {
  my $self = shift->SUPER::____new (shift);
  ($$self->{owner_element},
   $$self->{namespace_uri},
   $$self->{prefix},
   $$self->{local_name}) = @_;
  Scalar::Util::weaken ($$self->{owner_element});
  $$self->{child_nodes} = [];
  $$self->{specified} = 1;
  return $self;
} # ____new
             
sub AUTOLOAD {
  my $method_name = our $AUTOLOAD;
  $method_name =~ s/.*:://;
  return if $method_name eq 'DESTROY';

  if ({
    ## Read-only attributes (trivial accessors)
    namespace_uri => 1,
    owner_element => 1,
  }->{$method_name}) {
    no strict 'refs';
    eval qq{
      sub $method_name (\$) {
        return \${\$_[0]}->{$method_name}; 
      }
    };
    goto &{ $AUTOLOAD };
  } else {
    require Carp;
    Carp::croak (qq<Can't locate method "$AUTOLOAD">);
  }
} # AUTOLOAD
sub owner_element ($);

## |Node| attributes

sub base_uri ($) {
  my $self = $_[0];
  local $Error::Depth = $Error::Depth + 1;
  my $oe = $self->owner_element;
  if ($oe) {
    my $ln = $self->local_name;
    my $nsuri = $self->namespace_uri;
    if (($ln eq 'base' and
         defined $nsuri and $nsuri eq 'http://www.w3.org/XML/1998/namespace') or
        ($ln eq 'xml:base' and not defined $nsuri)) {
      my $oep = $oe->parent_node;
      if ($oep) {
        return $oep->base_uri;
      } else {
        return $self->owner_document->base_uri;
      }
    } else {
      return $oe->base_uri;
    }
  } else {
    return $self->owner_document->base_uri;
  }
} # base_uri

sub local_name ($) {
  ## TODO: HTML5
  return ${+shift}->{local_name};
} # local_name

sub manakai_local_name ($) {
  return ${$_[0]}->{local_name};
} # manakai_local_name

sub namespace_uri ($);

## The name of the attribute [DOM1, DOM2].
## Same as |Attr.name| [DOM3].

*node_name = \&name;

sub node_type () { 2 } # ATTRIBUTE_NODE

## The value of the attribute [DOM1, DOM2].
## Same as |Attr.value| [DOM3].

*node_value = \&value;

sub prefix ($;$) {
  ## NOTE: No check for new value as Firefox doesn't do.
  ## See <http://suika.fam.cx/gate/2005/sw/prefix>.

  ## NOTE: Same as trivial setter except "" -> undef

  ## NOTE: Same as |Element|'s |prefix|.
  
  if (@_ > 1) {
    if (${${$_[0]}->{owner_document}}->{strict_error_checking} and 
        ${$_[0]}->{manakai_read_only}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }
    if (defined $_[1] and $_[1] ne '') {
      ${$_[0]}->{prefix} = ''.$_[1];
    } else {
      delete ${$_[0]}->{prefix};
    }
  }
  return ${$_[0]}->{prefix}; 
} # prefix

## |Attr| attributes

sub manakai_attribute_type ($;$) {
  my $self = $_[0];
  if (@_ > 1) {
    if (${$$self->{owner_document}}->{strict_error_checking}) {
      if ($$self->{manakai_read_only}) {
        report Message::DOM::DOMException
            -object => $self,
            -type => 'NO_MODIFICATION_ALLOWED_ERR',
            -subtype => 'READ_ONLY_NODE_ERR';
      }
    }
    if ($_[1]) {
      $$self->{manakai_attribute_type} = 0+$_[1];
    } else {
      delete $$self->{manakai_attribute_type};
    }
  }
  
  return $$self->{manakai_attribute_type} || 0;
} # manakai_attribute_type

## TODO: HTML5 case stuff?
sub name ($) {
  my $self = shift;
  if (defined $$self->{prefix}) {
    return $$self->{prefix} . ':' . $$self->{local_name};
  } else {
    return $$self->{local_name};
  }
} # name

sub specified ($;$) {
  if (@_ > 1) {
    ## NOTE: A manakai extension.
    if (${${$_[0]}->{owner_document}}->{strict_error_checking} and 
        ${$_[0]}->{manakai_read_only}) {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NO_MODIFICATION_ALLOWED_ERR',
          -subtype => 'READ_ONLY_NODE_ERR';
    }
    if ($_[1] or not defined ${$_[0]}->{owner_element}) {
      ${$_[0]}->{specified} = 1;
    } else {
      delete ${$_[0]}->{specified};
    }
  }
  return ${$_[0]}->{specified}; 
} # specified

sub value ($;$) {
  ## TODO:
  shift->text_content (@_);
} # value

package Message::IF::Attr;

package Message::DOM::Document;

sub create_attribute ($$) {
  if (${$_[0]}->{strict_error_checking}) {
    my $xv = $_[0]->xml_version;
    ## TODO: HTML Document ??
    if (defined $xv) {
      if ($xv eq '1.0' and
          $_[1] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
        #
      } elsif ($xv eq '1.1' and
               $_[1] =~ /\A\p{InXMLNameStartChar11}\p{InXMLNameChar11}*\z/) {
        # 
      } else {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'INVALID_CHARACTER_ERR',
            -subtype => 'MALFORMED_NAME_ERR';
      }
    }
  }
  ## TODO: HTML5
  return Message::DOM::Attr->____new ($_[0], undef, undef, undef, $_[1]);
} # create_attribute

sub create_attribute_ns ($$$) {
  my ($prefix, $lname);
  if (ref $_[2] eq 'ARRAY') {
    ($prefix, $lname) = @{$_[2]};
  } else {
    ($prefix, $lname) = split /:/, $_[2], 2;
    ($prefix, $lname) = (undef, $prefix) unless defined $lname;
  }

  if (${$_[0]}->{strict_error_checking}) {
    my $xv = $_[0]->xml_version;
    ## TODO: HTML Document ?? (NOT_SUPPORTED_ERR is different from what Web browsers do)
    if (defined $xv) {
      if ($xv eq '1.0') {
        if (ref $_[2] eq 'ARRAY' or
            $_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
          if (defined $prefix) {
            if ($prefix =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
              #
            } else {
              report Message::DOM::DOMException
                  -object => $_[0],
                  -type => 'NAMESPACE_ERR',
                  -subtype => 'MALFORMED_QNAME_ERR';
            }
          }
          if ($lname =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
            #
          } else {
            report Message::DOM::DOMException
                -object => $_[0],
                -type => 'NAMESPACE_ERR',
                -subtype => 'MALFORMED_QNAME_ERR';
          }
        } else {
          report Message::DOM::DOMException
              -object => $_[0],
              -type => 'INVALID_CHARACTER_ERR',
              -subtype => 'MALFORMED_NAME_ERR';
        }
      } elsif ($xv eq '1.1') {
        if (ref $_[2] eq 'ARRAY' or
            $_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
          if (defined $prefix) {
            if ($prefix =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
              #
            } else {
              report Message::DOM::DOMException
                  -object => $_[0],
                  -type => 'NAMESPACE_ERR',
                  -subtype => 'MALFORMED_QNAME_ERR';
            }
          }
          if ($lname =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
            #
          } else {
            report Message::DOM::DOMException
                -object => $_[0],
                -type => 'NAMESPACE_ERR',
                -subtype => 'MALFORMED_QNAME_ERR';
          }
        } else {
          report Message::DOM::DOMException
              -object => $_[0],
              -type => 'INVALID_CHARACTER_ERR',
              -subtype => 'MALFORMED_NAME_ERR';
        }
      } else {
        die "create_attribute_ns: XML version |$xv| is not supported";
      }
    }

    if (defined $prefix) {
      if (not defined $_[1]) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'PREFIXED_NULLNS_ERR';
      } elsif ($prefix eq 'xml' and 
               $_[1] ne q<http://www.w3.org/XML/1998/namespace>) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'XMLPREFIX_NONXMLNS_ERR';
      } elsif ($prefix eq 'xmlns' and
               $_[1] ne q<http://www.w3.org/2000/xmlns/>) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'XMLNSPREFIX_NONXMLNSNS_ERR';
      } elsif ($_[1] eq q<http://www.w3.org/2000/xmlns/> and
               $prefix ne 'xmlns') {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
      }
    } else { # no prefix
      if ($lname eq 'xmlns' and
          (not defined $_[1] or $_[1] ne q<http://www.w3.org/2000/xmlns/>)) {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'XMLNS_NONXMLNSNS_ERR';
      } elsif (not defined $_[1]) {
        #
      } elsif ($_[1] eq q<http://www.w3.org/2000/xmlns/> and
               $lname ne 'xmlns') {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NAMESPACE_ERR',
            -subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
      }
    }
  }

  ## TODO: Older version of manakai set |attribute_type|
  ## attribute for |xml:id| attribute.  Should we support this?

  return Message::DOM::Attr->____new ($_[0], undef, $_[1], $prefix, $lname);
} # create_attribute_ns

=head1 LICENSE

Copyright 2007 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1;
## $Date: 2007/06/17 13:37:40 $
1	wakaba	1.1	package Message::DOM::Attr;
2			use strict;
3	wakaba	1.7	our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1	push our @ISA, 'Message::DOM::Node', 'Message::IF::Attr';
5			require Message::DOM::Node;
6
7			sub ____new ($$$$$$) {
8			my $self = shift->SUPER::____new (shift);
9			($$self->{owner_element},
10			$$self->{namespace_uri},
11			$$self->{prefix},
12			$$self->{local_name}) = @_;
13			Scalar::Util::weaken ($$self->{owner_element});
14	wakaba	1.4	$$self->{child_nodes} = [];
15	wakaba	1.6	$$self->{specified} = 1;
16	wakaba	1.1	return $self;
17			} # ____new
18
19			sub AUTOLOAD {
20			my $method_name = our $AUTOLOAD;
21			$method_name =~ s/.*:://;
22			return if $method_name eq 'DESTROY';
23
24			if ({
25			## Read-only attributes (trivial accessors)
26	wakaba	1.3	namespace_uri => 1,
27	wakaba	1.1	owner_element => 1,
28			}->{$method_name}) {
29			no strict 'refs';
30			eval qq{
31			sub $method_name (\$) {
32			return \${\$_[0]}->{$method_name};
33			}
34			};
35			goto &{ $AUTOLOAD };
36			} else {
37			require Carp;
38			Carp::croak (qq<Can't locate method "$AUTOLOAD">);
39			}
40			} # AUTOLOAD
41			sub owner_element ($);
42
43	wakaba	1.6	## \|Node\| attributes
44
45			sub base_uri ($) {
46			my $self = $_[0];
47			local $Error::Depth = $Error::Depth + 1;
48			my $oe = $self->owner_element;
49			if ($oe) {
50			my $ln = $self->local_name;
51			my $nsuri = $self->namespace_uri;
52			if (($ln eq 'base' and
53			defined $nsuri and $nsuri eq 'http://www.w3.org/XML/1998/namespace') or
54			($ln eq 'xml:base' and not defined $nsuri)) {
55			my $oep = $oe->parent_node;
56			if ($oep) {
57			return $oep->base_uri;
58			} else {
59			return $self->owner_document->base_uri;
60			}
61			} else {
62			return $oe->base_uri;
63			}
64			} else {
65			return $self->owner_document->base_uri;
66			}
67			} # base_uri
68	wakaba	1.1
69	wakaba	1.3	sub local_name ($) {
70			## TODO: HTML5
71			return ${+shift}->{local_name};
72			} # local_name
73
74			sub manakai_local_name ($) {
75	wakaba	1.6	return ${$_[0]}->{local_name};
76	wakaba	1.3	} # manakai_local_name
77
78			sub namespace_uri ($);
79	wakaba	1.2
80			## The name of the attribute [DOM1, DOM2].
81			## Same as \|Attr.name\| [DOM3].
82
83			*node_name = \&name;
84
85			sub node_type () { 2 } # ATTRIBUTE_NODE
86
87			## The value of the attribute [DOM1, DOM2].
88			## Same as \|Attr.value\| [DOM3].
89
90			*node_value = \&value;
91	wakaba	1.1
92	wakaba	1.3	sub prefix ($;$) {
93	wakaba	1.5	## NOTE: No check for new value as Firefox doesn't do.
94			## See <http://suika.fam.cx/gate/2005/sw/prefix>.
95
96			## NOTE: Same as trivial setter except "" -> undef
97
98			## NOTE: Same as \|Element\|'s \|prefix\|.
99
100			if (@_ > 1) {
101	wakaba	1.6	if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
102			${$_[0]}->{manakai_read_only}) {
103	wakaba	1.5	report Message::DOM::DOMException
104			-object => $_[0],
105			-type => 'NO_MODIFICATION_ALLOWED_ERR',
106			-subtype => 'READ_ONLY_NODE_ERR';
107			}
108			if (defined $_[1] and $_[1] ne '') {
109			${$_[0]}->{prefix} = ''.$_[1];
110			} else {
111			delete ${$_[0]}->{prefix};
112			}
113			}
114			return ${$_[0]}->{prefix};
115	wakaba	1.3	} # prefix
116
117	wakaba	1.6	## \|Attr\| attributes
118
119			sub manakai_attribute_type ($;$) {
120			my $self = $_[0];
121			if (@_ > 1) {
122			if (${$$self->{owner_document}}->{strict_error_checking}) {
123			if ($$self->{manakai_read_only}) {
124			report Message::DOM::DOMException
125			-object => $self,
126			-type => 'NO_MODIFICATION_ALLOWED_ERR',
127			-subtype => 'READ_ONLY_NODE_ERR';
128			}
129			}
130			if ($_[1]) {
131			$$self->{manakai_attribute_type} = 0+$_[1];
132			} else {
133			delete $$self->{manakai_attribute_type};
134			}
135			}
136
137			return $$self->{manakai_attribute_type} \|\| 0;
138			} # manakai_attribute_type
139	wakaba	1.1
140			## TODO: HTML5 case stuff?
141			sub name ($) {
142			my $self = shift;
143			if (defined $$self->{prefix}) {
144			return $$self->{prefix} . ':' . $$self->{local_name};
145			} else {
146			return $$self->{local_name};
147			}
148			} # name
149
150	wakaba	1.6	sub specified ($;$) {
151	wakaba	1.1	if (@_ > 1) {
152	wakaba	1.6	## NOTE: A manakai extension.
153			if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
154			${$_[0]}->{manakai_read_only}) {
155			report Message::DOM::DOMException
156			-object => $_[0],
157			-type => 'NO_MODIFICATION_ALLOWED_ERR',
158			-subtype => 'READ_ONLY_NODE_ERR';
159			}
160			if ($_[1] or not defined ${$_[0]}->{owner_element}) {
161			${$_[0]}->{specified} = 1;
162			} else {
163			delete ${$_[0]}->{specified};
164			}
165	wakaba	1.1	}
166	wakaba	1.6	return ${$_[0]}->{specified};
167			} # specified
168
169			sub value ($;$) {
170			## TODO:
171			shift->text_content (@_);
172	wakaba	1.1	} # value
173
174			package Message::IF::Attr;
175
176			package Message::DOM::Document;
177
178			sub create_attribute ($$) {
179	wakaba	1.7	if (${$_[0]}->{strict_error_checking}) {
180			my $xv = $_[0]->xml_version;
181			## TODO: HTML Document ??
182			if (defined $xv) {
183			if ($xv eq '1.0' and
184			$_[1] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
185			#
186			} elsif ($xv eq '1.1' and
187			$_[1] =~ /\A\p{InXMLNameStartChar11}\p{InXMLNameChar11}*\z/) {
188			#
189			} else {
190			report Message::DOM::DOMException
191			-object => $_[0],
192			-type => 'INVALID_CHARACTER_ERR',
193			-subtype => 'MALFORMED_NAME_ERR';
194			}
195			}
196			}
197	wakaba	1.1	## TODO: HTML5
198			return Message::DOM::Attr->____new ($_[0], undef, undef, undef, $_[1]);
199			} # create_attribute
200
201			sub create_attribute_ns ($$$) {
202			my ($prefix, $lname);
203			if (ref $_[2] eq 'ARRAY') {
204			($prefix, $lname) = @{$_[2]};
205			} else {
206			($prefix, $lname) = split /:/, $_[2], 2;
207			($prefix, $lname) = (undef, $prefix) unless defined $lname;
208			}
209	wakaba	1.7
210			if (${$_[0]}->{strict_error_checking}) {
211			my $xv = $_[0]->xml_version;
212			## TODO: HTML Document ?? (NOT_SUPPORTED_ERR is different from what Web browsers do)
213			if (defined $xv) {
214			if ($xv eq '1.0') {
215			if (ref $_[2] eq 'ARRAY' or
216			$_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
217			if (defined $prefix) {
218			if ($prefix =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
219			#
220			} else {
221			report Message::DOM::DOMException
222			-object => $_[0],
223			-type => 'NAMESPACE_ERR',
224			-subtype => 'MALFORMED_QNAME_ERR';
225			}
226			}
227			if ($lname =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
228			#
229			} else {
230			report Message::DOM::DOMException
231			-object => $_[0],
232			-type => 'NAMESPACE_ERR',
233			-subtype => 'MALFORMED_QNAME_ERR';
234			}
235			} else {
236			report Message::DOM::DOMException
237			-object => $_[0],
238			-type => 'INVALID_CHARACTER_ERR',
239			-subtype => 'MALFORMED_NAME_ERR';
240			}
241			} elsif ($xv eq '1.1') {
242			if (ref $_[2] eq 'ARRAY' or
243			$_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
244			if (defined $prefix) {
245			if ($prefix =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
246			#
247			} else {
248			report Message::DOM::DOMException
249			-object => $_[0],
250			-type => 'NAMESPACE_ERR',
251			-subtype => 'MALFORMED_QNAME_ERR';
252			}
253			}
254			if ($lname =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
255			#
256			} else {
257			report Message::DOM::DOMException
258			-object => $_[0],
259			-type => 'NAMESPACE_ERR',
260			-subtype => 'MALFORMED_QNAME_ERR';
261			}
262			} else {
263			report Message::DOM::DOMException
264			-object => $_[0],
265			-type => 'INVALID_CHARACTER_ERR',
266			-subtype => 'MALFORMED_NAME_ERR';
267			}
268			} else {
269			die "create_attribute_ns: XML version \|$xv\| is not supported";
270			}
271			}
272
273			if (defined $prefix) {
274			if (not defined $_[1]) {
275			report Message::DOM::DOMException
276			-object => $_[0],
277			-type => 'NAMESPACE_ERR',
278			-subtype => 'PREFIXED_NULLNS_ERR';
279			} elsif ($prefix eq 'xml' and
280			$_[1] ne q<http://www.w3.org/XML/1998/namespace>) {
281			report Message::DOM::DOMException
282			-object => $_[0],
283			-type => 'NAMESPACE_ERR',
284			-subtype => 'XMLPREFIX_NONXMLNS_ERR';
285			} elsif ($prefix eq 'xmlns' and
286			$_[1] ne q<http://www.w3.org/2000/xmlns/>) {
287			report Message::DOM::DOMException
288			-object => $_[0],
289			-type => 'NAMESPACE_ERR',
290			-subtype => 'XMLNSPREFIX_NONXMLNSNS_ERR';
291			} elsif ($_[1] eq q<http://www.w3.org/2000/xmlns/> and
292			$prefix ne 'xmlns') {
293			report Message::DOM::DOMException
294			-object => $_[0],
295			-type => 'NAMESPACE_ERR',
296			-subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
297			}
298			} else { # no prefix
299			if ($lname eq 'xmlns' and
300			(not defined $_[1] or $_[1] ne q<http://www.w3.org/2000/xmlns/>)) {
301			report Message::DOM::DOMException
302			-object => $_[0],
303			-type => 'NAMESPACE_ERR',
304			-subtype => 'XMLNS_NONXMLNSNS_ERR';
305			} elsif (not defined $_[1]) {
306			#
307			} elsif ($_[1] eq q<http://www.w3.org/2000/xmlns/> and
308			$lname ne 'xmlns') {
309			report Message::DOM::DOMException
310			-object => $_[0],
311			-type => 'NAMESPACE_ERR',
312			-subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
313			}
314			}
315			}
316
317			## TODO: Older version of manakai set \|attribute_type\|
318			## attribute for \|xml:id\| attribute. Should we support this?
319
320	wakaba	1.1	return Message::DOM::Attr->____new ($_[0], undef, $_[1], $prefix, $lname);
321	wakaba	1.7	} # create_attribute_ns
322
323			=head1 LICENSE
324
325			Copyright 2007 Wakaba <w@suika.fam.cx>
326
327			This program is free software; you can redistribute it and/or
328			modify it under the same terms as Perl itself.
329
330			=cut
331	wakaba	1.1
332			1;
333	wakaba	1.7	## $Date: 2007/06/17 13:37:40 $