view release on metacpan or  search on metacpan

CAB/Format/XmlPerl.pm  view on Meta::CPAN

			   listElt => 'l',
			   atomElt => 'a',

			   ##-- common

			   ##-- user args
			   @_
			  );
}

##==============================================================================
## Methods: Persistence
##==============================================================================

## @keys = $class_or_obj->noSaveKeys()
##  + returns list of keys not to be saved
##  + inherited from XmlCommon


##=============================================================================
## Methods: Input
##==============================================================================

##--------------------------------------------------------------
## Methods: Input: Local

## $obj = $fmt->parseNode($nod)
##  + Returns the perl object represented by the XML::LibXML::Node $nod
our %atomNames = map {($_=>undef)} (qw(VALUE VAL V value val v ATOM atom a), '#text');
our %hashNames = map {($_=>undef)} qw(HASH H hash h MAP M map m);
our %listNames = map {($_=>undef)} qw(ARRAY array   LIST L list l);
our %allNames  = (%atomNames,%hashNames,%listNames);
sub parseNode {
  my ($fmt,$nod) = @_;
  return undef if (!defined($nod));
  my $nodname = $nod->nodeName;
  my ($val,$ref);
  if (exists($atomNames{$nodname})) {
    ##-- non-reference: <VALUE>$val</VALUE> or <VALUE undef="1"/> or plain text
    $val = $nod->can('getAttribute') && $nod->getAttribute('undef') ? undef : $nod->textContent;
  }
  elsif (exists($hashNames{$nodname})){
    ##-- HASH ref: <HASH ref="$ref"> ... <ENTRY key="$eltKey">defaultXmlNode($eltVal)</ENTRY> ... </HASH>
    $ref = $nod->getAttribute('ref');
    $val = {};
    $val = bless($val,$ref) if ($ref && $ref ne 'HASH');
    foreach (grep {ref($_) eq 'XML::LibXML::Element' && $_->hasAttribute('key')} $nod->childNodes) {
      $val->{ $_->getAttribute('key') } = $fmt->parseNode($_);
    }
  }
  elsif (exists($listNames{$nodname})) {
    ##-- ARRAY ref: <ARRAY ref="$ref"> ... xmlNode($eltVal) ... </ARRAY>
    $ref = $nod->getAttribute('ref');
    $val = [];
    $val = bless($val,$ref) if ($ref && $ref ne 'ARRAY');
    foreach ($nod->childNodes) {
      push(@$val, $fmt->parseNode($_));
    }
  }
  elsif ($nodname =~ /^\#/) {
    ;##-- special node, e.g. #cdata-section, #comment, etc.: skip
  }
  else {
    $fmt->logwarn("cannot handle node with name=$nodname - skipping");
  }
  return $val;
}

##--------------------------------------------------------------
## Methods: Input: Generic API

## $doc = $fmt->parseDocument()
##  + parses buffered XML::LibXML::Document
sub parseDocument {
  my $fmt = shift;
  if (!defined($fmt->{xdoc})) {
    $fmt->logconfess("parseDocument(): no source document {xdoc} defined!");
    return undef;
  }
  my $parsed = $fmt->parseNode($fmt->{xdoc}->documentElement);

  ##-- force document
  return $fmt->forceDocument($parsed);
}


##=============================================================================
## Methods: Output
##==============================================================================

##--------------------------------------------------------------
## Methods: Output: MIME & HTTP stuff

## $short = $fmt->formatName()
##  + returns "official" short name for this format
##  + default just returns package suffix
sub shortName {
  return 'xmlperl';
}

##--------------------------------------------------------------
## Methods: Output: Local: Nodes

## $xmlnod = $fmt->tokenNode($tok)
##  + returns formatted token $tok as an XML node
sub tokenNode { return $_[0]->defaultXmlNode($_[1]); }

## $xmlnod = $fmt->sentenceNode($sent)
sub sentenceNode { return $_[0]->defaultXmlNode($_[1]); }

## $xmlnod = $fmt->documentNode($doc)
sub documentNode { return $_[0]->defaultXmlNode($_[1]); }


## $body_array_node = $fmt->xmlBodyNode()
##  + gets or creates buffered body array node
sub xmlBodyNode {
  my $fmt = shift;
  my $root = $fmt->xmlRootNode('doc');
  my ($body) = $root->findnodes('./*[@key="body"][last()]');
  if (!defined($body)) {