Froody::Response::PerlDS - create a response from a Perl data structure

  my $rsp = Froody::Response::PerlDS->new();
  $rsp->structure($froody_method);
  $rsp->content({
    name => "bob",
    attributes => { foo => "bar" },
    value => "harry",
  });
  print $rsp->render();

  # prints out
  <?xml version="1.0" encoding="utf-8" ?>
  <rsp stat="ok">
    <bob foo="bar">harry</bob>
  </rsp>

  $response->content({
    name => "bob",
    attributes => { foo => "bar" },
    value => "harry",
  });

  <?xml version="1.0" encoding="utf-8" ?>
  <rsp stat="ok">
    <bob foo="bar">harry</bob>
  </rsp>

  $response->content({
    name => "bob",
    attributes => { foo => "bar" },
    children => [
      {
        name => "dave",
        attributes => { fuzz => "ball" },
        value => "ninepence",
      },
    ],
  });

  <?xml version="1.0" encoding="utf-8" ?>
  <rsp stat="ok">
    <bob foo="bar">
      <dave fuzz="ball">ninepence</dave>
    </bob>
  </rsp>

  use Froody::Response::String;
  use Froody::Response::PerlDS;
  my $perlds = Froody::Response::String
      ->new()
      ->structure($froody_method)
      ->set_string('<rsp stat="ok"><foo>bar</foo></rsp>');
      ->as_perlds;

  print ref($perlds);  # prints "Froody::Response::PerlDS"

package Froody::Response::PerlDS;
use base qw(Froody::Response::Content);
use warnings;
use strict;

use XML::LibXML;
use Encode qw(encode);
use Params::Validate qw(SCALAR ARRAYREF HASHREF);

__PACKAGE__->mk_accessors(qw(
  root_name
));

sub find_by_path {
  my ($self, $target) = @_;
  _find_by_path ({children => $self->{content}}, $target);
}

sub _find_by_path {
    my ($node, $name) = @_;
    return $node unless defined $name;
    my ($lookup, $next) = split '/', $name, 2;
    my ($child) = grep {$_->{name} eq $lookup} @{$node->{children}};
    _find_by_path ($child, $next)
}

sub default_root_name { "rsp" }

sub _to_xml
{
  my $self = shift;
  my $content = shift;
   
  my $doc = XML::LibXML::Document->new("1.0","utf-8");
  my $root = $doc->createElement($self->root_name || $self->default_root_name);
  $root->setAttribute("stat", $self->status);

  # let's recurse again....like we did last summer.
  foreach ($self->_xml_nodes(
    doc  => $doc,
    list => [$content],
  )) { $root->addChild($_) }

  # finally add the root node.
  $doc->addChild($root);

  return $doc;
}

# _xml_nodes( doc => xml docuement, list => listref )
# given a listref of content nodes, return XML::LibXML node objects
# for them. Called recursively for deep structures.
sub _xml_nodes {
  my $self = shift;

  my %args = $self->validate_object(@_, {
    doc  => { isa => "XML::LibXML::Document" },
    list => { type => ARRAYREF },
  });

  my $enc = $args{doc}->getEncoding();

  my @xml_nodes;
  for my $value (@{ $args{list} }) {

    # create the node
    my $name = encode($enc, $value->{name}, 1);
    my $node = $args{doc}->createElement( $name );

    # populate attributes, if any
    
    # we're not doing encoding here because it doesn't work.
    # Yes, I know it should, but it's got one of those hard to track
    # down bugs.
    
    for my $att (sort keys %{ $value->{attributes} || {} }) {
      if (defined $value->{attributes}{$att}) {
        my $key = $att;
        #  Encode::encode($enc, $att, 1);
        my $val = $value->{attributes}{$att};
        #  Encode::encode($enc, $value->{attributes}{$att}, 1);
        $node->setAttribute( $key, $val )
      }
    }

    # set value, if any
    if (defined($value->{value})) {
      # there is a bigger rant here than I really want to think about,
      # so I'm not going to bother. Come to my talk.
      # essentially: you've got to add bytes here in whatever encoding
      # the document is in.  Dontcha just love that?
      use utf8;
      utf8::upgrade( $value->{value} );
      my $text = $args{doc}->createTextNode( $value->{value} );
      $node->addChild( $text );
    }

    # add children, if any
    if (defined($value->{children})) {
      for ($self->_xml_nodes(
        doc => $args{doc},
        list => $value->{children},
      )) {
        $node->addChild($_);
      }
    }

    # add to list of returned nodes
    push @xml_nodes, $node;
  }
  return @xml_nodes;
}

# as_perlds is documented
sub as_perlds { return $_[0] }
sub Froody::Response::as_perlds
{
  my $self = shift;
  $self = $self->as_xml;  # get as far as XML

  my $perlds = Froody::Response::PerlDS->new()
                                       ->structure($self->structure);
                                       
  # find the top node
  my ($top) = $self->xml->findnodes("/rsp")
    or Froody::Error->throw("froody.convert", "no rsp!");

  my $stat = $top->getAttribute("stat");
  unless (defined($stat) && ($stat eq "ok" || $stat eq "fail"))
   { Froody::Error->throw("froody.convert", "invalid stat!") }
  
  # right, recurse down our XML and turn it into this data structure
  $perlds->content(_recurse_to_ds($top->findnodes("./*")));
  $perlds->status( $stat );
  
  return $perlds;
}

sub _recurse_to_ds
{
  my $node = shift;
  return {} unless $node;
  
  # work out the text content of this node
  my $text = $node->findvalue("./text()");
  $text =~ s/^\s+//;  # lose leading  white space
  $text =~ s/\s+$//;  # lose trailing white space
  
  # what were the attributes?
  my %attr = map { $_->nodeName => $_->getValue } $node->findnodes("./@*");
  
  # what were the children?
  my @children = map { _recurse_to_ds($_) } $node->findnodes("./*");
  
  return {
    name => $node->nodeName,
    
    # text, if there was any text
    ((length $text) ? (value => $text) : ()),
    
    # attributes, if there were any attributes
    ((%attr) ? (attributes => \%attr) : ()),
    
    # children, if there were any children
    ((@children) ? (children => \@children) : ()),
  }
}

1;