XML::Merge - flexibly merge XML documents

  use XML::Merge;

  # create new    XML::Merge object from         MainFile.xml
  my $merge_obj = XML::Merge->new('filename' => 'MainFile.xml');

  # Merge File2Add.xml              into         MainFile.xml
     $merge_obj->merge(           'filename' => 'File2Add.xml');

  # Tidy up the indenting that resulted from the merge
     $merge_obj->tidy();

  # Write out changes back            to         MainFile.xml
     $merge_obj->write();

  'filename' => 'SomeFile.xml'
  'xml'      => $variable_which_holds_a_bunch_of_XML_data
  'ioref'    => $file_InputOutput_reference
  'context'  => $existing_node_at_specified_context_to_become_new_obj

  'conflict_resolution_method' => 'main', # main  file wins
  'conflict_resolution_method' => 'merg', # merge file wins
                   # 'last-in_wins' is an alias for 'merg'
  'conflict_resolution_method' => 'warn', # croak conflicts
  'conflict_resolution_method' => 'test', # just test, 0 if conflict
  # this option is not implemented yet, please say if you need it
  'comment_join_method' => 'none',

  0. If both documents share the same root element name, they are
       merged directly.
  1. If they don't share root elements but the temporary merge file's
       root element is found anywhere within the main file, the merge
       occurs at the match.
  2. If no root element match is found, the merge document becomes the
       new last child of the main file's root element.
  3. Whenever a deeper level is found with an element of the same name
       in both documents && either it does not contain any
       distinguishing attributes or it has attributes which are
       recognized as 'identifier' (id) attributes (by default, for any
       element, these are attributes named: 'id', 'name', && 'handle'),
       a corresponding element is searched for to match && merge with.
  4. Any remaining (non-id) nodes are merged in document order.
  5. When a conflict arises as non-id attributes or other nodes merge,
       the specified conflict_resolution_method merge-option is
       applied (which by default has the main file data persist at the
       expense of the merging file data).

  my $merge_obj = XML::Merge->new(
    'filename'                   => 'MainFile.xml',
    'conflict_resolution_method' => 'last-in_wins');

  $merge_obj->merge(
    'filename'                   => 'File2Add.xml',
    'conflict_resolution_method' => 'warn');

  foreach(@files) {
    if($merge_obj->merge('cres' => 'test', $_)) {
      $merge_obj->merge($_); # only do it if there are no conflicts
    } else {
      croak("Yipes! Conflict with file:$_!\n");
    }
  }

  $merge_obj->merge($another_merge_obj);

  'merge_destination_path' => $main_obj_xpath_location,
  'merge_source_path'      => $merging_obj_xpath_location,

    `perl -MCPAN -e "install XML::Merge"`

    `perl Makefile.PL; make; make test; make install`

#!/usr/bin/perl -w
# 4AIDCLW - XML::Merge.pm created by Pip Stuart <Pip@CPAN.Org>
#   to intelligently merge XML documents as parsed XML::XPath objects.
#
# Plan:
#   if    same-named root nodes,
#     merge straight
#   elsif root of 2nd exists in 1st,
#     merge at first match
#   else
#     append 2nd root as new last child of 1st root
#
#     XML::Merge new(filename => 'fnam'[, <other options> ])
#       inherits XML::Tidy which inherits XML::XPath.
#       Merge creates an object with a merge() member which creates another
#       XPath object && combines the result back into the main object.
#     optn:
#       merge below specified context
#       id attributes: 'id', 'name', && 'handle' (default)
#       join comments of same context (leave separate default)
#       source-file-stamp merged comments
#              time-stamp merged comments
#                pt-stamp merged comments
#     conflict rules:
#       main    wins (default)
#       last-in wins (aka. clobber)
#       newer modification date wins
#       warn (croak conflict)
#       test (don't merge anything, just return true if no conflicts)
#     members:
#       merge() (can accept tmp override optz)
#       unmerge()
#
#   option to rename some XPath to something else so like simple example
#     is taking merge-file's root node element && pretending it is
#     named the same as the main-file's root node element so that the
#     two can merge in place even though their root node elements had
#     different names.  This would clobber the name of the merge-file
#     element with the main-file one but it would be a useful option.
#

