Changeset 17333

Timestamp:

08/10/08 23:20:23 (5 years ago)

Author:

daisuke

Message:

automatically generate root node

Location:

lang/perl/MooseX-DOM/trunk/lib/MooseX

Files:

• DOM.pm (modified) (2 diffs)
• DOM/LibXML.pm (modified) (14 diffs)

lang/perl/MooseX-DOM/trunk/lib/MooseX/DOM.pm

@@ -55 +55 @@
 
   no Moose;
+  no MoooseX::DOM;
 
   my $obj = MyObject->new(node => <<EOXML);
@@ -73 +74 @@
 =head1 DECLARATION
 
-=head2 has_dom_root $tag
+=head2 has_dom_root $name[, %opts]
 
-Specifies that the given XML have the specified tag
+Specifies that the given XML have the specified tag. This specification is
+also used when creating new root node for creating the underlying XML
+
+  has_dom_root $name => (
+    # attributes => { ... }
+  );
 
 =head2 has_dom_attr $name[, %opts]

lang/perl/MooseX-DOM/trunk/lib/MooseX/DOM/LibXML.pm

@@ -10 +10 @@
     is => 'rw',
     isa => 'MooseX::DOM::LibXML::ContextNode',
-    required => 1,
 );
 
@@ -41 +40 @@
             confess "Don't know how to handle $node";
         }
-    }
-
-    return  { %args, node => $node };
-}
-
-{
+
+        $args{node} = $node;
+    }
+
+    return  { %args };
+}
+
+BOOTSTRAP: {
     my $subname = sub { join('::', $_[1] || __PACKAGE__, $_[0]) };
     my $subassign = sub {
@@ -56 +57 @@
     my $textfilter = sub {
         my $self = shift;
-        return map { $_->textContent } @_;
+        return map { blessed $_ && $_->can('textContent') ? $_->textContent : $_ } @_;
     };
 
@@ -84 +85 @@
     # Used only in has_dom_children, to create a list of element nodes from
     # list of text
-    my $text2elements =Class::MOP::subname($subname->('text2elements') => sub {
+    my $text2elements = Class::MOP::subname($subname->('text2elements') => sub {
         my($self, %args) = @_;
 
@@ -113 +114 @@
     my %exports = (
         has_dom_root => sub {
-            return Class::MOP::subname($subname->('has_dom_attr') => sub ($;%) {
+            return Class::MOP::subname($subname->('has_dom_root') => sub ($;%) {
                 my $caller = caller();
-                my $tag = shift;
+                my ($tag, %args) = @_;
+                # tag => $tag
+                # attributes => { attr1 => $val1, attr2 => $val2 }
+
+                $tag = $args{tag} if $args{tag};
+                my $attrs = $args{attributes};
+
+                my $meta = $caller->meta;
+                $meta->{'$!dom_root'} = { tag => $tag, attributes => $attrs };
 
                 my $assert_root = sub {
@@ -125 +134 @@
                 };
 
-                my $meta = $caller->meta;
                 $meta->add_around_method_modifier(new => sub {
                     my $next = shift;
@@ -148 +156 @@
                     $name = $args{accessor};
                 }
+
+                $caller->meta->{'%!dom_attributes'}->{$name} = 1;
                 my $method = $subname->($name, $caller);
                 $subassign->($method => sub {
@@ -171 +181 @@
                     $name = $args{accessor};
                 }
+                $caller->meta->{'%!dom_attributes'}->{$name} = 1;
                 my $method = $subname->($name, $caller);
 
@@ -182 +193 @@
                         $node->getChildrenByTagName($tagname)
                     ;
-
                     if (@_) {
                         $create->($self, children => \@children, values => \@_, namespace => $namespace, tag => $tagname);
@@ -204 +214 @@
                 }
 
+                my $meta = $caller->meta;
+                $meta->{'%!dom_attributes'}->{$name} = 1;
                 my $method = $subname->($name, $caller);
                 $subassign->($method => sub {
@@ -209 +221 @@
 
                     my $node = $self->node;
-                    my $nsuri = $self->namespaces->{ $namespace };
-                    my ($child) = ($nsuri) ?
-                        $node->getChildrenByTagNameNS($nsuri, $tagname):
-                        $node->getChildrenByTagName($tagname)
-                    ;
+                    my $child;
+                    if ($node) {
+                        my $nsuri = $self->namespaces->{ $namespace };
+                        ($child) = ($nsuri) ?
+                            $node->getChildrenByTagNameNS($nsuri, $tagname):
+                            $node->getChildrenByTagName($tagname)
+                        ;
+                    }
 
                     if (@_) {
+                        $self->__create_root_node();
                         $create->( $self, child => $child, value => $_[0], namespace => $namespace, tag => $tagname);
                     }
@@ -231 +247 @@
     });
     sub export_dsl {
-        goto &$export;
+        goto &$export if $export;
     }
 
@@ -254 +270 @@
         }
     }
-
+}
+
+sub BUILD {
+    my ($self, $args) = @_;
+
+    if (my $attrs = $self->meta->{'%!dom_attributes'}) {
+        foreach my $attr (keys %$attrs) {
+            next unless defined $args->{$attr};
+            $self->$attr( $args->{ $attr } );
+        }
+    }
+    return $self;
 }
 
@@ -262 +289 @@
 }
 
+sub __create_root_node {
+    my $self = shift;
+    return if $self->node;
+
+    my $root = $self->meta->{'$!dom_root'};
+    confess "No root node defined" unless $root;
+
+    my $tag = $root->{tag};
+    my $attrs = $root->{attributes};
+    my $doc = XML::LibXML::Document->new( '1.0' => 'UTF-8' );
+    my $node = $doc->createElement($tag);
+    while (my($name, $value) = each %$attrs) {
+        $node->setAttribute($name, $value);
+    }
+    $self->node( MooseX::DOM::LibXML::ContextNode->new(node => $node) );
+}
+
 
 1;