File Coverage

blib/lib/XML/Merge.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             # 4AIDCLW - XML::Merge.pm created by Pip Stuart
3             # to intelligently merge XML documents as parsed XML::XPath objects.
4             #
5             # Plan:
6             # if same-named root nodes,
7             # merge straight
8             # elsif root of 2nd exists in 1st,
9             # merge at first match
10             # else
11             # append 2nd root as new last child of 1st root
12             #
13             # XML::Merge new(filename => 'fnam'[, ])
14             # inherits XML::Tidy which inherits XML::XPath.
15             # Merge creates an object with a merge() member which creates another
16             # XPath object && combines the result back into the main object.
17             # optn:
18             # merge below specified context
19             # id attributes: 'id', 'name', && 'handle' (default)
20             # join comments of same context (leave separate default)
21             # source-file-stamp merged comments
22             # time-stamp merged comments
23             # pt-stamp merged comments
24             # conflict rules:
25             # main wins (default)
26             # last-in wins (aka. clobber)
27             # newer modification date wins
28             # warn (croak conflict)
29             # test (don't merge anything, just return true if no conflicts)
30             # members:
31             # merge() (can accept tmp override optz)
32             # unmerge()
33             #
34             # option to rename some XPath to something else so like simple example
35             # is taking merge-file's root node element && pretending it is
36             # named the same as the main-file's root node element so that the
37             # two can merge in place even though their root node elements had
38             # different names. This would clobber the name of the merge-file
39             # element with the main-file one but it would be a useful option.
40             #
41              
42             =head1 NAME
43              
44             XML::Merge - flexibly merge XML documents
45              
46             =head1 VERSION
47              
48             This documentation refers to version 1.2.565EgGd of
49             XML::Merge, which was released on Sun Jun 5 14:42:16:39 2005.
50              
51             =head1 SYNOPSIS
52              
53             use XML::Merge;
54              
55             # create new XML::Merge object from MainFile.xml
56             my $merge_obj = XML::Merge->new('filename' => 'MainFile.xml');
57              
58             # Merge File2Add.xml into MainFile.xml
59             $merge_obj->merge( 'filename' => 'File2Add.xml');
60              
61             # Tidy up the indenting that resulted from the merge
62             $merge_obj->tidy();
63              
64             # Write out changes back to MainFile.xml
65             $merge_obj->write();
66              
67             =head1 DESCRIPTION
68              
69             This module inherits from L which in turn inherits from
70             L. This ensures that Merge objects' indenting can be
71             tidied up after any merge operation since such modification usually
72             spells the ruination of indentation. Polymorphism allows Merge
73             objects to be utilized as normal XML::XPath objects as well.
74              
75             The merging behavior is setup to combine separate XML documents
76             according to certain rules && configurable options. If both
77             documents have root nodes which are elements of the same name, the
78             documents are merged directly. Otherwise, one is merged as a child
79             of the other. An optional XPath location can be specified as the
80             place to perform the merge. If no location is specified, the merge
81             is attempted at the first matching element or is appended as the new
82             last child of the other root if no match is found.
83              
84             =head1 2DO
85              
86             =over 2
87              
88             =item - mk namespaces && attz stay in order after merge()
89              
90             =item - mk txt apnd merg optn
91              
92             =item - handle comment joins && stamping && options
93              
94             =item - support modification-time _cres
95              
96             =item - add _ignr ignore list of merg xplc's to not merge (pre-prune())
97              
98             =item - support _idea options where several attz together are single id
99              
100             =item - What else does Merge need?
101              
102             =back
103              
104             =head1 USAGE
105              
106             =head2 new()
107              
108             This is the standard Merge object constructor. It can take the
109             same parameters as an L object constructor to initialize
110             the primary XML document object (the object which subsequent XML
111             documents will be merged into). These parameters can be any one of:
112              
113             'filename' => 'SomeFile.xml'
114             'xml' => $variable_which_holds_a_bunch_of_XML_data
115             'ioref' => $file_InputOutput_reference
116             'context' => $existing_node_at_specified_context_to_become_new_obj
117              
118             Merge's new() can also accept merge-option parameters to
119             override the default merge behavior. These include:
120              
121             'conflict_resolution_method' => 'main', # main file wins
122             'conflict_resolution_method' => 'merg', # merge file wins
123             # 'last-in_wins' is an alias for 'merg'
124             'conflict_resolution_method' => 'warn', # croak conflicts
125             'conflict_resolution_method' => 'test', # just test, 0 if conflict
126             # this option is not implemented yet, please say if you need it
127             'comment_join_method' => 'none',
128              
129             =head2 merge()
130              
131             The merge() member function can accept the same L
132             constructor options as new() but this time they are for the
133             temporary file which will be merged into the main object.
134             Merge-options from new() can also be specified && they will only
135             impact one particular invokation of merge(). The specified document
136             will be merged into the primary XML document object according to
137             the following default merge rules:
138              
139             0. If both documents share the same root element name, they are
140             merged directly.
141             1. If they don't share root elements but the temporary merge file's
142             root element is found anywhere within the main file, the merge
143             occurs at the match.
144             2. If no root element match is found, the merge document becomes the
145             new last child of the main file's root element.
146             3. Whenever a deeper level is found with an element of the same name
147             in both documents && either it does not contain any
148             distinguishing attributes or it has attributes which are
149             recognized as 'identifier' (id) attributes (by default, for any
150             element, these are attributes named: 'id', 'name', && 'handle'),
151             a corresponding element is searched for to match && merge with.
152             4. Any remaining (non-id) nodes are merged in document order.
153             5. When a conflict arises as non-id attributes or other nodes merge,
154             the specified conflict_resolution_method merge-option is
155             applied (which by default has the main file data persist at the
156             expense of the merging file data).
157              
158             Some of the above rules can be overridden first by the object's
159             merge-options && second by the particular method call's merge-options.
160             Thus, if the default merge-option for conflict resolution is to
161             have the main object win && you use the following constructor:
162              
163             my $merge_obj = XML::Merge->new(
164             'filename' => 'MainFile.xml',
165             'conflict_resolution_method' => 'last-in_wins');
166              
167             ... then any $merge_obj->merge() call would override the
168             default merge behavior by letting the document being merged have
169             priority over the main object's document. However, you could
170             supply additional merge-options in the parameter list of your
171             specific merge() call like:
172              
173             $merge_obj->merge(
174             'filename' => 'File2Add.xml',
175             'conflict_resolution_method' => 'warn');
176              
177             ... then the latest option would override the already overridden.
178              
179             The 'test' conflict_resolution_method merge-option does not modify the
180             object at all. It solely returns true if no conflict is encountered.
181             It should be used like:
182              
183             foreach(@files) {
184             if($merge_obj->merge('cres' => 'test', $_)) {
185             $merge_obj->merge($_); # only do it if there are no conflicts
186             } else {
187             croak("Yipes! Conflict with file:$_!\n");
188             }
189             }
190              
191             merge() can also accept another XML::Merge object as a parameter
192             for what to be merged with the main object instead of a filename.
193             An example of this is:
194              
195             $merge_obj->merge($another_merge_obj);
196              
197             Along with the merge options that can be specified in the object
198             constructor, merge() also accepts the following options to specify
199             where to perform the merge relative to:
200              
201             'merge_destination_path' => $main_obj_xpath_location,
202             'merge_source_path' => $merging_obj_xpath_location,
203              
204             =head2 unmerge()
205              
206             The unmerge() member function is a shorthand for calling both write()
207             && prune() on a certain XPath location which should be written out
208             to a disk file before being removed from the Merge object. Please
209             see L for documentation of the inherited write() && prune()
210             member functions.
211              
212             This unmerge() process could be the opposite of merge() if no original
213             elements or attributes overlapped && combined but if combining did
214             happen, this would remove original sections of your primary XML
215             document's data from your Merge object so please use this carefully.
216             It is meant to help separate a giant object (probably the result of
217             myriad merge() calls) back into separate useful well-formed XML
218             documents on disk.
219              
220             unmerge() takes a filename && an xpath_location parameter.
221              
222             =head1 Accessors
223              
224             =head2 get_object_to_merge()
225              
226             Returns the object which was last merged into the main object.
227              
228             =head2 set_object_to_merge()
229              
230             Assigns the object which was last merged into the main object.
231              
232             =head2 get_conflict_resolution_method()
233              
234             Returns the underlying merge-option conflict_resolution_method.
235              
236             =head2 set_conflict_resolution_method()
237              
238             A new value can be provided as a parameter to be assigned
239             as the XML::Merge object's merge-option.
240              
241             =head2 get_comment_join_method()
242              
243             Returns the underlying merge-option comment_join_method.
244              
245             =head2 set_comment_join_method()
246              
247             A new value can be provided as a parameter to be assigned
248             as the XML::Merge object's merge-option.
249              
250             =head2 get_id_xpath_list()
251              
252             Returns the underlying id_xpath_list. This is normally just a list
253             of attributes (eg. '@id', '@name', '@handle') which are unique
254             identifiers for any XML element. When these attribute names are
255             encountered during a merge(), another element with the same name &&
256             attribute value are matched for further merging && conflict resolution.
257              
258             =head2 set_id_xpath_list()
259              
260             A new list can assigned to the XML::Merge object's id_xpath_list.
261              
262             Please note that this list normally contains XPath attributes so they
263             must be preceded by an at-symbol (@) like: '@example_id_attribute'.
264              
265             =head1 CHANGES
266              
267             Revision history for Perl extension XML::Merge:
268              
269             =over 4
270              
271             =item - 1.2.565EgGd Sun Jun 5 14:42:16:39 2005
272              
273             * added use XML::Tidy to make sure exports are available
274              
275             * removed 02prune.t && moved 03keep.t to 02keep.t ... passing tests is good
276              
277             =item - 1.2.4CCJWiB Sun Dec 12 19:32:44:11 2004
278              
279             * guessing how to fix Darwin test failure @ t/02prune.t first prune() call
280              
281             =item - 1.0.4CAL5IS Fri Dec 10 21:05:18:28 2004
282              
283             * fixed buggy _recmerge
284              
285             =item - 1.0.4CAEU0I Fri Dec 10 14:30:00:18 2004
286              
287             * made accessors for _id_xpath_list
288              
289             * made _id_xpath_list take XPath locations instead of elem names (old _idea)
290              
291             * made test _cres (at Marc's request)
292              
293             * made warn _cres croak
294              
295             * made Merge inherit from Tidy (which inherits from XPath)
296              
297             * separated reload(), strip(), tidy(), prune(), && write() into own
298             XML::Tidy module
299              
300             =item - 1.0.4C2Nf0R Thu Dec 2 23:41:00:27 2004
301              
302             * updated license && prep'd for release
303              
304             =item - 1.0.4C2BcI2 Thu Dec 2 11:38:18:02 2004
305              
306             * updated reload(), strip(), && tidy() to verify _xpob exists
307              
308             =item - 1.0.4C1JHOl Wed Dec 1 19:17:24:47 2004
309              
310             * commented out override stuff since it's probably bad form && dumps crap
311             warnings all over tests && causes them to fail... so I guess just
312             uncomment that stuff if you care to preserve PI's && escapes
313              
314             =item - 1.0.4C1J7gt Wed Dec 1 19:07:42:55 2004
315              
316             * made merge() accept merge_source_xpath && merge_destination_xpath params
317              
318             * made merge() accept other Merge objects
319              
320             * made reload() not clobber basic escapes (by overriding Text toString())
321              
322             * made tidy() not kill processing-instructions (by overriding node_test())
323              
324             * made tidy() not kill comments
325              
326             =item - 1.0.4BOHGjm Wed Nov 24 17:16:45:48 2004
327              
328             * fixed merge() same elems with diff ids bug
329              
330             =item - 1.0.4BNBCZL Tue Nov 23 11:12:35:21 2004
331              
332             * rewrote both merge() && _recmerge() _cres stuff since it was
333             buggy before... so hopefully consistently good now
334              
335             =item - 1.0.4BMJCPm Mon Nov 22 19:12:25:48 2004
336              
337             * fixed merge() for empty elem matching && _cres on text kids
338              
339             =item - 1.0.4BMGTLF Mon Nov 22 16:29:21:15 2004
340              
341             * separated reload() from strip() so that prune() can call it too
342              
343             =item - 1.0.4BM0B3x Mon Nov 22 00:11:03:59 2004
344              
345             * fixed tidy() empty elem bug && implemented prune() && unmerge()
346              
347             =item - 1.0.4BJAZpM Fri Nov 19 10:35:51:22 2004
348              
349             * fixing e() ABSTRACT gen bug
350              
351             =item - 1.0.4BJAMR6 Fri Nov 19 10:22:27:06 2004
352              
353             * fleshed out pod && members
354              
355             =item - 1.0.4AIDqmR Mon Oct 18 13:52:48:27 2004
356              
357             * original version
358              
359             =back
360              
361             =head1 INSTALL
362              
363             From your command shell, please run:
364              
365             `perl -MCPAN -e "install XML::Merge"`
366              
367             or uncompress the package && run the standard:
368              
369             `perl Makefile.PL; make; make test; make install`
370              
371             =head1 FILES
372              
373             XML::Merge requires:
374              
375             L to allow errors to croak() from calling sub
376              
377             L to use objects derived from XPath to update XML
378              
379             =head1 LICENSE
380              
381             Most source code should be Free!
382             Code I have lawful authority over is && shall be!
383             Copyright: (c) 2004, Pip Stuart.
384             Copyleft : This software is licensed under the GNU General Public
385             License (version 2), && as such comes with NO WARRANTY. Please
386             consult the Free Software Foundation (http://FSF.Org) for
387             important information about your freedom.
388              
389             =head1 AUTHOR
390              
391             Pip Stuart
392              
393             =cut
394              
395             # Please see CHANGES section to know why the following is commented.
396             ## Need to fix node_test() test_nt_pi return in XML::XPath::Step.pm first...
397             #package XML::XPath::Step;
398             #use XML::XPath::Parser;
399             #use XML::XPath::Node;
400             #
401             #sub node_test {
402             # my $self = shift; my $node = shift;
403             # my $test = $self->{test}; # if node passes test, return true
404             # return 1 if $test == test_nt_node;
405             # if($test == test_any) {
406             # return 1 if $node->isElementNode && defined $node->getName;
407             # }
408             # local $^W;
409             # if($test == test_ncwild) {
410             # return unless $node->isElementNode;
411             # my $match_ns = $self->{pp}->get_namespace($self->{literal}, $node);
412             # if(my $node_nsnode = $node->getNamespace()) {
413             # return 1 if $match_ns eq $node_nsnode->getValue;
414             # }
415             # } elsif($test == test_qname) {
416             # return unless $node->isElementNode;
417             # if($self->{literal} =~ /:/) {
418             # my($prefix, $name) = split(':', $self->{literal}, 2);
419             # my $match_ns = $self->{pp}->get_namespace($prefix, $node);
420             # if(my $node_nsnode = $node->getNamespace()) {
421             # return 1 if($match_ns eq $node_nsnode->getValue && $name eq $node->getLocalName);
422             # }
423             # } else {
424             # return 1 if $node->getName eq $self->{literal};
425             # }
426             # } elsif ($test == test_nt_text) {
427             # return 1 if $node->isTextNode;
428             # } elsif($test == test_nt_comment) {
429             # return 1 if $node->isCommentNode;
430             # } elsif($test == test_nt_pi) {
431             # return unless $node->isPINode;
432             # # EROR was here! $self->{literal} is undefined so can't ->value!
433             # #if(my $val = $self->{literal}->value) {
434             # # return 1 if $node->getTarget eq $val;
435             # #} else {
436             # return 1;
437             # #}
438             # }
439             # return; # fallthrough returns false
440             #}
441             ## ... also update Text nodes' toString() to escape both < && >! ...
442             #package XML::XPath::Node::TextImpl;
443             #sub toString {
444             # my $self = shift; XML::XPath::Node::XMLescape($self->[node_text], '<&>');
445             #}
446              
447             # Now ready to handle XML::Merge package...
448             package XML::Merge;
449 2     2   14477 use warnings;
  2         5  
  2         73  
450 2     2   20 use strict;
  2         3  
  2         91  
451             require XML::Tidy;
452 2     2   14 use base qw( XML::Tidy );
  2         8  
  2         3485  
453             use XML::Tidy;
454             use Carp;
455             our $VERSION = '1.2.565EgGd'; # major . minor . PipTimeStamp
456             our $PTVR = $VERSION; $PTVR =~ s/^\d+\.\d+\.//; # strip major and minor
457             # Please see `perldoc Time::PT` for an explanation of $PTVR.
458              
459             my $DBUG = 0;
460              
461             sub new {
462             my $clas = shift(); my @parm; my $cres = 'main';
463             for(my $indx = 0; $indx < @_; $indx++) {
464             if($_[$indx] =~ /^[-_]?(cres$|conflict_resolution)/ && ($indx + 1) < @_) {
465             $cres = $_[++$indx];
466             } else {
467             push(@parm, $_[$indx]);
468             }
469             }
470             my $tdob = XML::Tidy->new(@parm);
471             my $self = bless($tdob, $clas);
472             # self just a new Tidy (XPath) obj blessed into Merge class...
473             # ... with a few new options
474             $self->{'_object_to_merge'} = undef;
475             $self->{'_conflict_resolution_method'} = $cres;
476             # Conflict RESolution method valid values:
477             # 'main' = Main (primary) file wins
478             # 'merg' = Merge file resolves (Last-In wins)
479             # 'warn' = Croak warning about conflict && halt merge
480             # 'test' = Test whether any conflict would occur if merge were performed
481             $self->{'_comment_join_method'} = 'none';
482             # CoMmenT Join method valid values:
483             # 'none', 'separate'
484             # 'join', 'combine'
485             # 'jpts', 'join_with_piptime_stamp'
486             # 'jlts', 'join_with_localtime_stamp'
487             $self->{'_id_xpath_list'} = [ # unique ID elements or attributes
488             '@id',
489             '@name',
490             '@handle',
491             ];
492             return($self);
493             }
494              
495             sub merge { # under water
496             my $self = shift(); my @parm;
497             my $cres = $self->get_conflict_resolution_method();
498             my $cmtj = $self->get_comment_join_method();
499             my $mdxp = undef;
500             my $msxp = undef;
501             my $mgob = undef;
502             # setup local options
503             for(my $indx = 0; $indx < @_; $indx++) {
504             if ($_[$indx] =~ /^[-_]?(cres$|conflict_resolution)/ && ($indx + 1) < @_) {
505             $cres = $_[++$indx];
506             } elsif($_[$indx] =~ /^[-_]?(cmtj$|comment_join)/ && ($indx + 1) < @_) {
507             $cmtj = $_[++$indx];
508             } elsif($_[$indx] =~ /^[-_]?(mdxp$|merge_destination)/ && ($indx + 1) < @_) {
509             $mdxp = $_[++$indx];
510             } elsif($_[$indx] =~ /^[-_]?(msxp$|merge_source)/ && ($indx + 1) < @_) {
511             $msxp = $_[++$indx];
512             } elsif(ref($_[$indx]) =~ /XML::(XPath|Tidy|Merge)/) {
513             $self->set_object_to_merge($_[$indx]);
514             } else {
515             push(@parm, $_[$indx]);
516             }
517             }
518             $self->set_object_to_merge( XML::Merge->new(@parm) ) if(@parm);
519             $cres = 'merg' if($cres =~ /last/i);
520             $mgob = $self->get_object_to_merge();
521             if($mgob) {
522             my $mnrn; my $mgrn;
523             # traverse main Merge obj && merge w/ object_to_merge according to options
524             # 0a. ck if root node elems have same LocalName
525             # but short-circuit root element loading if merge_source or merge_dest
526             if(defined($mdxp) && length($mdxp)) {
527             ($mnrn)= $self->findnodes($mdxp);
528             } else {
529             ($mnrn)= $self->findnodes('/*');
530             }
531             if(defined($msxp) && length($msxp)) {
532             ($mgrn)= $mgob->findnodes($msxp);
533             } else {
534             ($mgrn)= $mgob->findnodes('/*');
535             }
536             if($mnrn->getLocalName() eq $mgrn->getLocalName()) {
537             print "Root Node Element names match so merging in place!\n" if($DBUG);
538             # 1a. ck if each merge root elem has attributes which main doesn't
539             foreach($mgrn->findnodes('@*')) {
540             print " Found attr:" . $_->getLocalName() . "\n" if($DBUG);
541             my($mnat)= $mnrn->findnodes('@' . $_->getLocalName());
542             # if both root elems have same attribute name with different values...
543             if(defined($mnat)) {
544             print " Found matching attr:" . $_->getLocalName() . "\n" if($DBUG);
545             # must use Conflict RESolution method to know who's value wins
546             if($mnat->getNodeValue() ne $_->getNodeValue()) {
547             if ($cres eq 'merg') {
548             print " CRES:merg so setting main attr:" . $_->getLocalName() . " to merg valu:" . $_->getNodeValue() . "\n" if($DBUG);
549             $mnat->setNodeValue($_->getNodeValue());
550             } elsif($cres eq 'warn') {
551             croak("!*WARN*! Found conflicting attribute:" .
552             $_ ->getLocalName() .
553             "\n main value:" . $mnat->getNodeValue() .
554             "\n merg value:" . $_ ->getNodeValue() .
555             "\n Croaking... please resolve manually.\n");
556             } elsif($cres eq 'test') {
557             return(0);
558             }
559             }
560             } else {
561             print " Found new attr:" . $_->getLocalName() . "\n" if($DBUG);
562             $mnrn->appendAttribute($_) unless($cres eq 'test');
563             }
564             }
565             # 1b. loop through all merge child elems
566             if($mgrn->findnodes('*')) {
567             foreach($mgrn->findnodes('*')) {
568             print " Found elem:" . $_->getLocalName() . "\n" if($DBUG);
569             my $mtch = 0; # flag to know if already matched
570             # test ID paths
571             foreach my $idat (@{$self->get_id_xpath_list()}) {
572             print " idat matching against:$idat\n" if($DBUG);
573             # if a child merge elem has a matching id, search main for same
574             my($mgmt)= $_->findnodes($idat); # MerG MaTch
575             if(defined($mgmt)) {
576             print " Matched idat:$idat\n" if($DBUG);
577             my $mnmt;
578             if ($idat =~ /^\@/) {
579             ($mnmt)= $mnrn->findnodes($_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"]');
580             } elsif($idat =~ /\[\@\w+\]/) {
581             my $itmp = $idat; my $nval = $mgmt->getNodeValue();
582             $itmp =~ s/(\[\@\w+)\]/$1="$nval"\]/;
583             ($mnmt)= $mnrn->findnodes($itmp);
584             } else {
585             ($mnmt)= $mnrn->findnodes($idat);
586             }
587             if(defined($mnmt)) { # id matched both main && merg...
588             print " Matched elem:" . $_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"] with elem:' . $mnmt->getLocalName() . "\n" if($DBUG);
589             $mtch = 1; # so recursively merge deeper...
590             my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
591             return(0) if($cres eq 'test' && !$test);
592             }
593             }
594             }
595             if(!$mtch && $mnrn->findnodes($_->getLocalName())) {
596             my($mnmt)= $mnrn->findnodes($_->getLocalName());
597             if(defined($mnmt)) { # plain elem matched both main && merg...
598             my $fail = 0;
599             foreach my $idat (@{$self->get_id_xpath_list()}) {
600             my($mnat)= $mnmt->findnodes($idat); # MaiN ATtribute
601             my($mgat)= $_ ->findnodes($idat); # MerG ATtribute
602             $fail = 1 if(defined($mnat) || defined($mgat));
603             }
604             unless($fail) { # fail tests if any unique id paths were found
605             $mtch = 1; # so recursively merge deeper...
606             my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
607             return(0) if($cres eq 'test' && !$test);
608             }
609             }
610             }
611             # if none above matched, append diff child to main root node
612             $mnrn->appendChild($_) unless($mtch || $cres eq 'test');
613             }
614             } elsif($mgrn->getChildNodes()) { # no kid elems but kid text data node
615             my($mntx)= $mnrn->getChildNodes();
616             my($mgtx)= $mgrn->getChildNodes();
617             if(defined($mgtx) && $mgtx->getNodeType() == TEXT_NODE) {
618             print " Found text:" . $mgrn->getLocalName() . " valu:" . $mgtx->getNodeValue() . "\n" if($DBUG);
619             if (!defined($mntx)) {
620             $mnrn->appendChild($mgtx) unless($cres eq 'test');
621             } elsif($cres eq 'merg') {
622             $mntx->setNodeValue($mgtx->getNodeValue());
623             } elsif($cres eq 'warn') {
624             croak("!*WARN*! Found conflicting Root text node:" .
625             $mnrn->getLocalName() .
626             "\n main value:" . $mntx->getNodeValue() .
627             "\n merg value:" . $mgtx->getNodeValue() .
628             "\n Croaking... please resolve manually.\n");
629             } elsif($cres eq 'test') {
630             #return(0); # new text node value is not a merge prob?
631             }
632             }
633             }
634             # 0b. ck if merge root node elem exists somewhere in main
635             } elsif($self->findnodes('//' . $mgrn->getLocalName())) {
636             print "Root Node Element names differ && mgrn is in mnrn so merging at match!\n" if($DBUG);
637             my($mnmt)= $self->findnodes('//' . $mgrn->getLocalName());
638             # recursively merge main child with merg root
639             my $test = $self->_recmerge($mnmt, $mgrn, $cres, $cmtj);
640             return(0) if($cres eq 'test' && !$test);
641             # 0c. just append whole merge doc as last child of main root
642             } elsif($cres ne 'test') {
643             print "Root Node Element names differ so appending mgrn as last child of mnrn!\n" if($DBUG);
644             $mnrn->appendChild($mgrn);
645             $mnrn->appendChild($self->Text("\n"));
646             }
647             print " mnrn:" . $mnrn->getLocalName() . "\n" if($DBUG);
648             print " mgrn:" . $mgrn->getLocalName() . "\n" if($DBUG);
649             }
650             return(1); # true test _cres == no conflict, 0 == conflict
651             }
652              
653             sub _recmerge { # recursively merge XML elements
654             my $self = shift(); # merge() already setup all needed _optn values
655             my $mnnd = shift(); # MaiN NoDe
656             my $mgnd = shift(); # MerG NoDe
657             my $cres = shift() || $self->get_conflict_resolution_method();
658             my $cmtj = shift() || $self->get_comment_join_method();
659             if($mnnd->getLocalName() eq $mgnd->getLocalName()) {
660             print "Non-Root Node Element names match so merging in place!\n" if($DBUG);
661             foreach($mgnd->findnodes('@*')) {
662             print "NR Found attr:" . $_->getLocalName() . "\n" if($DBUG);
663             my($mnat)= $mnnd->findnodes('@' . $_->getLocalName());
664             if(defined($mnat)) {
665             print "NR Found matching attr:" . $_->getLocalName() . "\n" if($DBUG);
666             if($mnat->getNodeValue() ne $_->getNodeValue()) {
667             if ($cres eq 'merg') {
668             print "NR CRES:merg so setting main attr:" . $_->getLocalName() . " to merg valu:" . $_->getNodeValue() . "\n" if($DBUG);
669             $mnat->setNodeValue($_->getNodeValue());
670             } elsif($cres eq 'warn') {
671             croak("!*WARN*! Found conflicting Non-Root attribute:" .
672             $_ ->getLocalName() .
673             "\n main value:" . $mnat->getNodeValue() .
674             "\n merg value:" . $_ ->getNodeValue() .
675             "\n Croaking... please resolve manually.\n");
676             } elsif($cres eq 'test') {
677             return(0);
678             }
679             }
680             } else {
681             print "NR Found new attr:" . $_->getLocalName() . "\n" if($DBUG);
682             $mnnd->appendAttribute($_) unless($cres eq 'test');
683             }
684             }
685             if($mgnd->findnodes('*')) {
686             foreach($mgnd->findnodes('*')) {
687             print "NR Found elem:" . $_->getLocalName() . "\n" if($DBUG);
688             my $mtch = 0; # flag to know if already matched
689             foreach my $idat (@{$self->get_id_xpath_list()}) { # test ID XPaths
690             # if a child merge elem has a matching id, search main for same
691             my($mgmt)= $_->findnodes($idat); # MerG MaTch
692             if(defined($mgmt)) {
693             my $mnmt;
694             if ($idat =~ /^\@/) {
695             ($mnmt)= $mnnd->findnodes($_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"]');
696             } elsif($idat =~ /\[\@\w+\]/) {
697             my $itmp = $idat; my $nval = $mgmt->getNodeValue();
698             $itmp =~ s/(\[\@\w+)\]/$1="$nval"\]/;
699             ($mnmt)= $mnnd->findnodes($itmp);
700             } else {
701             ($mnmt)= $mnnd->findnodes($idat);
702             }
703             if(defined($mnmt)) { # id matched both main && merg...
704             print " Matched elem:" . $_->getLocalName() . '[' . $idat . '="' . $mgmt->getNodeValue() . '"] with elem:' . $mnmt->getLocalName() . "\n" if($DBUG);
705             $mtch = 1; # so recursively merge deeper...
706             my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
707             return(0) if($cres eq 'test' && !$test);
708             }
709             }
710             }
711             if(!$mtch && $mnnd->findnodes($_->getLocalName())) {
712             my($mnmt)= $mnnd->findnodes($_->getLocalName());
713             if(defined($mnmt)) { # plain elem matched both main && merg...
714             my $fail = 0;
715             foreach my $idat (@{$self->get_id_xpath_list()}) {
716             my($mnat)= $mnmt->findnodes($idat); # MaiN ATtribute
717             my($mgat)= $_ ->findnodes($idat); # MerG ATtribute
718             $fail = 1 if(defined($mnat) || defined($mgat));
719             }
720             unless($fail) { # fail tests if any unique id paths were found
721             $mtch = 1; # so recursively merge deeper...
722             my $test = $self->_recmerge($mnmt, $_, $cres, $cmtj);
723             return(0) if($cres eq 'test' && !$test);
724             }
725             }
726             }
727             # if none above matched, append diff child to main root node
728             $mnnd->appendChild($_) unless($mtch || $cres eq 'test');
729             }
730             } elsif($mgnd->getChildNodes()) { # no child elems but child text data node
731             my($mntx)= $mnnd->getChildNodes();
732             my($mgtx)= $mgnd->getChildNodes();
733             if(defined($mgtx) && $mgtx->getNodeType() == TEXT_NODE) {
734             print "NR Found text:" . $mgnd->getLocalName() . " valu:" . $mgtx->getNodeValue() . "\n" if($DBUG);
735             if (!defined($mntx) && $cres ne 'test') {
736             $mnnd->appendChild($mgtx);
737             } elsif($cres eq 'merg') {
738             $mntx->setNodeValue($mgtx->getNodeValue());
739             } elsif($cres eq 'warn') {
740             croak("!*WARN*! Found conflicting Non-Root text node:" .
741             $mnnd->getLocalName() .
742             "\n main value:" . $mntx->getNodeValue() .
743             "\n merg value:" . $mgtx->getNodeValue() .
744             "\n Croaking... please resolve manually.\n");
745             } elsif($cres eq 'test') {
746             #return(0); # new text node value is not a merge prob?
747             }
748             }
749             }
750             } elsif($cres ne 'test') { # append whole merge elem as last kid of main elem
751             print "Non-Root Node Element names differ so appending mgrn as last child of mnrn!\n" if($DBUG);
752             $mnnd->appendChild($mgnd);
753             $mnnd->appendChild($self->Text("\n"));
754             }
755             print "NR mnnd:" . $mnnd->getLocalName() . "\n" if($DBUG);
756             print "NR mgnd:" . $mgnd->getLocalName() . "\n" if($DBUG);
757             return(1);
758             }
759              
760             sub unmerge { # short-hand for writing a certain xpath_loc out then pruning it
761             my $self = shift(); my @parm; my $xplc = undef; my $flnm = undef;
762             # setup local options
763             for(my $indx = 0; $indx < @_; $indx++) {
764             if ($_[$indx] =~ /^[-_]?(flnm$|filename)/ && ($indx + 1) < @_) {
765             $flnm = $_[++$indx];
766             } elsif($_[$indx] =~ /^[-_]?(xplc$|xpath_location)/ && ($indx + 1) < @_) {
767             $xplc = $_[++$indx];
768             } else {
769             push(@parm, $_[$indx]);
770             }
771             }
772             if(@parm) {
773             $flnm = shift(@parm) unless(defined($flnm));
774             $xplc = shift(@parm) unless(defined($xplc));
775             }
776             if(defined($flnm) && defined($xplc) &&
777             length ($flnm) && length ($xplc)) {
778             $self->write($flnm,
779             $xplc);
780             $self->prune($xplc);
781             }
782             }
783              
784             # Accessors
785             sub get_object_to_merge {
786             my $self = shift();
787             return($self->{'_object_to_merge'});
788             }
789              
790             sub set_object_to_merge {
791             my $self = shift();
792             $self->{'_object_to_merge'} = shift() if(@_);
793             return($self->{'_object_to_merge'});
794             }
795              
796             sub get_conflict_resolution_method {
797             my $self = shift();
798             return($self->{'_conflict_resolution_method'});
799             }
800              
801             sub set_conflict_resolution_method {
802             my $self = shift();
803             $self->{'_conflict_resolution_method'} = shift() if(@_);
804             return($self->{'_conflict_resolution_method'});
805             }
806              
807             sub get_comment_join_method {
808             my $self = shift();
809             return($self->{'_comment_join_method'});
810             }
811              
812             sub set_comment_join_method {
813             my $self = shift();
814             $self->{'_comment_join_method'} = shift() if(@_);
815             return($self->{'_comment_join_method'});
816             }
817              
818             sub get_id_xpath_list {
819             my $self = shift();
820             return($self->{'_id_xpath_list'});
821             }
822              
823             sub set_id_xpath_list {
824             my $self = shift();
825             if(@_) {
826             if(@_ == 1 && ref($_[0]) eq 'ARRAY') {
827             $self->{'_id_xpath_list'} = shift();
828             } else {
829             $self->{'_id_xpath_list'} = [ @_ ];
830             }
831             }
832             return($self->{'_id_xpath_list'});
833             }
834              
835             sub DESTROY { } # do nothing but define in case && to calm test warnings
836              
837             127;