# Please see CHANGES section to know why the following is commented.
## Need to fix node_test() test_nt_pi return in XML::XPath::Step.pm first...
#package XML::XPath::Step;
#use XML::XPath::Parser;
#use XML::XPath::Node;
#
#sub node_test {
#  my $self = shift; my $node = shift;
#  my $test = $self->{test}; # if node passes test, return true
#  return 1 if $test == test_nt_node;
#  if($test == test_any) {
#    return 1 if $node->isElementNode && defined $node->getName;
#  }
#  local $^W;
#  if($test == test_ncwild) {
#    return unless $node->isElementNode;
#    my $match_ns = $self->{pp}->get_namespace($self->{literal}, $node);
#    if(my $node_nsnode = $node->getNamespace()) {
#      return 1 if $match_ns eq $node_nsnode->getValue;
#    }
#  } elsif($test == test_qname) {
#    return unless $node->isElementNode;
#    if($self->{literal} =~ /:/) {
#      my($prefix, $name) = split(':', $self->{literal}, 2);
#      my $match_ns = $self->{pp}->get_namespace($prefix, $node);
#      if(my $node_nsnode = $node->getNamespace()) {
#        return 1 if($match_ns eq $node_nsnode->getValue && $name eq $node->getLocalName);
#      }
#    } else {
#      return 1 if $node->getName eq $self->{literal};
#    }
#  } elsif ($test == test_nt_text) {
#    return 1 if $node->isTextNode;
#  } elsif($test == test_nt_comment) {
#    return 1 if $node->isCommentNode;
#  } elsif($test == test_nt_pi) {
#    return unless $node->isPINode;
#    # EROR was here!  $self->{literal} is undefined so can't ->value!
#    #if(my $val = $self->{literal}->value) {
#    #  return 1 if $node->getTarget eq $val;
#    #} else {
#      return 1;
#    #}
#  }
#  return; # fallthrough returns false
#}
## ... also update Text nodes' toString() to escape both < && >! ...
#package XML::XPath::Node::TextImpl;
#sub toString {
#  my $self = shift; XML::XPath::Node::XMLescape($self->[node_text], '<&>');
#}

# Now ready to handle XML::Merge package...
package XML::Merge;
use warnings;
use strict;
require      XML::Tidy;
use base qw( XML::Tidy );
use          XML::Tidy;
use Carp;
our $VERSION     = '1.2.565EgGd'; # major . minor . PipTimeStamp
our $PTVR        = $VERSION; $PTVR =~ s/^\d+\.\d+\.//; # strip major and minor
# Please see `perldoc Time::PT` for an explanation of $PTVR.

my $DBUG = 0;

sub new {
  my $clas = shift(); my @parm; my $cres = 'main';
  for(my $indx = 0; $indx < @_; $indx++) {
    if($_[$indx] =~ /^[-_]?(cres$|conflict_resolution)/ && ($indx + 1) < @_) {
      $cres = $_[++$indx];
    } else {
      push(@parm, $_[$indx]);
    }
  }
  my $tdob = XML::Tidy->new(@parm);
  my $self = bless($tdob, $clas);
  #   self just a new Tidy (XPath) obj blessed into Merge class...
  #     ... with a few new options
  $self->{'_object_to_merge'} = undef;
  $self->{'_conflict_resolution_method'} = $cres;
  #         Conflict RESolution method valid values:
  # 'main' = Main (primary) file wins
  # 'merg' = Merge file resolves (Last-In wins)
  # 'warn' = Croak warning about conflict && halt merge
  # 'test' = Test whether any conflict would occur if merge were performed
  $self->{'_comment_join_method'} = 'none';
  #         CoMmenT Join method        valid values:
  # 'none', 'separate'
  # 'join', 'combine'
  # 'jpts', 'join_with_piptime_stamp'
  # 'jlts', 'join_with_localtime_stamp'
  $self->{'_id_xpath_list'} = [ # unique ID elements or attributes
    '@id',
    '@name',
    '@handle',
  ];
  return($self);
}

