/[suikacvs]/messaging/manakai/lib/Message/DOM/Node.pm
Suika

Diff of /messaging/manakai/lib/Message/DOM/Node.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by wakaba, Sun Jun 17 13:37:40 2007 UTC revision 1.8 by wakaba, Wed Jun 20 13:41:16 2007 UTC
# Line 135  sub child_nodes ($) { Line 135  sub child_nodes ($) {
135    return bless \\($_[0]), 'Message::DOM::NodeList::ChildNodeList';    return bless \\($_[0]), 'Message::DOM::NodeList::ChildNodeList';
136  } # child_nodes  } # child_nodes
137    
138    sub manakai_expanded_uri ($) {
139      my $self = shift;
140      local $Error::Depth = $Error::Depth + 1;
141      my $ln = $self->local_name;
142      if (defined $ln) {
143        my $nsuri = $self->namespace_uri;
144        if (defined $nsuri) {
145          return $nsuri . $ln;
146        } else {
147          return $ln;
148        }
149      } else {
150        return undef;
151      }
152    } # manakai_expanded_uri
153    
154  sub first_child ($) {  sub first_child ($) {
155    my $self = shift;    my $self = shift;
156    return $$self->{child_nodes} ? $$self->{child_nodes}->[0] : undef;    return $$self->{child_nodes} ? $$self->{child_nodes}->[0] : undef;
# Line 179  sub node_value () { undef } Line 195  sub node_value () { undef }
195    
196  sub owner_document ($);  sub owner_document ($);
197    
198    sub manakai_parent_element ($) {
199      my $self = shift;
200      my $parent = $$self->{parent_node};
201      while (defined $parent) {
202        if ($parent->node_type == ELEMENT_NODE) {
203          return $parent;
204        } else {
205          $parent = $$parent->{parent_node};
206        }
207      }
208      return undef;
209    } # manakai_parent_element
210    
211  sub parent_node ($);  sub parent_node ($);
212    
213  ## NOTE: Overridden by |Element| and |Attr|.  ## NOTE: Overridden by |Element| and |Attr|.
# Line 252  sub text_content ($;$) { Line 281  sub text_content ($;$) {
281    
282  ## |Node| methods  ## |Node| methods
283    
284    sub clone_node ($;$) {
285      my ($self, $deep) = @_;
286    
287      ## ISSUE: Need definitions for the cloning operation
288      ## for ElementTypeDefinition, and AttributeDefinition nodes,
289      ## as well as new attributes introduced in DOM XML Document Type Definition
290      ## module.
291      ## ISSUE: Define if default attributes and attributedefinition are inconsistent
292    
293      local $Error::Depth = $Error::Depth + 1;
294      my $od = $self->owner_document;
295      my $strict_check = $od->strict_error_checking;
296      $od->strict_error_checking (0);
297      my $cfg = $od->dom_config;
298      my $er_copy_asis = $cfg->{'http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree'};
299    
300      my $r;
301      my @udh;
302      my @node = ([$self]);
303      while (@node) {
304        my ($node, $parent) = @{shift @node};
305        my $nt = $node->node_type;
306        my $clone;
307        if ($nt == ELEMENT_NODE) {
308          $clone = $od->create_element_ns
309            ($node->namespace_uri, [$node->prefix, $node->local_name]);
310          if ($parent) {
311            $parent->append_child ($clone);
312          } else {
313            $r = $clone;
314          }
315          my $attrs = $node->attributes;
316          my $attrsMax = @$attrs - 1;
317          for my $i (0..$attrsMax) {
318            my $attr = $attrs->[$i];
319            push @node, [$attr, $clone] if $attr->specified;
320          }
321          if ($deep) {
322            push @node, map {[$_, $clone]} @{$node->child_nodes};
323          }
324        } elsif ($nt == TEXT_NODE) {
325          $clone = $od->create_text_node ($node->data);
326          if ($parent) {
327            $parent->append_child ($clone);
328          } else {
329            $r = $clone;
330          }
331          $clone->element_content_whitespace (1)
332            if $node->element_content_whitespace;
333        } elsif ($nt == ATTRIBUTE_NODE) {
334          $clone = $od->create_attribute_ns
335            ($node->namespace_uri, [$node->prefix, $node->local_name]);
336          if ($parent) {
337            $parent->set_attribute_node_ns ($clone);
338          } else {
339            $r = $clone;
340          }
341          $clone->specified (1);
342          push @node, map {[$_, $clone]} @{$node->child_nodes};
343        } elsif ($nt == COMMENT_NODE) {
344          $clone = $od->create_comment ($node->data);
345          if ($parent) {
346            $parent->append_child ($clone);
347          } else {
348            $r = $clone;
349          }
350        } elsif ($nt == CDATA_SECTION_NODE) {
351          $clone = $od->create_cdata_section ($node->data);
352          if ($parent) {
353            $parent->append_child ($clone);
354          } else {
355            $r = $clone;
356          }
357        } elsif ($nt == PROCESSING_INSTRUCTION_NODE) {
358          $clone = $od->create_processing_instruction
359            ($node->target, $node->data);
360          if ($parent) {
361            $parent->append_child ($clone);
362          } else {
363            $r = $clone;
364          }
365        } elsif ($nt == ENTITY_REFERENCE_NODE) {
366          $clone = $od->create_entity_reference ($node->node_name);
367          if ($er_copy_asis) {
368            $clone->manakai_set_read_only (0);
369            $clone->text_content (0);
370            for (@{$node->child_nodes}) {
371              $clone->append_child ($_->clone_node (1));
372            }
373            $clone->manakai_expanded ($node->manakai_expanded);
374            $clone->manakai_set_read_only (1, 1);
375          } # copy asis
376          if ($parent) {
377            $parent->append_child ($clone);
378          } else {
379            $r = $clone;
380          }
381        } elsif ($nt == DOCUMENT_FRAGMENT_NODE) {
382          $clone = $od->create_document_fragment;
383          $r = $clone;
384          push @node, map {[$_, $clone]} @{$node->child_nodes};
385        } elsif ($nt == DOCUMENT_NODE) {
386          $od->strict_error_checking ($strict_check);
387          report Message::DOM::DOMException
388              -object => $self,
389              -type => 'NOT_SUPPORTED_ERR',
390              -subtype => 'CLONE_NODE_NOT_SUPPORTED_ERR';
391        } elsif ($nt == DOCUMENT_TYPE_NODE) {
392          $od->strict_error_checking ($strict_check);
393          report Message::DOM::DOMException
394              -object => $self,
395              -type => 'NOT_SUPPORTED_ERR',
396              -subtype => 'CLONE_NODE_NOT_SUPPORTED_ERR';
397        } elsif ($nt == ENTITY_NODE) {
398          $od->strict_error_checking ($strict_check);
399          report Message::DOM::DOMException
400              -object => $self,
401              -type => 'NOT_SUPPORTED_ERR',
402              -subtype => 'CLONE_NODE_NOT_SUPPORTED_ERR';
403        } elsif ($nt == NOTATION_NODE) {
404          $od->strict_error_checking ($strict_check);
405          report Message::DOM::DOMException
406              -object => $self,
407              -type => 'NOT_SUPPORTED_ERR',
408              -subtype => 'CLONE_NODE_NOT_SUPPORTED_ERR';
409        } else {
410          $od->strict_error_checking ($strict_check);
411          report Message::DOM::DOMException
412              -object => $self,
413              -type => 'NOT_SUPPORTED_ERR',
414              -subtype => 'CLONE_NODE_NOT_SUPPORTED_ERR';
415        }
416    
417        my $udhs = $$self->{user_data};
418        push @udh, [$node => $clone, $udhs] if $udhs and %$udhs;
419      } # @node
420      $od->strict_error_checking (1) if $strict_check;
421      
422      ## Calling user data handlers if any
423      for my $sd (@udh) {
424        my $src = $sd->[0];
425        my $src_ud = $sd->[2];
426        for my $key (keys %{$src_ud}) {
427          my $dh = $src_ud->{$key}->[1];
428          if ($dh) {     ## NODE_CLONED
429            $dh->handle (1, $key, $src_ud->{$key}->[0], $src, $sd->[1]);
430            ## ISSUE: |handler| method? CODE?
431          }
432        }
433      }
434    
435      return $r;
436    } # clone_node
437    
438    sub compare_document_position ($$) {
439      ## ISSUE: There are implementation specifics
440      ## (see what Gecko does if it implement this method...)
441    
442      ## ISSUE: Maybe we should overload <=> or cmp
443    
444      ## TODO: Too long method name!  Too long constant names!
445      ## Too many thing to be done by a method!
446      ## Maybe we should import simpler method implemented by IE.
447    
448      ## ISSUE: Need documentation for ElementTypeDefinition and AttributeDefinition
449      ## concerns
450    
451      my @acontainer = ($_[0]);
452      my @bcontainer = ($_[1]);
453      F: {
454        A: while (1) {
455          if ($acontainer[-1] eq $bcontainer[-1]) {
456            last F;
457          } else {
458            my $ap;
459            my $atype = $acontainer[-1]->node_type;
460            if ($atype == ATTRIBUTE_NODE) {
461              $ap = $acontainer[-1]->owner_element;
462            } elsif ($atype == ENTITY_NODE or $atype == NOTATION_NODE or
463                     $atype == ELEMENT_TYPE_DEFINITION_NODE) {
464              $ap = $acontainer[-1]->owner_document_type_definition;
465            } elsif ($atype == ATTRIBUTE_DEFINITION_NODE) {
466              $ap = $acontainer[-1]->owner_element_type_definition;
467            } else {
468              $ap = $acontainer[-1]->parent_node;
469            }
470            if (defined $ap) {
471              push @acontainer, $ap;
472            } else {
473              last A;
474            }
475          }
476        } # A
477    
478        B: while (1) {
479          if ($acontainer[-1] eq $bcontainer[-1]) {
480            last F;
481          } else {
482            my $bp;
483            my $btype = $bcontainer[-1]->node_type;
484            if ($btype == ATTRIBUTE_NODE) {
485              $bp = $bcontainer[-1]->owner_element;
486            } elsif ($btype == ENTITY_NODE or $btype == NOTATION_NODE or
487                     $btype == ELEMENT_TYPE_DEFINITION_NODE) {
488              $bp = $bcontainer[-1]->owner_document_type_definition;
489            } elsif ($btype == ATTRIBUTE_DEFINITION_NODE) {
490              $bp = $bcontainer[-1]->owner_element_type_definition;
491            } else {
492              $bp = $bcontainer[-1]->parent_node;
493            }
494            if (defined $bp) {
495              push @bcontainer, $bp;
496            } else {
497              last B;
498            }
499          }
500        } # B
501          
502        ## Disconnected
503        if ($bcontainer[-1]->isa ('Message::IF::Node')) {
504          ## ISSUE: Document this in manakai's DOM Perl Binding?
505          return DOCUMENT_POSITION_DISCONNECTED
506            | DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC
507            | ((${$acontainer[-1]} cmp ${$bcontainer[-1]}) > 0
508                 ? DOCUMENT_POSITION_FOLLOWING
509                 : DOCUMENT_POSITION_PRECEDING);
510        } else {
511          ## TODO: Is there test cases for this?
512          return DOCUMENT_POSITION_DISCONNECTED
513            | DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC
514            | DOCUMENT_POSITION_FOLLOWING;
515        }
516      } # F
517    
518      ## Common container found
519      if (@acontainer >= 2) {
520        if (@bcontainer >= 2) {
521          my $acnt = $acontainer[-2]->node_type;
522          my $bcnt = $bcontainer[-2]->node_type;
523          if ($acnt == ATTRIBUTE_NODE or
524              $acnt == NOTATION_NODE or
525              $acnt == ELEMENT_TYPE_DEFINITION_NODE or
526              $acnt == ATTRIBUTE_DEFINITION_NODE) {
527            if ($acnt == $bcnt) {
528              return DOCUMENT_POSITION_IMPLEMENTATION_SPECIFIC
529                | (($acontainer[-2]->node_name cmp
530                    $bcontainer[-2]->node_name) > 0
531                   ? DOCUMENT_POSITION_FOLLOWING
532                   : DOCUMENT_POSITION_PRECEDING);
533            } elsif ($bcnt == ATTRIBUTE_NODE or
534                     $bcnt == NOTATION_NODE or
535                     $bcnt == ELEMENT_TYPE_DEFINITION_NODE or
536                     $bcnt == ATTRIBUTE_DEFINITION_NODE) {
537              return (($acnt < $bcnt)
538                      ? DOCUMENT_POSITION_FOLLOWING
539                      : DOCUMENT_POSITION_PRECEDING);
540            } else {
541              ## A: Non-child and B: child
542              return DOCUMENT_POSITION_FOLLOWING;
543            }
544          } elsif ($bcnt == ATTRIBUTE_NODE or
545                   $bcnt == NOTATION_NODE or
546                   $bcnt == ELEMENT_TYPE_DEFINITION_NODE or
547                   $bcnt == ATTRIBUTE_DEFINITION_NODE) {
548            ## A: Child and B: non-child
549            return DOCUMENT_POSITION_PRECEDING;
550          } else {
551            ## A and B are both children
552            for my $cn (@{$acontainer[-1]->child_nodes}) {
553              if ($cn eq $acontainer[-2]) {
554                return DOCUMENT_POSITION_FOLLOWING;
555              } elsif ($cn eq $bcontainer[-2]) {
556                return DOCUMENT_POSITION_PRECEDING;
557              }
558            }
559            die "compare_document_position: Something wrong (1)";
560          }
561        } else {
562          ## B contains A
563          return DOCUMENT_POSITION_CONTAINS
564            | DOCUMENT_POSITION_PRECEDING;
565        }
566      } else {
567        if (@bcontainer >= 2) {
568          ## A contains B
569          return DOCUMENT_POSITION_CONTAINED_BY
570            | DOCUMENT_POSITION_FOLLOWING;
571        } else {
572          ## A eq B
573          return 0;
574        }
575      }
576      die "compare_document_position: Something wrong (2)";
577    } # compare_document_position
578    
579    sub has_attributes ($) {
580      for (values %{${$_[0]}->{attributes} or {}}) {
581        return 1 if keys %$_;
582      }
583      return 0;
584    } # has_attributes
585    
586    sub has_child_nodes ($) {
587      return (@{${$_[0]}->{child_nodes} or []} > 0);
588    } # has_child_nodes
589    
590  ## TODO:  ## TODO:
591  sub is_same_node ($$) {  sub is_same_node ($$) {
592    return $_[0] eq $_[1];    return $_[0] eq $_[1];
# Line 263  sub is_equal_node ($$) { Line 598  sub is_equal_node ($$) {
598      $_[0]->node_value eq $_[1]->node_value;      $_[0]->node_value eq $_[1]->node_value;
599  } # is_equal_node  } # is_equal_node
600    
 sub manakai_parent_element ($) {  
   my $self = shift;  
   my $parent = $$self->{parent_node};  
   while (defined $parent) {  
     if ($parent->node_type == 1) { # ELEMENT_NODE  
       return $parent;  
     } else {  
       $parent = $$parent->{parent_node};  
     }  
   }  
   return undef;  
 } # manakai_parent_element  
   
601  ## NOTE: Only applied to Elements and Documents  ## NOTE: Only applied to Elements and Documents
602  sub append_child ($$) {  sub append_child ($$) {
603    my ($self, $new_child) = @_;    my ($self, $new_child) = @_;
# Line 347  sub insert_before ($$;$) { Line 669  sub insert_before ($$;$) {
669    return $new_child;    return $new_child;
670  } # insert_before  } # insert_before
671    
672    sub is_default_namespace ($$) {
673      ## TODO: Document that ElementTypeDefinition and AttributeDefinition
674      ## are same as DocumentType
675    
676      local $Error::Depth = $Error::Depth + 1;
677      my $namespace_uri = defined $_[1] ? $_[1] : '';
678      my $nt = $_[0]->node_type;
679      if ($nt == ELEMENT_NODE) {
680        my $el = $_[0];
681        EL: {
682          unless (defined $el->prefix) {
683            my $elns = $el->namespace_uri;
684            if ($namespace_uri ne '' and defined $elns) {
685              return $namespace_uri eq $elns;
686            } else {
687              return not ($namespace_uri eq '' or defined $elns);
688            }
689          }
690          my $xmlns = $el->get_attribute_ns
691            ('http://www.w3.org/2000/xmlns/', 'xmlns');
692          if (defined $xmlns) {
693            if ($namespace_uri ne '') {
694              return ($namespace_uri eq $xmlns);
695            } else {
696              return ($xmlns eq '');
697            }
698          }
699          $el = $el->manakai_parent_element;
700          redo EL if defined $el;
701          return 0;
702        } # EL;
703      } else {
704        my $el = $nt == DOCUMENT_NODE
705          ? $_[0]->document_element
706          : $nt == ATTRIBUTE_NODE
707            ? $_[0]->owner_element
708            : $_[0]->manakai_parent_element;
709        if (defined $el) {
710          return $el->is_default_namespace ($_[1]);
711        } else {
712          return 0;
713        }
714      }
715    } # is_default_namespace
716    
717    sub lookup_namespace_uri ($$) {
718      ## TODO: Need definition for ElementTypeDefinition and AttributeDefinition
719    
720      my ($self, $prefix) = @_;
721      $prefix = undef if defined $prefix and $prefix eq '';
722          ## NOTE: Implementation dependent.
723          ## TODO: Check what Gecko does.
724      local $Error::Depth = $Error::Depth + 1;
725      my $nt = $self->node_type;
726      if ($nt == ELEMENT_NODE) {
727        my $el = $self;
728        EL: {
729          my $elns = $el->namespace_uri;
730          if (defined $elns) {
731            my $elpfx = $el->prefix;
732            if ((not defined $prefix and not defined $elpfx) or
733                (defined $prefix and defined $elpfx and $prefix eq $elpfx)) {
734              return $elns;
735            }
736          }
737          AT: for my $attr (@{$el->attributes}) {
738            my $attrns = $attr->namespace_uri;
739            next AT if not defined $attrns or
740              $attrns ne 'http://www.w3.org/2000/xmlns/';
741            my $attrpfx = $attr->prefix;
742            if (not defined $prefix) {
743              my $attrln = $attr->local_name;
744              if ($attrln eq 'xmlns') {
745                my $attrval = $attr->value;
746                return length $attrval ? $attrval : undef;
747              }
748            } elsif (defined $prefix and
749                     defined $attrpfx and $attrpfx eq 'xmlns') {
750              my $attrln = $attr->local_name;
751              if ($attrln eq $prefix) {
752                my $attrval = $attr->value;
753                return length $attrval ? $attrval : undef;
754              }
755            }
756          } # AT
757          $el = $el->manakai_parent_element;
758          redo EL if defined $el;
759          return undef;
760        } # EL;
761      } else {
762        my $el = $nt == DOCUMENT_NODE
763          ? $self->document_element
764          : $nt == ATTRIBUTE_NODE
765            ? $self->owner_element
766            : $self->manakai_parent_element;
767        if (defined $el) {
768          return $el->lookup_namespace_uri ($prefix);
769        } else {
770          return undef;
771        }
772      }
773    } # lookup_namespace_uri
774    
775    sub lookup_prefix ($$) {
776      ## ISSUE: Document ElementTypeDefinition and AttributeDefinition
777      ## behavior (i.e. same as DocumentType)
778    
779      my $namespace_uri = defined $_[1] ? $_[1] : '';
780      if ($namespace_uri eq '') {
781        return undef;
782      }
783    
784      local $Error::Depth = $Error::Depth + 1;
785      my $nt = $_[0]->node_type;
786      if ($nt == ELEMENT_NODE) {
787        my $el = $_[0];
788        EL: {
789          my $elns = $el->namespace_uri;
790          if (defined $elns and $elns eq $namespace_uri) {
791            my $elpfx = $el->prefix;
792            if (defined $elpfx) {
793              my $oeluri = $_[0]->lookup_namespace_uri ($elpfx);
794              if (defined $oeluri and $oeluri eq $namespace_uri) {
795                return $elpfx;
796              }
797            }
798          }
799          AT: for my $attr (@{$el->attributes}) {
800            my $attrpfx = $attr->prefix;
801            next AT if not defined $attrpfx or $attrpfx ne 'xmlns';
802            my $attrns = $attr->namespace_uri;
803            next AT if not defined $attrns or
804              $attrns ne 'http://www.w3.org/2000/xmlns/';
805            next AT unless $attr->value eq $namespace_uri;
806            my $attrln = $attr->local_name;
807            my $oeluri = $el->lookup_namespace_uri ($attrln);
808            next AT unless defined $oeluri;
809            if ($oeluri eq $namespace_uri) {
810              return $attrln;
811            }
812          }
813          $el = $el->manakai_parent_element;
814          redo EL if defined $el;
815          return undef;
816        } # EL
817      } else {
818        my $el = $nt == DOCUMENT_NODE
819          ? $_[0]->document_element
820          : $nt == ATTRIBUTE_NODE
821            ? $_[0]->owner_element
822            : $_[0]->manakai_parent_element;
823        if (defined $el) {
824          return $el->lookup_prefix ($_[1]);
825        } else {
826          return undef;
827        }
828      }
829    } # lookup_prefix
830    
831    sub normalize ($) {
832      my $self = shift;
833      my $ptext;
834      local $Error::Depth = $Error::Depth + 1;
835      
836      ## Children
837      my @remove;
838      for my $cn (@{$self->child_nodes}) {
839        if ($cn->node_type == TEXT_NODE) {
840          my $nv = $cn->node_value;
841          if (length $nv) {
842            if (defined $ptext) {
843              $ptext->manakai_append_text ($nv);
844              $ptext->is_element_content_whitespace (1)
845                if $cn->is_element_content_whitespace and
846                  $ptext->is_element_content_whitespace;
847              push @remove, $cn;
848            } else {
849              $ptext = $cn;
850            }
851          } else {
852            push @remove, $cn;
853          }
854        } else {
855          $cn->normalize;
856          undef $ptext;
857        }
858      }
859      $self->remove_child ($_) for @remove;
860    
861      my $nt = $self->node_type;
862      if ($nt == ELEMENT_NODE) {
863        ## Attributes
864        $_->normalize for @{$self->attributes};
865      } elsif ($nt == DOCUMENT_TYPE_NODE) {
866        ## ISSUE: Document these explicitly in DOM XML Document Type Definitions spec
867        ## Element type definitions
868        $_->normalize for @{$self->element_types};
869        ## General entities
870        $_->normalize for @{$self->general_entities};
871      } elsif ($nt == ELEMENT_TYPE_DEFINITION_NODE) {
872        ## Attribute definitions
873        $_->normalize for @{$self->attribute_definitions};
874      }
875      ## TODO: normalize-characters
876    
877      ## TODO: In this implementation, if a modification raises a
878      ## |NO_MODIFICATION_ALLOWED_ERR|, then any modification before it
879      ## is not reverted.
880    } # normalize
881    
882  ## NOTE: Only applied to Elements and Documents  ## NOTE: Only applied to Elements and Documents
883  sub remove_child ($$) {  sub remove_child ($$) {
884    my ($self, $old_child) = @_;    my ($self, $old_child) = @_;
# Line 361  sub remove_child ($$) { Line 893  sub remove_child ($$) {
893    return $old_child;    return $old_child;
894  } # remove_child  } # remove_child
895    
 ## NOTE: Only applied to Elements and Documents  
 sub has_child_nodes ($) {  
   return @{${+shift}->{child_nodes}} > 0;  
 } # has_child_nodes  
   
896  sub manakai_set_read_only ($;$$) {  sub manakai_set_read_only ($;$$) {
897    my $value = 1 if $_[1];    my $value = 1 if $_[1];
898    if ($_[2]) {    if ($_[2]) {
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24