sub merge { # under water
  my $self = shift(); my @parm;
  my $cres = $self->get_conflict_resolution_method();
  my $cmtj = $self->get_comment_join_method();
  my $mdxp = undef;
  my $msxp = undef;
  my $mgob = undef;
  # setup local options
  for(my $indx = 0; $indx < @_; $indx++) {
    if     ($_[$indx] =~ /^[-_]?(cres$|conflict_resolution)/ && ($indx + 1) < @_) {
      $cres = $_[++$indx];
    } elsif($_[$indx] =~ /^[-_]?(cmtj$|comment_join)/        && ($indx + 1) < @_) {
      $cmtj = $_[++$indx];
    } elsif($_[$indx] =~ /^[-_]?(mdxp$|merge_destination)/   && ($indx + 1) < @_) {
      $mdxp = $_[++$indx];
    } elsif($_[$indx] =~ /^[-_]?(msxp$|merge_source)/        && ($indx + 1) < @_) {
      $msxp = $_[++$indx];
    } elsif(ref($_[$indx]) =~ /XML::(XPath|Tidy|Merge)/) {
      $self->set_object_to_merge($_[$indx]);
    } else {
      push(@parm, $_[$indx]);
    }
  }
  $self->set_object_to_merge( XML::Merge->new(@parm) ) if(@parm);
  $cres = 'merg' if($cres =~ /last/i);
  $mgob = $self->get_object_to_merge();
  if($mgob) {
    my $mnrn; my $mgrn;
    # traverse main Merge obj && merge w/ object_to_merge according to options
    # 0a. ck if root node elems have same LocalName
    #   but short-circuit root element loading if merge_source or merge_dest
    if(defined($mdxp) && length($mdxp)) {
      ($mnrn)= $self->findnodes($mdxp);
    } else {
      ($mnrn)= $self->findnodes('/*');
    }
    if(defined($msxp) && length($msxp)) {
      ($mgrn)= $mgob->findnodes($msxp);
    } else {
      ($mgrn)= $mgob->findnodes('/*');
    }
    if($mnrn->getLocalName() eq $mgrn->getLocalName()) {
      print "Root Node Element names match so merging in place!\n" if($DBUG);
      # 1a. ck if each merge root elem has attributes which main doesn't
      foreach($mgrn->findnodes('@*')) {
        print "  Found attr:" . $_->getLocalName() . "\n" if($DBUG);
        my($mnat)= $mnrn->findnodes('@' . $_->getLocalName());
        # if both root elems have same attribute name with different values...
        if(defined($mnat)) {
          print "  Found matching attr:" . $_->getLocalName() . "\n" if($DBUG);
          # must use Conflict RESolution method to know who's value wins
          if($mnat->getNodeValue() ne $_->getNodeValue()) {
            if     ($cres eq 'merg') {
              print "    CRES:merg so setting main attr:" . $_->getLocalName() .  " to merg valu:" . $_->getNodeValue() . "\n" if($DBUG);
              $mnat->setNodeValue($_->getNodeValue());
            } elsif($cres eq 'warn') {
              croak("!*WARN*! Found conflicting attribute:" .
                                     $_   ->getLocalName() .
                "\n  main value:" .  $mnat->getNodeValue() .
                "\n  merg value:" .  $_   ->getNodeValue() .
                "\n    Croaking... please resolve manually.\n");
            } elsif($cres eq 'test') {
              return(0);
            }
          }
        } else {
          print "  Found new      attr:" . $_->getLocalName() . "\n" if($DBUG);
          $mnrn->appendAttribute($_) unless($cres eq 'test');
        }
      }
      # 1b. loop through all merge child elems
      if($mgrn->findnodes('*')) {
        foreach($mgrn->findnodes('*')) {
          print "  Found elem:" . $_->getLocalName() . "\n" if($DBUG);
          my $mtch = 0; # flag to know if already matched
          # test ID paths
          foreach my $idat (@{$self->get_id_xpath_list()}) {
            print "    idat matching against:$idat\n" if($DBUG);
            # if a child merge elem has a matching id, search main for same
            my($mgmt)= $_->findnodes($idat); # MerG MaTch
            if(defined($mgmt)) {
              print "    Matched idat:$idat\n" if($DBUG);
              my $mnmt;
              if     ($idat =~ /^\@/) {
                ($mnmt)= $mnrn->findnodes($_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"]');
              } elsif($idat =~ /\[\@\w+\]/) {
                my $itmp = $idat; my $nval = $mgmt->getNodeValue();
                $itmp =~ s/(\[\@\w+)\]/$1="$nval"\]/;
                ($mnmt)= $mnrn->findnodes($itmp);
              } else {
                ($mnmt)= $mnrn->findnodes($idat);
              }
              if(defined($mnmt)) { # id matched both main && merg...
                print "    Matched elem:" . $_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"] with elem:' . $mnmt->getLocalName() . "\n" if($DBUG);
                $mtch = 1; # so recursively merge deeper...
                my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
                return(0) if($cres eq 'test' && !$test);
              }
            }
          }
          if(!$mtch && $mnrn->findnodes($_->getLocalName())) {
            my($mnmt)= $mnrn->findnodes($_->getLocalName());
            if(defined($mnmt)) { # plain elem matched both main && merg...
              my $fail = 0;
              foreach my $idat (@{$self->get_id_xpath_list()}) {
                my($mnat)= $mnmt->findnodes($idat); # MaiN ATtribute
                my($mgat)= $_   ->findnodes($idat); # MerG ATtribute
                $fail = 1 if(defined($mnat) || defined($mgat));
              }
              unless($fail) { # fail tests if any unique id paths were found
                $mtch = 1; # so recursively merge deeper...
                my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
                return(0) if($cres eq 'test' && !$test);
              }
            }
          }
          # if none above matched, append diff child to main root node
          $mnrn->appendChild($_) unless($mtch || $cres eq 'test');
        }
      } elsif($mgrn->getChildNodes()) { # no kid elems but kid text data node
        my($mntx)= $mnrn->getChildNodes();
        my($mgtx)= $mgrn->getChildNodes();
        if(defined($mgtx) && $mgtx->getNodeType() == TEXT_NODE) {
          print "  Found text:" . $mgrn->getLocalName() . " valu:" . $mgtx->getNodeValue() . "\n" if($DBUG);
          if     (!defined($mntx)) {
            $mnrn->appendChild($mgtx) unless($cres eq 'test');
          } elsif($cres eq 'merg') {
            $mntx->setNodeValue($mgtx->getNodeValue());
          } elsif($cres eq 'warn') {
            croak("!*WARN*! Found conflicting     Root text node:" .
                                   $mnrn->getLocalName() .
              "\n  main value:" .  $mntx->getNodeValue() .
              "\n  merg value:" .  $mgtx->getNodeValue() .
              "\n    Croaking... please resolve manually.\n");
          } elsif($cres eq 'test') {
            #return(0); # new text node value is not a merge prob?
          }
        }
      }
    # 0b. ck if merge root node elem exists somewhere in main
    } elsif($self->findnodes('//' . $mgrn->getLocalName())) {
      print "Root Node Element names differ && mgrn is in mnrn so merging at match!\n" if($DBUG);
      my($mnmt)= $self->findnodes('//' . $mgrn->getLocalName());
      # recursively merge main child with merg root
      my $test = $self->_recmerge($mnmt, $mgrn, $cres, $cmtj);
      return(0) if($cres eq 'test' && !$test);
    # 0c. just append whole merge doc as last child of main root
    } elsif($cres ne 'test') {
      print "Root Node Element names differ so appending mgrn as last child of mnrn!\n" if($DBUG);
      $mnrn->appendChild($mgrn);
      $mnrn->appendChild($self->Text("\n"));
    }
    print "  mnrn:" . $mnrn->getLocalName() . "\n" if($DBUG);
    print "  mgrn:" . $mgrn->getLocalName() . "\n" if($DBUG);
  }
  return(1); # true test _cres == no conflict, 0 == conflict
}

sub _recmerge { # recursively merge XML elements
  my $self = shift(); # merge() already setup all needed _optn values
  my $mnnd = shift(); # MaiN NoDe
  my $mgnd = shift(); # MerG NoDe
  my $cres = shift() || $self->get_conflict_resolution_method();
  my $cmtj = shift() || $self->get_comment_join_method();
  if($mnnd->getLocalName() eq $mgnd->getLocalName()) {
    print "Non-Root Node Element names match so merging in place!\n" if($DBUG);
    foreach($mgnd->findnodes('@*')) {
      print "NR  Found attr:" . $_->getLocalName() . "\n" if($DBUG);
      my($mnat)= $mnnd->findnodes('@' . $_->getLocalName());
      if(defined($mnat)) {
        print "NR  Found matching attr:" . $_->getLocalName() . "\n" if($DBUG);
        if($mnat->getNodeValue() ne $_->getNodeValue()) {
          if     ($cres eq 'merg') {
            print "NR    CRES:merg so setting main attr:" . $_->getLocalName() .  " to merg valu:" . $_->getNodeValue() . "\n" if($DBUG);
            $mnat->setNodeValue($_->getNodeValue());
          } elsif($cres eq 'warn') {
            croak("!*WARN*! Found conflicting Non-Root attribute:" .
                                   $_   ->getLocalName() .
              "\n  main value:" .  $mnat->getNodeValue() .
              "\n  merg value:" .  $_   ->getNodeValue() .
              "\n    Croaking... please resolve manually.\n");
          } elsif($cres eq 'test') {
            return(0);
          }
        }
      } else {
        print "NR  Found new      attr:" . $_->getLocalName() . "\n" if($DBUG);
        $mnnd->appendAttribute($_) unless($cres eq 'test');
      }
    }
    if($mgnd->findnodes('*')) {
      foreach($mgnd->findnodes('*')) {
        print "NR  Found elem:" . $_->getLocalName() . "\n" if($DBUG);
        my $mtch = 0; # flag to know if already matched
        foreach my $idat (@{$self->get_id_xpath_list()}) { # test ID XPaths
          # if a child merge elem has a matching id, search main for same
          my($mgmt)= $_->findnodes($idat); # MerG MaTch
          if(defined($mgmt)) {
            my $mnmt;
            if     ($idat =~ /^\@/) {
              ($mnmt)= $mnnd->findnodes($_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"]');
            } elsif($idat =~ /\[\@\w+\]/) {
              my $itmp = $idat; my $nval = $mgmt->getNodeValue();
              $itmp =~ s/(\[\@\w+)\]/$1="$nval"\]/;
              ($mnmt)= $mnnd->findnodes($itmp);
            } else {
              ($mnmt)= $mnnd->findnodes($idat);
            }
            if(defined($mnmt)) { # id matched both main && merg...
              print "    Matched elem:" . $_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"] with elem:' . $mnmt->getLocalName() . "\n" if($DBUG);
              $mtch = 1; # so recursively merge deeper...
              my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
              return(0) if($cres eq 'test' && !$test);
            }
          }
        }
        if(!$mtch && $mnnd->findnodes($_->getLocalName())) {
          my($mnmt)= $mnnd->findnodes($_->getLocalName());
          if(defined($mnmt)) { # plain elem matched both main && merg...
            my $fail = 0;
            foreach my $idat (@{$self->get_id_xpath_list()}) {
              my($mnat)= $mnmt->findnodes($idat); # MaiN ATtribute
              my($mgat)= $_   ->findnodes($idat); # MerG ATtribute
              $fail = 1 if(defined($mnat) || defined($mgat));
            }
            unless($fail) { # fail tests if any unique id paths were found
              $mtch = 1; # so recursively merge deeper...
              my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
              return(0) if($cres eq 'test' && !$test);
            }
          }
        }
        # if none above matched, append diff child to main root node
        $mnnd->appendChild($_) unless($mtch || $cres eq 'test');
      }
    } elsif($mgnd->getChildNodes()) { # no child elems but child text data node
      my($mntx)= $mnnd->getChildNodes();
      my($mgtx)= $mgnd->getChildNodes();
      if(defined($mgtx) && $mgtx->getNodeType() == TEXT_NODE) {
        print "NR  Found text:" . $mgnd->getLocalName() . " valu:" . $mgtx->getNodeValue() . "\n" if($DBUG);
        if     (!defined($mntx) && $cres ne 'test') {
          $mnnd->appendChild($mgtx);
        } elsif($cres eq 'merg') {
          $mntx->setNodeValue($mgtx->getNodeValue());
        } elsif($cres eq 'warn') {
          croak("!*WARN*! Found conflicting Non-Root text node:" .
                                 $mnnd->getLocalName() .
            "\n  main value:" .  $mntx->getNodeValue() .
            "\n  merg value:" .  $mgtx->getNodeValue() .
            "\n    Croaking... please resolve manually.\n");
        } elsif($cres eq 'test') {
          #return(0); # new text node value is not a merge prob?
        }
      }
    }
  } elsif($cres ne 'test') { # append whole merge elem as last kid of main elem
    print "Non-Root Node Element names differ so appending mgrn as last child of mnrn!\n" if($DBUG);
    $mnnd->appendChild($mgnd);
    $mnnd->appendChild($self->Text("\n"));
  }
  print "NR  mnnd:" . $mnnd->getLocalName() . "\n" if($DBUG);
  print "NR  mgnd:" . $mgnd->getLocalName() . "\n" if($DBUG);
  return(1);
}

sub unmerge { # short-hand for writing a certain xpath_loc out then pruning it
  my $self = shift(); my @parm; my $xplc = undef; my $flnm = undef;
  # setup local options
  for(my $indx = 0; $indx < @_; $indx++) {
    if     ($_[$indx] =~ /^[-_]?(flnm$|filename)/       && ($indx + 1) < @_) {
      $flnm = $_[++$indx];
    } elsif($_[$indx] =~ /^[-_]?(xplc$|xpath_location)/ && ($indx + 1) < @_) {
      $xplc = $_[++$indx];
    } else {
      push(@parm, $_[$indx]);
    }
  }
  if(@parm) {
    $flnm = shift(@parm) unless(defined($flnm));
    $xplc = shift(@parm) unless(defined($xplc));
  }
  if(defined($flnm) && defined($xplc) &&
     length ($flnm) && length ($xplc)) {
    $self->write($flnm,
                 $xplc);
    $self->prune($xplc);
  }
}

# Accessors
sub get_object_to_merge {
  my $self = shift();
  return($self->{'_object_to_merge'});
}

sub set_object_to_merge {
  my $self = shift();
  $self->{'_object_to_merge'} = shift() if(@_);
  return($self->{'_object_to_merge'});
}

sub get_conflict_resolution_method {
  my $self = shift();
  return($self->{'_conflict_resolution_method'});
}

sub set_conflict_resolution_method {
  my $self = shift();
  $self->{'_conflict_resolution_method'} = shift() if(@_);
  return($self->{'_conflict_resolution_method'});
}

sub get_comment_join_method {
  my $self = shift();
  return($self->{'_comment_join_method'});
}

sub set_comment_join_method {
  my $self = shift();
  $self->{'_comment_join_method'} = shift() if(@_);
  return($self->{'_comment_join_method'});
}

sub get_id_xpath_list {
  my $self = shift();
  return($self->{'_id_xpath_list'});
}

sub set_id_xpath_list {
  my $self = shift();
  if(@_) {
    if(@_ == 1 && ref($_[0]) eq 'ARRAY') {
      $self->{'_id_xpath_list'} = shift();
    } else {
      $self->{'_id_xpath_list'} = [ @_ ];
    }
  }
  return($self->{'_id_xpath_list'});
}

sub DESTROY { } # do nothing but define in case && to calm test warnings

127;