1#----------------------------------------------------------------------------- 2# 3# $Id : XPath.pm 2.237 2010-07-12 JMG$ 4# 5# Created and maintained by Jean-Marie Gouarne 6# Copyright 2010 by Genicorp, S.A. (www.genicorp.com) 7# 8#----------------------------------------------------------------------------- 9 10package OpenOffice::OODoc::XPath; 11use 5.008_000; 12use strict; 13our $VERSION = '2.237'; 14use XML::Twig 3.32; 15use Encode; 16require Exporter; 17our @ISA = qw ( Exporter ); 18our @EXPORT = qw 19 ( 20 TRUE FALSE is_true is_false 21 odfLocaltime odfTimelocal 22 ); 23 24#------------------------------------------------------------------------------ 25 26use constant 27 { 28 TRUE => 1, 29 FALSE => 0 30 }; 31 32sub is_true 33 { 34 my $arg = shift or return FALSE; 35 $arg = lc $arg; 36 return ($arg eq '1' || $arg eq 'true' || $arg eq 'on') ? TRUE : FALSE; 37 } 38 39sub is_not_true 40 { 41 return is_true(shift) ? FALSE : TRUE; 42 } 43 44#------------------------------------------------------------------------------ 45 46BEGIN { 47 *dispose = *DESTROY; 48 *update = *save; 49 *getXMLContent = *exportXMLContent; 50 *getContent = *exportXMLContent; 51 *getChildElementByName = *selectChildElementByName; 52 *getElementByIdentifier = *selectElementByIdentifier; 53 *blankSpaces = *spaces; 54 *createSpaces = *spaces; 55 *createTextNode = *newTextNode; 56 *getFrame = *getFrameElement; 57 *getUserFieldElement = *getUserField; 58 *getVariableElement = *getVariable; 59 *getNodeByXPath = *selectNodeByXPath; 60 *getNodesByXPath = *selectNodesByXPath; 61 *getElementList = *selectNodesByXPath; 62 *isCalcDocument = *isSpreadsheet; 63 *isDrawDocument = *isDrawing; 64 *isImpressDocument = *isPresentation; 65 *isWriterDocument = *isText; 66 *odfVersion = *openDocumentVersion; 67 } 68 69#------------------------------------------------------------------------------ 70 71our %XMLNAMES = # OODoc root element names 72 ( 73 'content' => 'office:document-content', 74 'styles' => 'office:document-styles', 75 'meta' => 'office:document-meta', 76 'manifest' => 'manifest:manifest', 77 'settings' => 'office:document-settings' 78 ); 79 80 # characters to be escaped in XML 81our $CHARS_TO_ESCAPE = "\"<>'&"; 82 # standard external character set 83our $LOCAL_CHARSET = 'utf8'; 84 # standard ODF character set 85our $OO_CHARSET = 'utf8'; 86 # default element identifier 87our $ELT_ID = 'text:id'; 88 89#------------------------------------------------------------------------------ 90# basic conversion between internal & printable encodings 91 92sub OpenOffice::OODoc::XPath::decode_text 93 { 94 return Encode::encode($LOCAL_CHARSET, shift); 95 } 96 97sub OpenOffice::OODoc::XPath::encode_text 98 { 99 return Encode::decode($LOCAL_CHARSET, shift); 100 } 101 102#------------------------------------------------------------------------------ 103# common date formatting functions 104 105sub odfLocaltime 106 { 107 my $time = shift || time(); 108 my @t = localtime($time); 109 return sprintf 110 ( 111 "%04d-%02d-%02dT%02d:%02d:%02d", 112 $t[5] + 1900, $t[4] + 1, $t[3], $t[2], $t[1], $t[0] 113 ); 114 } 115 116sub odfTimelocal 117 { 118 require Time::Local; 119 120 my $ootime = shift; 121 return undef unless $ootime; 122 $ootime =~ /(\d*)-(\d*)-(\d*)T(\d*):(\d*):(\d*)/; 123 return Time::Local::timelocal($6, $5, $4, $3, $2 - 1, $1); 124 } 125 126#------------------------------------------------------------------------------ 127# object coordinates, size, description control 128 129sub setObjectCoordinates 130 { 131 my $self = shift; 132 my $element = shift or return undef; 133 my ($x, $y) = @_; 134 if ($x && ($x =~ /,/)) # X and Y are concatenated in a single string 135 { 136 $x =~ s/\s*//g; # remove the spaces 137 $x =~ s/,(.*)//; $y = $1; # split on the comma 138 } 139 $x = '0cm' unless $x; $y = '0cm' unless $y; 140 $x .= 'cm' unless $x =~ /[a-zA-Z]$/; 141 $y .= 'cm' unless $y =~ /[a-zA-Z]$/; 142 $self->setAttributes($element, 'svg:x' => $x, 'svg:y' => $y); 143 return wantarray ? ($x, $y) : ($x . ',' . $y); 144 } 145 146sub getObjectCoordinates 147 { 148 my $self = shift; 149 my $element = shift or return undef; 150 my $x = $element->getAttribute('svg:x'); 151 my $y = $element->getAttribute('svg:y'); 152 return undef unless defined $x and defined $y; 153 return wantarray ? ($x, $y) : ($x . ',' . $y); 154 } 155 156sub setObjectSize 157 { 158 my $self = shift; 159 my $element = shift or return undef; 160 my ($w, $h) = @_; 161 if ($w && ($w =~ /,/)) # W and H are concatenated in a single string 162 { 163 $w =~ s/\s*//g; # remove the spaces 164 $w =~ s/,(.*)//; $h = $1; # split on the comma 165 } 166 $w = '0cm' unless $w; $h = '0cm' unless $h; 167 $w .= 'cm' unless $w =~ /[a-zA-Z]$/; 168 $h .= 'cm' unless $h =~ /[a-zA-Z]$/; 169 $self->setAttributes($element, 'svg:width' => $w, 'svg:height' => $h); 170 return wantarray ? ($w, $h) : ($w . ',' . $h); 171 } 172 173sub getObjectSize 174 { 175 my $self = shift; 176 my $element = shift or return undef; 177 my $w = $element->getAttribute('svg:width'); 178 my $h = $element->getAttribute('svg:height'); 179 return wantarray ? ($w, $h) : ($w . ',' . $h); 180 } 181 182sub setObjectDescription 183 { 184 my $self = shift; 185 my $element = shift or return undef; 186 my $text = shift; 187 my $desc = $element->first_child('svg:desc'); 188 unless ($desc) 189 { 190 $self->appendElement($element, 'svg:desc', text => $text) 191 if (defined $text); 192 } 193 else 194 { 195 if (defined $text) { $self->setText($desc, $text, @_); } 196 else { $self->removeElement($desc, @_); } 197 } 198 return $desc; 199 } 200 201sub getObjectDescription 202 { 203 my $self = shift; 204 my $element = shift or return undef; 205 return $self->getXPathValue($element, 'svg:desc'); 206 } 207 208sub getObjectName 209 { 210 my $self = shift; 211 my $element = shift or return undef; 212 my $name = shift; 213 my $attr = $element->getPrefix() . ':name' ; 214 return $self->getAttribute($element, $attr); 215 } 216 217sub setObjectName 218 { 219 my $self = shift; 220 my $element = shift or return undef; 221 my $name = shift; 222 my $attr = $element->getPrefix() . ':name' ; 223 return $self->setAttribute($element, $attr, @_); 224 } 225 226sub objectName 227 { 228 my $self = shift; 229 my $element = shift or return undef; 230 my $name = shift; 231 my $attr = $element->getPrefix() . ':name' ; 232 return (defined $name) ? 233 $self->setAttribute($element, $attr => $name) : 234 $self->getAttribute($element, $attr); 235 } 236 237#------------------------------------------------------------------------------ 238# basic element creation 239 240sub OpenOffice::OODoc::XPath::new_element 241 { 242 my $name = shift or return undef; 243 return undef if ref $name; 244 $name =~ s/^\s+//; 245 $name =~ s/\s+$//; 246 if ($name =~ /^</) # create element from XML string 247 { 248 return OpenOffice::OODoc::Element->parse($name, @_); 249 } 250 else # create element from name and optional data 251 { 252 return OpenOffice::OODoc::Element->new($name, @_); 253 } 254 } 255 256#------------------------------------------------------------------------------ 257# text node creation 258 259sub OpenOffice::OODoc::XPath::new_text_node 260 { 261 return OpenOffice::OODoc::XPath::new_element('#PCDATA', @_); 262 } 263 264#------------------------------------------------------------------------------ 265# basic conversion between internal & printable encodings (object version) 266 267sub inputTextConversion 268 { 269 my $self = shift; 270 my $text = shift; 271 return undef unless defined $text; 272 my $local_encoding = $self->{'local_encoding'} or return $text; 273 return Encode::decode($local_encoding, $text); 274 } 275 276sub outputTextConversion 277 { 278 my $self = shift; 279 my $text = shift; 280 return undef unless defined $text; 281 my $local_encoding = $self->{'local_encoding'} or return $text; 282 return Encode::encode($local_encoding, $text); 283 } 284 285sub localEncoding 286 { 287 my $self = shift; 288 my $encoding = shift; 289 $self->{'local_encoding'} = $encoding if $encoding; 290 return $self->{'local_encoding'} || ''; 291 } 292 293sub noLocalEncoding 294 { 295 my $self = shift; 296 delete $self->{'local_encoding'}; 297 return 1; 298 } 299 300#------------------------------------------------------------------------------ 301# search/replace text processing routine 302# if $replace is a user-provided routine, it's called back with 303# the current argument stack, plus the substring found 304 305sub _find_text 306 { 307 my $self = shift; 308 my $text = shift; 309 my $pattern = $self->inputTextConversion(shift); 310 my $replace = shift; 311 312 if (defined $pattern) 313 { 314 if (defined $replace) 315 { 316 if (ref $replace) 317 { 318 if ((ref $replace) eq 'CODE') 319 { 320 return undef 321 unless 322 ( 323 $text =~ 324 s/($pattern)/ 325 { 326 my $found = $1; 327 Encode::_utf8_on($found) 328 if Encode::is_utf8($text); 329 my $result = &$replace(@_, $found); 330 $result = $found 331 unless (defined $result); 332 $result; 333 } 334 /eg 335 ); 336 } 337 else 338 { 339 return undef unless ($text =~ /$pattern/); 340 } 341 } 342 else 343 { 344 my $r = $self->inputTextConversion($replace); 345 return undef unless ($text =~ s/$pattern/$r/g); 346 } 347 } 348 else 349 { 350 return undef unless ($text =~ /$pattern/); 351 } 352 } 353 return $text; 354 } 355 356#------------------------------------------------------------------------------ 357# search/replace content in descendant nodes 358 359sub _search_content 360 { 361 my $self = shift; 362 my $node = shift or return undef; 363 my $content = undef; 364 365 if ($node->isTextNode) 366 { 367 my $text = $self->_find_text($node->text, @_); 368 if (defined $text) 369 { 370 $node->set_text($text); 371 $content = $text; 372 } 373 } 374 else 375 { 376 foreach my $n ($node->getTextDescendants) 377 { 378 my $text = $self->_find_text($n->text, @_); 379 if (defined $text) 380 { 381 $n->set_text($text); 382 $content .= $text; 383 } 384 } 385 } 386 return $content; 387 } 388 389#------------------------------------------------------------------------------ 390# is this an OASIS Open Document or an OpenOffice 1.x Document ? 391 392sub isOpenDocument 393 { 394 my $self = shift; 395 my $root = $self->getRootElement; 396 die __PACKAGE__ . " Missing root element\n" unless $root; 397 my $ns = $root->att('xmlns:office'); 398 return $ns && ($ns =~ /opendocument/) ? 1 : undef; 399 } 400 401sub openDocumentVersion 402 { 403 my $self = shift; 404 my $new_version = shift; 405 my $root = $self->getRootElement or return undef; 406 $root->set_att('office:version' => $new_version) if $new_version; 407 return $root->att('office:version'); 408 } 409 410#------------------------------------------------------------------------------ 411# document class check 412 413sub isContent 414 { 415 my $self = shift; 416 return ($self->contentClass()) ? 1 : undef; 417 } 418 419sub isSpreadsheet 420 { 421 my $self = shift; 422 return ($self->contentClass() eq 'spreadsheet') ? 1 : undef; 423 } 424sub isPresentation 425 { 426 my $self = shift; 427 return ($self->contentClass() eq 'presentation') ? 1 : undef; 428 } 429sub isDrawing 430 { 431 my $self = shift; 432 return ($self->contentClass() eq 'drawing') ? 1 : undef; 433 } 434sub isText 435 { 436 my $self = shift; 437 return ($self->contentClass() eq 'text') ? 1 : undef; 438 } 439 440#------------------------------------------------------------------------------ 441 442sub _get_container # get a new OODoc::File container 443 { 444 require OpenOffice::OODoc::File; 445 446 my $doc = shift; 447 448 return OpenOffice::OODoc::File->new 449 ( 450 $doc->{'file'}, 451 create => $doc->{'create'}, 452 opendocument => $doc->{'opendocument'}, 453 template_path => $doc->{'template_path'} 454 ); 455 } 456 457sub _get_flat_file # get flat ODF content 458 { 459 my $doc = shift; 460 my $source = $doc->{'file'}; 461 $doc->{'xpath'} = UNIVERSAL::isa($source, 'IO::File') ? 462 $doc->{'twig'}->safe_parse($source) : 463 $doc->{'twig'}->safe_parsefile($source); 464 return $doc->{'path'}; 465 } 466 467sub new 468 { 469 my $caller = shift; 470 my $class = ref($caller) || $caller; 471 my $self = 472 { 473 auto_style_path => '//office:automatic-styles', 474 master_style_path => '//office:master-styles', 475 named_style_path => '//office:styles', 476 image_container => 'draw:image', 477 image_xpath => '//draw:image', 478 image_fpath => '#Pictures/', 479 local_encoding => 480 $OpenOffice::OODoc::XPath::LOCAL_CHARSET, 481 @_ 482 }; 483 484 foreach my $optk (keys %$self) 485 { 486 next unless $self->{$optk}; 487 my $v = lc $self->{$optk}; 488 $self->{$optk} = 0 if ($v =~ /^false$|^off$/); 489 } 490 491 $self->{'container'} = $self->{'file'} if defined $self->{'file'}; 492 $self->{'container'} = $self->{'archive'} if defined $self->{'archive'}; 493 $self->{'part'} = $self->{'member'} if $self->{'member'}; 494 $self->{'part'} = 'content' unless $self->{'part'}; 495 496 unless ($self->{'element'}) 497 { 498 my $m = lc $self->{'part'}; 499 if ($m =~ /(^.*)\..*/) { $m = $1; } 500 $self->{'element'} = 501 $OpenOffice::OODoc::XPath::XMLNAMES{$m}; 502 } 503 # create the XML::Twig 504 if (is_true($self->{'readable_XML'})) 505 { 506 $self->{'readable_XML'} = 'indented'; 507 } 508 $self->{'element'} = $OpenOffice::OODoc::XPath::XMLNAMES{'content'} 509 unless $self->{'element'}; 510 if ($self->{'element'}) 511 { 512 $self->{'twig'} = XML::Twig->new 513 ( 514 elt_class => "OpenOffice::OODoc::Element", 515 twig_roots => 516 { 517 $self->{'element'} => 1 518 }, 519 pretty_print => $self->{'readable_XML'}, 520 %{$self->{'twig_options'}} 521 ); 522 } 523 else 524 { 525 $self->{'twig'} = XML::Twig->new 526 ( 527 elt_class => "OpenOffice::OODoc::Element", 528 pretty_print => $self->{'readable_XML'}, 529 %{$self->{'twig_options'}} 530 ); 531 } 532 533 # other OODoc::Xpath object 534 $self->{'container'} = $self->{'container'}->{'container'} 535 if ( 536 ref($self->{container}) 537 && 538 $self->{'container'}->isa('OpenOffice::OODoc::XPath') 539 ); 540 541 if ($self->{'xml'}) # load from XML string 542 { 543 delete $self->{'container'}; 544 delete $self->{'file'}; 545 $self->{'xpath'} = 546 $self->{'twig'}->safe_parse($self->{'xml'}); 547 delete $self->{'xml'}; 548 } 549 550 elsif (defined $self->{'container'}) 551 { 552 delete $self->{'file'}; 553 # existing OODoc::File object 554 if 555 ( 556 UNIVERSAL::isa($self->{'container'}, 557 'OpenOffice::OODoc::File') 558 ) 559 { 560 my $xml = $self->{'container'}->link($self); 561 $self->{'xpath'} = $self->{'twig'}->safe_parse($xml); 562 } 563 # source file or filehandle 564 else 565 { 566 $self->{'file'} = $self->{'container'}; 567 delete $self->{'container'}; 568 if ( 569 $self->{'flat_xml'} 570 || 571 (lc $self->{'file'}) =~ /\.xml$/ 572 ) 573 # XML flat file 574 { 575 $self->{'xpath'} = _get_flat_file($self); 576 } 577 else 578 { # new OODoc::File object 579 $self->{'container'} = _get_container($self); 580 return undef unless $self->{'container'}; 581 delete $self->{'file'}; 582 my $xml = $self->{'container'}->link($self); 583 $self->{'xpath'} = 584 $self->{'twig'}->safe_parse($xml); 585 } 586 } 587 } 588 589 unless ($self->{'xpath'}) 590 { 591 warn "[" . __PACKAGE__ . "::new] No ODF content\n"; 592 return undef; 593 } 594 # XML content loaded & parsed 595 bless $self, $class; 596 597 $self->{'opendocument'} = $self->isOpenDocument; 598 599 if ($self->{'opendocument'}) 600 { 601 $self->{'image_container'} = 'draw:frame'; 602 $self->{'image_xpath'} = '//draw:frame'; 603 $self->{'image_fpath'} = 'Pictures/'; 604 } 605 606 $self->{'member'} = $self->{'part'}; # for compatibility 607 $self->{'archive'} = $self->{'container'}; # for compatibility 608 $self->{'context'} = $self->getRoot; 609 $self->{'body'} = $self->getBody; 610 611 return $self; 612 } 613 614#------------------------------------------------------------------------------ 615# destructor 616 617sub DESTROY 618 { 619 my $self = shift; 620 621 if ($self->{'body'}) 622 { 623 $self->{'body'}->dispose(); 624 } 625 delete $self->{'body'}; 626 if ($self->{'context'}) 627 { 628 $self->{'context'}->dispose(); 629 } 630 delete $self->{'context'}; 631 if ($self->{'xpath'}) 632 { 633 $self->{'xpath'}->dispose(); 634 } 635 delete $self->{'xpath'}; 636 if ($self->{'twig'}) 637 { 638 $self->{'twig'}->dispose(); 639 } 640 delete $self->{'twig'}; 641 delete $self->{'xml'}; 642 delete $self->{'content_class'}; 643 delete $self->{'file'}; 644 delete $self->{'container'}; 645 delete $self->{'archive'}; 646 delete $self->{'part'}; 647 delete $self->{'twig_options'}; 648 $self = {}; 649 } 650 651#------------------------------------------------------------------------------ 652# get a reference to the embedded XML parser for share 653 654sub getXMLParser 655 { 656 warn "[" . __PACKAGE__ . "::getXMLParser] No longer implemented\n"; 657 return undef; 658 } 659 660#------------------------------------------------------------------------------ 661# make the changes persistent in an OpenOffice.org file 662 663sub save 664 { 665 my $self = shift; 666 my $target = shift; 667 668 my $filename = ($target) ? $target : $self->{'file'}; 669 my $archive = $self->{'container'}; 670 unless ($archive) 671 { 672 return undef if is_true($self->{'read_only'}); 673 674 if ($filename) 675 { 676 open my $fh, ">:utf8", $filename; 677 $self->exportXMLContent($fh); 678 close $fh; 679 return $filename; 680 } 681 else 682 { 683 warn "[" . __PACKAGE__ . "::save] Missing file\n"; 684 return undef; 685 } 686 } 687 $filename = $archive->{'source_file'} unless $filename; 688 unless ($filename) 689 { 690 warn "[" . __PACKAGE__ . "::save] No target file\n"; 691 return undef; 692 } 693 694 unless ($self->{'part'}) 695 { 696 warn "[" . __PACKAGE__ . "::save] Missing archive part name\n"; 697 return undef; 698 } 699 700 my $result = $archive->save($filename); 701 return $result; 702 } 703 704#------------------------------------------------------------------------------ 705# raw file import 706 707sub raw_import 708 { 709 my $self = shift; 710 if ($self->{'container'}) 711 { 712 my $target = shift; 713 unless ($target) 714 { 715 warn "[" . __PACKAGE__ . "::raw_import] " . 716 "No target member for import\n"; 717 return undef; 718 } 719 $target =~ s/^#//; 720 return $self->{'container'}->raw_import($target, @_); 721 } 722 else 723 { 724 warn "[" . __PACKAGE__ . "::raw_import] " . 725 "No container for file import\n"; 726 return undef; 727 } 728 } 729 730#------------------------------------------------------------------------------ 731# raw file export 732 733sub raw_export 734 { 735 my $self = shift; 736 if ($self->{'container'}) 737 { 738 my $source = shift; 739 unless ($source) 740 { 741 warn "[" . __PACKAGE__ . "::raw_import] " . 742 "Missing source file name\n"; 743 return undef; 744 } 745 $source =~ s/^#//; 746 return $self->{'container'}->raw_export($source, @_); 747 } 748 else 749 { 750 warn "[" . __PACKAGE__ . "::raw_import] " . 751 "No container for file export\n"; 752 return undef; 753 } 754 } 755 756#------------------------------------------------------------------------------ 757# exports the whole content of the document as an XML string 758 759sub exportXMLContent 760 { 761 my $self = shift; 762 my $target = shift; 763 if ($target) 764 { 765 return $self->{'twig'}->print($target); 766 } 767 else 768 { 769 return $self->{'twig'}->sprint; 770 } 771 } 772 773#------------------------------------------------------------------------------ 774# brute force tree reorganization 775 776sub reorganize 777 { 778 warn "[" . __PACKAGE__ . "::reorganize] No longer implemented\n"; 779 return undef; 780 } 781 782#------------------------------------------------------------------------------ 783# returns the root of the XML document 784 785sub getRoot 786 { 787 my $self = shift; 788 return $self->{'xpath'}->root; 789 } 790 791#------------------------------------------------------------------------------ 792# returns the name of the document part (content, styles, meta, ...) 793 794sub getPartName 795 { 796 my $self = shift; 797 my $name = $self->getRoot->getName; 798 $name =~ s/^office:document-//; 799 return $name; 800 } 801 802#------------------------------------------------------------------------------ 803# returns the root element of the XML document 804 805sub getRootElement 806 { 807 my $self = shift; 808 809 my $root = $self->{'xpath'}->root; 810 my $rootname = $root->name() || ''; 811 return ($rootname eq $self->{'element'}) ? 812 $root : 813 $root->first_child($self->{'element'}); 814 } 815 816#------------------------------------------------------------------------------ 817# get/set/reset the current search context 818 819sub currentContext 820 { 821 my $self = shift; 822 my $new_context = shift; 823 $self->{'context'} = $new_context if (ref $new_context); 824 return $self->{'context'}; 825 } 826 827sub resetCurrentContext 828 { 829 my $self = shift; 830 return $self->currentContext($self->getRoot); 831 } 832 833#------------------------------------------------------------------------------ 834# returns the content class (text, spreadsheet, presentation, drawing) 835 836sub contentClass 837 { 838 my $self = shift; 839 840 my $content_class = 841 $self->getRootElement->getAttribute('office:class'); 842 return $content_class if $content_class; 843 844 my $body = $self->getBody or return undef; 845 my $name = $body->name or return undef; 846 $name =~ /(.*):(.*)/; 847 return $2; 848 } 849 850#------------------------------------------------------------------------------ 851# element name check 852 853sub getRootName 854 { 855 my $self = shift; 856 return $self->getRootElement->name; 857 } 858 859#------------------------------------------------------------------------------ 860# XML part type checks 861 862sub isMeta 863 { 864 my $self = shift; 865 return ($self->getRootName() eq $XMLNAMES{'meta'}) ? 1 : undef; 866 } 867 868sub isStyles 869 { 870 my $self = shift; 871 return ($self->getRootName() eq $XMLNAMES{'styles'}) ? 1 : undef; 872 } 873 874sub isSettings 875 { 876 my $self = shift; 877 return ($self->getRootName() eq $XMLNAMES{'settings'}) ? 1 : undef; 878 } 879 880#------------------------------------------------------------------------------ 881# returns the document body element (if defined) 882 883sub getBody 884 { 885 my $self = shift; 886 887 return $self->{'body'} if ref $self->{'body'}; 888 889 my $root = $self->getRoot; 890 if ($self->{'body_path'}) 891 { 892 $self->{'body'} = $self->getElement 893 ($self->{'body_path'}, 0, $root); 894 return $self->{'body'}; 895 } 896 897 my $office_body = $self->getElement('//office:body', 0, $root); 898 899 if ($office_body) 900 { 901 $self->{'body'} = $self->{'opendocument'} ? 902 $office_body->selectChildElement 903 ('office:(text|spreadsheet|presentation|drawing)') 904 : 905 $office_body; 906 } 907 else 908 { 909 $self->{'body'} = $self->getRootElement->selectChildElement 910 ( 911 'office:(body|meta|master-styles|settings)' 912 ); 913 } 914 915 return $self->{'body'}; 916 } 917 918#------------------------------------------------------------------------------ 919# makes the current OODoc::XPath object share the same content as another one 920 921sub cloneContent 922 { 923 my $self = shift; 924 my $source = shift; 925 926 unless ($source && $source->{'xpath'}) 927 { 928 warn "[" . __PACKAGE__ . "::cloneContent] No valid source\n"; 929 return undef; 930 } 931 932 $self->{'xpath'} = $source->{'xpath'}; 933 $self->{'begin'} = $source->{'begin'}; 934 $self->{'xml'} = $source->{'xml'}; 935 $self->{'end'} = $source->{'end'}; 936 937 return $self->getRoot; 938 } 939 940#------------------------------------------------------------------------------ 941# exports an individual element as an XML string 942 943sub exportXMLElement 944 { 945 my $self = shift; 946 my $path = shift; 947 my $element = 948 (ref $path) ? $path : $self->getElement($path, shift); 949 unless (defined $element) 950 { 951 warn "[" . __PACKAGE__ . "::exportXMLElement]] " . 952 "Missing element\n"; 953 return undef; 954 } 955 return $element->sprint(@_); 956 } 957 958#------------------------------------------------------------------------------ 959# exports the document body (if defined) as an XML string 960 961sub exportXMLBody 962 { 963 my $self = shift; 964 965 return $self->exportXMLElement($self->getBody, @_); 966 } 967 968#------------------------------------------------------------------------------ 969# gets the reference of an XML element identified by path & position 970# for subsequent processing 971 972sub getElement 973 { 974 my $self = shift; 975 my $path = shift; 976 return undef unless $path; 977 if (ref $path) 978 { 979 return $path->isElementNode ? $path : undef; 980 } 981 my $pos = shift || 0; 982 my $context = shift || $self->{'context'} || $self->getRoot; 983 if (defined $pos && (($pos =~ /^\d*$/) || ($pos =~ /^[\d+-]\d+$/))) 984 { 985 my $node = $self->selectNodeByXPath($context, $path, $pos); 986 return $node && $node->isElementNode ? $node : undef; 987 } 988 else 989 { 990 warn "[" . __PACKAGE__ . "::getElement] " . 991 "Invalid node position\n"; 992 return undef; 993 } 994 } 995 996#------------------------------------------------------------------------------ 997# get the list of children (or the first child unless wantarray) matching 998# a given element name and belonging to a given element 999 1000sub selectChildElementsByName 1001 { 1002 my $self = shift; 1003 my $path = shift; 1004 my $element = ref $path ? $path : $self->getElement($path, shift); 1005 return undef unless $element; 1006 1007 return $element->selectChildElements(@_); 1008 } 1009 1010#------------------------------------------------------------------------------ 1011# get the first child belonging to a given element and matching a given name 1012 1013sub selectChildElementByName 1014 { 1015 my $self = shift; 1016 my $path = shift; 1017 my $element = ref $path ? $path : $self->getElement($path, shift); 1018 return undef unless $element; 1019 return $element->selectChildElement(@_); 1020 } 1021 1022#----------------------------------------------------------------------------- 1023# create a user field 1024 1025sub setUserFieldDeclaration 1026 { 1027 my $self = shift; 1028 my $name = shift or return undef; 1029 my %attr = 1030 ( 1031 type => 'string', 1032 value => "", 1033 @_ 1034 ); 1035 1036 return undef if $self->getUserField($name); 1037 1038 my $body = $self->getBody; 1039 my $context = $body->first_child('text:user-field-decls'); 1040 unless ($context) 1041 { 1042 $context = $self->appendElement 1043 ($body, 'text:user-field-decls'); 1044 } 1045 1046 1047 my $va = 1048 ( 1049 ($attr{'type'} eq 'float') || 1050 ($attr{'type'} eq 'currency') || 1051 ($attr{'type'} eq 'percentage') 1052 ) ? 1053 'office:value' : "office:$attr{'type'}-value" ; 1054 $attr{'office:value-type'} = $attr{'type'}; 1055 $attr{$va} = $attr{'value'}; 1056 $attr{'text:name'} = $name; 1057 $attr{'office:currency'} = $attr{'currency'}; 1058 delete @attr{qw(type value currency)}; 1059 1060 return $self->appendElement 1061 ( 1062 $context, 'text:user-field-decl', 1063 attributes => { %attr } 1064 ); 1065 } 1066 1067#----------------------------------------------------------------------------- 1068# get user field element 1069 1070sub getUserField 1071 { 1072 my $self = shift; 1073 my $name = shift; 1074 1075 unless ($name) 1076 { 1077 warn "[" . __PACKAGE__ . "::getUserField] Missing name\n"; 1078 return undef; 1079 } 1080 if (ref $name) 1081 { 1082 my $n = $name->getName; 1083 return ($n eq 'text:user-field-decl') ? $name : undef; 1084 } 1085 $name = $self->inputTextConversion($name); 1086 my $context = $self->getRoot(); 1087 if ($self->getPartName() eq 'styles') 1088 { 1089 $context = shift || $self->currentContext; 1090 } 1091 return $self->getNodeByXPath 1092 ( 1093 "//text:user-field-decl[\@text:name=\"$name\"]", 1094 $context 1095 ); 1096 } 1097 1098#----------------------------------------------------------------------------- 1099# get user field list 1100 1101sub getUserFields 1102 { 1103 my $self = shift; 1104 my $context = $self->getRoot; 1105 1106 if ($self->getPartName() eq 'styles') 1107 { 1108 $context = shift || $self->currentContext; 1109 } 1110 1111 return $self->selectNodesByXPath('//text:user-field-decl', $context); 1112 } 1113 1114#----------------------------------------------------------------------------- 1115# get/set user field value 1116 1117sub userFieldValue 1118 { 1119 my $self = shift; 1120 my $field = $self->getUserField(shift) or return undef; 1121 my $value = shift; 1122 1123 my $value_att = $self->fieldValueAttributeName($field); 1124 1125 if (defined $value) 1126 { 1127 if ($value) 1128 { 1129 $self->setAttribute($field, $value_att, $value); 1130 } 1131 else 1132 { 1133 $field->set_att($value_att => $value); 1134 } 1135 } 1136 return $self->getAttribute($field, $value_att); 1137 } 1138 1139#----------------------------------------------------------------------------- 1140# get a variable element (contributed by Andrew Layton) 1141 1142sub getVariable 1143 { 1144 my $self = shift; 1145 my $name = shift; 1146 1147 unless ($name) { 1148 warn "[" . __PACKAGE__ . "::getVariable] " . 1149 "Missing name\n"; 1150 return undef; 1151 } 1152 1153 if (ref $name) { 1154 my $n = $name->getName; 1155 return ($n eq 'text:variable-set') ? $name : undef; 1156 } 1157 1158 $name = $self->inputTextConversion($name); 1159 return $self->getNodeByXPath 1160 ("//text:variable-set[\@text:name=\"$name\"]"); 1161 } 1162 1163#----------------------------------------------------------------------------- 1164# get/set the content of a variable element (contributed by Andrew Layton) 1165 1166sub variableValue 1167 { 1168 my $self = shift; 1169 my $variable = $self->getVariable(shift) or return undef; 1170 my $value = shift; 1171 1172 my $value_att = $self->fieldValueAttributeName($variable); 1173 1174 if (defined $value) 1175 { 1176 $self->setAttribute($variable, $value_att, $value); 1177 $self->setText($variable, $value); 1178 } 1179 1180 $value = $self->getAttribute($variable, $value_att); 1181 return defined $value ? $value : $self->getText($variable); 1182 } 1183 1184#----------------------------------------------------------------------------- 1185# some usual text field constructors 1186 1187sub create_field 1188 { 1189 my $self = shift; 1190 my $tag = shift; 1191 my %opt = @_; 1192 my $prefix = $opt{'-prefix'}; 1193 delete $opt{'-prefix'}; 1194 1195 if ($prefix) 1196 { 1197 $tag = "$prefix:$tag" unless $tag =~ /:/; 1198 my %att = (); 1199 foreach my $k (keys %opt) 1200 { 1201 my $a = ($k =~ /:/) ? $k : "$prefix:$k"; 1202 $att{$a} = $opt{$k}; 1203 } 1204 %opt = %att; 1205 } 1206 my $element = OpenOffice::OODoc::Element->new($tag); 1207 $self->setAttributes($element, %opt); 1208 return $element; 1209 } 1210 1211sub spaces 1212 { 1213 my $self = shift; 1214 my $length = shift; 1215 return $self->create_field('text:s', 'text:c' => $length, @_); 1216 } 1217 1218sub tabStop 1219 { 1220 my $self = shift; 1221 my $tag = $self->{'opendocument'} ? 'text:tab' : 'text:tab-stop'; 1222 return $self->create_field($tag, @_); 1223 } 1224 1225sub lineBreak 1226 { 1227 my $self = shift; 1228 return $self->create_field('text:line-break', @_); 1229 } 1230 1231#------------------------------------------------------------------------------ 1232 1233sub appendLineBreak 1234 { 1235 my $self = shift; 1236 my $element = shift; 1237 1238 return $element->appendChild('text:line-break'); 1239 } 1240 1241#------------------------------------------------------------------------------ 1242 1243sub appendSpaces 1244 { 1245 my $self = shift; 1246 my $element = shift; 1247 my $length = shift; 1248 1249 my $spaces = $self->spaces($length) or return undef; 1250 $spaces->paste_last_child($element); 1251 } 1252 1253#------------------------------------------------------------------------------ 1254# multiple whitespace handling routine, contributed by J David Eisenberg 1255 1256sub processSpaces 1257 { 1258 my $self = shift; 1259 my $element = shift; 1260 my $str = shift; 1261 my @words = split(/(\s\s+)/, $str); 1262 foreach my $word (@words) 1263 { 1264 if ($word =~ m/^ +$/) 1265 { 1266 $self->appendSpaces($element, length($word)); 1267 } 1268 elsif (length($word) > 0) 1269 { 1270 $element->appendTextChild($word); 1271 } 1272 } 1273 } 1274 1275#------------------------------------------------------------------------------ 1276 1277sub appendTabStop 1278 { 1279 my $self = shift; 1280 my $element = shift; 1281 1282 my $tabtag = $self->{'opendocument'} ? 'text:tab' : 'text:tab-stop'; 1283 1284 return $element->appendChild($tabtag); 1285 } 1286 1287#------------------------------------------------------------------------------ 1288 1289sub createFrameElement 1290 { 1291 my $self = shift; 1292 my %opt = @_; 1293 my %attr = (); 1294 1295 $attr{'draw:name'} = $opt{'name'}; delete $opt{'name'}; 1296 1297 my $content_class = $self->contentClass; 1298 1299 $attr{'draw:style-name'} = $opt{'style'}; delete $opt{'style'}; 1300 if ($opt{'page'}) 1301 { 1302 my $pg = $opt{'page'}; 1303 if (ref $pg) 1304 { 1305 $opt{'attachment'} = $pg unless $opt{'attachment'}; 1306 } 1307 elsif ($content_class eq 'text') 1308 { 1309 $opt{'attachment'} = $self->{'body'}; 1310 $attr{'text:anchor-type'} = 'page'; 1311 $attr{'text:anchor-page-number'} = $pg; 1312 } 1313 elsif ( 1314 ($content_class eq 'presentation') 1315 or 1316 ($content_class eq 'drawing') 1317 ) 1318 { 1319 my $n = $self->inputTextConversion($pg); 1320 $opt{'attachment'} = $self->getNodeByXPath 1321 ("//draw:page[\@draw:name=\"$n\"]"); 1322 } 1323 } 1324 delete $opt{'page'}; 1325 1326 my $tag = $opt{'tag'} || 'draw:frame'; delete $opt{'tag'}; 1327 1328 my $frame = OpenOffice::OODoc::XPath::new_element($tag); 1329 1330 if ($opt{'position'}) 1331 { 1332 $self->setObjectCoordinates($frame, $opt{'position'}); 1333 delete $opt{'position'}; 1334 } 1335 if ($opt{'size'}) 1336 { 1337 $self->setObjectSize($frame, $opt{'size'}); 1338 delete $opt{'size'}; 1339 } 1340 if ($opt{'description'}) 1341 { 1342 $self->setObjectDescription($frame, $opt{'description'}); 1343 delete $opt{'description'}; 1344 } 1345 if ($opt{'attachment'}) 1346 { 1347 $frame->paste_first_child($opt{'attachment'}); 1348 delete $opt{'attachment'}; 1349 } 1350 1351 foreach my $k (keys %opt) 1352 { 1353 $attr{$k} = $opt{$k} if ($k =~ /:/); 1354 } 1355 $self->setAttributes($frame, %attr); 1356 1357 return $frame; 1358 } 1359 1360sub createFrame 1361 { 1362 my $self = shift; 1363 return $self->createFrameElement(@_); 1364 } 1365 1366#----------------------------------------------------------------------------- 1367# select an individual frame element by name 1368 1369sub selectFrameElementByName 1370 { 1371 my $self = shift; 1372 my $text = $self->inputTextConversion(shift); 1373 my $tag = shift || 'draw:frame'; 1374 return $self->selectNodeByXPath 1375 ("//$tag\[\@draw:name=\"$text\"\]", @_); 1376 } 1377 1378#----------------------------------------------------------------------------- 1379# gets frame element (name or ref, with type checking) 1380 1381sub getFrameElement 1382 { 1383 my $self = shift; 1384 my $frame = shift; 1385 return undef unless defined $frame; 1386 my $tag = shift || 'draw:frame'; 1387 1388 my $element = undef; 1389 if (ref $frame) 1390 { 1391 $element = $frame; 1392 } 1393 else 1394 { 1395 if ($frame =~ /^[\-0-9]*$/) 1396 { 1397 return $self->getElement("//$tag", $frame, @_); 1398 } 1399 else 1400 { 1401 return $self->selectFrameElementByName 1402 ($frame, $tag, @_); 1403 } 1404 } 1405 } 1406 1407#------------------------------------------------------------------------------ 1408 1409sub getFrameList 1410 { 1411 my $self = shift; 1412 return $self->getDescendants('draw:frame', shift); 1413 } 1414 1415#------------------------------------------------------------------------------ 1416 1417sub frameStyle 1418 { 1419 my $self = shift; 1420 my $frame = $self->getFrameElement(shift) or return undef; 1421 my $style = shift; 1422 my $attr = 'draw:style-name'; 1423 return (defined $style) ? 1424 $self->setAttribute($frame, $attr => shift) : 1425 $self->getAttribute($frame, $attr); 1426 } 1427 1428#------------------------------------------------------------------------------ 1429# replaces any previous content of an existing element by a given text 1430# without processing other than encoding 1431 1432sub setFlatText 1433 { 1434 my $self = shift; 1435 my $path = shift; 1436 my $element = ref $path ? 1437 $path : 1438 $self->OpenOffice::OODoc::XPath::getElement 1439 ($path, shift); 1440 return undef unless $element; 1441 my $text = shift; 1442 1443 my $t = $self->inputTextConversion($text); 1444 return undef unless defined $t; 1445 1446 $element->set_text($t); 1447 return $text; 1448 } 1449 1450#------------------------------------------------------------------------------ 1451# replaces any previous content of an existing element by a given text 1452# processing tab stops and line breaks 1453 1454sub setText 1455 { 1456 my $self = shift; 1457 my $path = shift; 1458 my $element = ref $path ? 1459 $path : 1460 $self->OpenOffice::OODoc::XPath::getElement 1461 ($path, shift); 1462 return undef unless $element; 1463 1464 my $text = shift; 1465 return undef unless defined $text; 1466 1467 unless ($text) 1468 { 1469 $element->set_text($text); return $text; 1470 } 1471 return $self->setFlatText($element, $text) if $element->isTextNode; 1472 1473 my $tabtag = $self->{'opendocument'} ? 'text:tab' : 'text:tab-stop'; 1474 $element->set_text(""); 1475 my @lines = split "\n", $text; 1476 while (@lines) 1477 { 1478 my $line = shift @lines; 1479 my @columns = split "\t", $line; 1480 while (@columns) 1481 { 1482 my $column = 1483 $self->inputTextConversion(shift @columns); 1484 unless ($self->{'multiple_spaces'}) 1485 { 1486 $element->appendTextChild($column); 1487 } 1488 else 1489 { 1490 $self->processSpaces($element, $column); 1491 } 1492 $element->appendChild($tabtag) if (@columns); 1493 } 1494 $element->appendChild('text:line-break') if (@lines); 1495 } 1496 $element->normalize; 1497 return $text; 1498 } 1499 1500#------------------------------------------------------------------------------ 1501# extends the text of an existing element 1502 1503sub extendText 1504 { 1505 my $self = shift; 1506 my $path = shift; 1507 my $pos = (ref $path) ? undef : shift; 1508 my $text = shift; 1509 1510 return undef unless defined $text; 1511 1512 my $element = $self->getElement($path, $pos); 1513 return undef unless $element; 1514 1515 my $offset = shift; 1516 1517 if (ref $text) 1518 { 1519 if ($text->isElementNode) 1520 { 1521 unless (defined $offset) 1522 { 1523 $text->paste_last_child($element); 1524 } 1525 else 1526 { 1527 $text->paste_within($element, $offset); 1528 } 1529 } 1530 return $text; 1531 } 1532 1533 my $tabtag = $self->{'opendocument'} ? 'text:tab' : 'text:tab-stop'; 1534 my @lines = split "\n", $text; 1535 my $ref_node = undef; 1536 while (@lines) 1537 { 1538 my $line = shift @lines; 1539 my @columns = split "\t", $line; 1540 while (@columns) 1541 { 1542 my $column = 1543 $self->inputTextConversion(shift @columns); 1544 unless ($ref_node) 1545 { 1546 $ref_node = $element->insertTextChild 1547 ($column, $offset); 1548 $ref_node = $ref_node->insertNewNode 1549 ($tabtag, 'after') 1550 if (@columns); 1551 } 1552 else 1553 { 1554 my $tn = $self->createTextNode($column); 1555 $ref_node = $ref_node->insertNewNode 1556 ($tn, 'after'); 1557 $ref_node = $ref_node->insertNewNode 1558 ($tabtag, 'after') 1559 if (@columns); 1560 } 1561 } 1562 if (@lines) 1563 { 1564 if ($ref_node) 1565 { 1566 $ref_node->insertNewNode 1567 ('text:line-break', 'after'); 1568 } 1569 else 1570 { 1571 $element->insertNewNode 1572 ( 1573 'text:line-break', 1574 'within', 1575 $offset 1576 ); 1577 } 1578 } 1579 } 1580 1581 $element->normalize; 1582 return $text; 1583 } 1584 1585#------------------------------------------------------------------------------ 1586# converts the content of an element to flat text 1587 1588sub flatten 1589 { 1590 my $self = shift; 1591 my $element = shift || $self->{'context'}; 1592 return $element->flatten; 1593 } 1594 1595#------------------------------------------------------------------------------ 1596# creates a new encoded text node 1597 1598sub newTextNode 1599 { 1600 my $self = shift; 1601 my $text = $self->inputTextConversion(shift) 1602 or return undef; 1603 return OpenOffice::OODoc::Element->new('#PCDATA' => $text); 1604 } 1605 1606#------------------------------------------------------------------------------ 1607# gets decoded text without other processing 1608 1609sub getFlatText 1610 { 1611 my $self = shift; 1612 my $path = shift; 1613 my $element = ref $path ? 1614 $path : 1615 $self->OpenOffice::OODoc::XPath::getElement 1616 ($path, @_); 1617 return undef unless $element; 1618 1619 return $self->outputTextConversion($element->text); 1620 } 1621 1622#------------------------------------------------------------------------------ 1623# gets text in element by path (sub-element texts are concatenated) 1624 1625sub getText 1626 { 1627 my $self = shift; 1628 my $path = shift; 1629 my $element = ref $path ? 1630 $path : 1631 $self->OpenOffice::OODoc::XPath::getElement 1632 ($path, @_); 1633 return undef unless $element; 1634 return $self->getFlatText($element) if $element->isTextNode; 1635 return undef unless $element->isElementNode; 1636 1637 my $text = ''; 1638 1639 my $name = $element->getName; 1640 1641 if ($name =~ /^text:tab(|-stop)$/) { return "\t"; } 1642 if ($name eq 'text:line-break') { return "\n"; } 1643 if ($name eq 'text:s') 1644 { 1645 my $spaces = ""; 1646 my $count = $element->att('text:c') || 1; 1647 while ($count > 0) { $spaces .= ' '; $count--; } 1648 return $spaces; 1649 } 1650 foreach my $node ($element->getChildNodes) 1651 { 1652 if ($node->isElementNode) 1653 { 1654 $text .= $self->getText($node); 1655 } 1656 else 1657 { 1658 $text .= $self->outputTextConversion($node->text); 1659 } 1660 } 1661 return $text; 1662 } 1663 1664#------------------------------------------------------------------------------ 1665 1666sub xpathInContext 1667 { 1668 my $self = shift; 1669 my $path = shift || "/"; 1670 my $context = shift || $self->{'context'}; 1671 if ($context ne $self->{'xpath'}) 1672 { 1673 $path =~ s/^\//\.\//; 1674 } 1675 return ($path, $context); 1676 } 1677 1678#------------------------------------------------------------------------------ 1679 1680sub getDescendants 1681 { 1682 my $self = shift; 1683 my $tag = shift; 1684 my $context = shift || $self->{'context'}; 1685 return $context->descendants($tag, @_); 1686 } 1687 1688#------------------------------------------------------------------------------ 1689 1690sub getTextNodes 1691 { 1692 my $self = shift; 1693 my $path = shift; 1694 my $element = ref $path ? $path : $self->getElement($path, shift) 1695 or return undef; 1696 my $filter = $self->inputTextConversion(shift); 1697 return $element->getTextDescendants($filter); 1698 } 1699 1700#------------------------------------------------------------------------------ 1701# brute XPath nodelist selection; allows any XML::XPath expression 1702 1703sub selectNodesByXPath 1704 { 1705 my $self = shift; 1706 my ($p1, $p2) = @_; 1707 my $path = undef; 1708 my $context = undef; 1709 if (ref $p1) { $context = $p1; $path = $p2; } 1710 else { $path = $p1; $context = $p2; } 1711 ($path, $context) = $self->xpathInContext($path, $context); 1712 unless (ref $context) 1713 { 1714 warn "[" . __PACKAGE__ . "::selectNodesByXPath] " . 1715 "Bad context argument\n"; 1716 return undef; 1717 } 1718 return $context->get_xpath($path); 1719 } 1720 1721#------------------------------------------------------------------------------ 1722# like selectNodesByXPath, without variable context (direct XML::Twig method) 1723 1724sub get_xpath 1725 { 1726 my $self = shift; 1727 return $self->{'xpath'}->get_xpath(@_); 1728 } 1729 1730#------------------------------------------------------------------------------ 1731# brute XPath single node selection; allows any XML::XPath expression 1732 1733sub selectNodeByXPath 1734 { 1735 my $self = shift; 1736 my $p1 = shift; 1737 my $p2 = shift; 1738 my $offset = shift || 0; 1739 my $path = undef; 1740 my $context = undef; 1741 if (ref $p1) { $context = $p1; $path = $p2; } 1742 else { $path = $p1; $context = $p2; } 1743 ($path, $context) = $self->xpathInContext($path, $context); 1744 unless (ref $context) 1745 { 1746 warn "[" . __PACKAGE__ . "::selectNodeByXPath] " . 1747 "Bad context argument\n"; 1748 return undef; 1749 } 1750 1751 return $context->get_xpath($path, $offset); 1752 } 1753 1754#------------------------------------------------------------------------------ 1755# brute XPath value extraction; allows any XML::XPath expression 1756 1757sub getXPathValue 1758 { 1759 my $self = shift; 1760 my ($p1, $p2) = @_; 1761 my $path = undef; 1762 my $context = undef; 1763 if (ref $p1) { $context = $p1; $path = $p2; } 1764 else { $path = $p1; $context = $p2; } 1765 ($path, $context) = $self->xpathInContext($path, $context); 1766 unless (ref $context) 1767 { 1768 warn "[" . __PACKAGE__ . "::getXPathValue] " . 1769 "Bad context argument\n"; 1770 return undef; 1771 } 1772 return $self->outputTextConversion($context->findvalue($path, @_)); 1773 } 1774 1775#------------------------------------------------------------------------------ 1776# create or update an xpath 1777 1778sub makeXPath 1779 { 1780 my $self = shift; 1781 my $path = shift; 1782 my $root = undef; 1783 if (ref $path) 1784 { 1785 $root = $path; 1786 $path = shift; 1787 } 1788 else 1789 { 1790 $root = $self->getRoot; 1791 } 1792 $path =~ s/^[\/ ]*//; $path =~ s/[\/ ]*$//; 1793 my @list = split '/', $path; 1794 my $posnode = $root; 1795 while (@list) 1796 { 1797 my $item = shift @list; 1798 while (($item =~ /\[.*/) && !($item =~ /\[.*\]/)) 1799 { 1800 my $cont = shift @list or last; 1801 $item .= ('/' . $cont); 1802 } 1803 next unless $item; 1804 my $node = undef; 1805 my $name = undef; 1806 my $param = undef; 1807 $item =~ s/\[(.*)\] *//; 1808 $param = $1; 1809 $name = $item; $name =~ s/^ *//; $name =~ s/ *$//; 1810 my %attributes = (); 1811 my $text = undef; 1812 my $indice = undef; 1813 if ($param) 1814 { 1815 my @attrlist = []; 1816 $indice = undef; 1817 $param =~ s/^ *//; $param =~ s/ *$//; 1818 $param =~ s/^@//; 1819 @attrlist = split /@/, $param; 1820 foreach my $a (@attrlist) 1821 { 1822 next unless $a; 1823 $a =~ s/^ *//; 1824 my $tmp = $a; 1825 $tmp =~ s/ *$//; 1826 if ($tmp =~ /^\d*$/) 1827 { 1828 $indice = $tmp; 1829 next; 1830 } 1831 if ($a =~ s/^\"(.*)\".*/$1/) 1832 { 1833 $text = $1; next; 1834 } 1835 if ($a =~ /^=/) 1836 { 1837 $a =~ s/^=//; 1838 $a =~ '^"(.*)"$'; 1839 $text = $1 ? $1 : $a; 1840 next; 1841 } 1842 $a =~ s/^@//; 1843 my ($attname, $attvalue) = split '=', $a; 1844 next unless $attname; 1845 if ($attvalue) 1846 { 1847 $attvalue =~ '"(.*)"'; 1848 $attvalue = $1 if $1; 1849 } 1850 $attname =~ s/^ *//; $attname =~ s/ *$//; 1851 $attributes{$attname} = $attvalue; 1852 } 1853 } 1854 if (defined $indice) 1855 { 1856 $node = $self->getNodeByXPath 1857 ($posnode, "$name\[$indice\]"); 1858 } 1859 else 1860 { 1861 $node = 1862 $self->getChildElementByName($posnode, $name); 1863 } 1864 if ($node) 1865 { 1866 $self->setAttributes($node, %attributes); 1867 $self->setText($node, $text) if (defined $text); 1868 } 1869 else 1870 { 1871 $node = $self->appendElement 1872 ( 1873 $posnode, $name, 1874 text => $text, 1875 attributes => {%attributes} 1876 ); 1877 } 1878 if ($node) { $posnode = $node; } 1879 else { return undef; } 1880 } 1881 return $posnode; 1882 } 1883 1884#------------------------------------------------------------------------------ 1885# selects element by path and attribute 1886 1887sub selectElementByAttribute 1888 { 1889 my $self = shift; 1890 my $path = shift or return undef; 1891 my $key = shift or return undef; 1892 my $arg3 = shift; 1893 1894 my $xp = undef; 1895 if (defined $arg3 && ! ref $arg3) # arg3 = value 1896 { 1897 my $value = $self->inputTextConversion($arg3); 1898 $xp = "//$path\[\@$key=\"$value\"\]"; 1899 } 1900 else # arg3 = undef or context 1901 { 1902 $xp = "//$path\[\@$key\]" ; unshift @_, $arg3; 1903 } 1904 1905 return $self->selectNodeByXPath($xp, @_); 1906 } 1907 1908#------------------------------------------------------------------------------ 1909 1910sub selectElementByIdentifier 1911 { 1912 my $self = shift; 1913 1914 return $self->selectElementByAttribute(shift, $ELT_ID, @_); 1915 } 1916 1917#------------------------------------------------------------------------------ 1918# selects list of elements by path and attribute 1919 1920sub selectElementsByAttribute 1921 { 1922 my $self = shift; 1923 my $path = shift or return undef; 1924 my $key = shift or return undef; 1925 my $arg3 = shift; 1926 1927 my $xp = undef; 1928 if (defined $arg3 && ! ref $arg3) # arg3 = value 1929 { 1930 my $value = $self->inputTextConversion($arg3); 1931 $xp = "//$path\[\@$key=\"$value\"\]"; 1932 } 1933 else # arg3 = undef or context 1934 { 1935 $xp = "//$path\[\@$key\]" ; unshift @_, $arg3; 1936 } 1937 1938 1939 return wantarray ? $self->selectNodesByXPath($xp, @_) : 1940 $self->selectNodeByXPath($xp, @_); 1941 } 1942 1943#------------------------------------------------------------------------------ 1944# get a list of elements matching a given path and an optional content pattern 1945 1946sub findElementList 1947 { 1948 my $self = shift; 1949 my $path = shift; 1950 my $pattern = shift; 1951 my $replace = shift; 1952 my $context = shift; 1953 1954 return undef unless $path; 1955 1956 my @result = (); 1957 1958 ($path, $context) = $self->xpathInContext($path, $context); 1959 foreach my $n ($context->findnodes($path)) 1960 { 1961 push @result, 1962 [ $self->findDescendants($n, $pattern, $replace, @_) ]; 1963 } 1964 1965 return @result; 1966 } 1967 1968#------------------------------------------------------------------------------ 1969# get a list of elements matching a given path and an optional content pattern 1970# without replacement operation, and from an optional context node 1971 1972sub selectElements 1973 { 1974 my $self = shift; 1975 my $path = shift; 1976 my $context = $self->{'context'}; 1977 if (ref $path) 1978 { 1979 $context = $path; 1980 $path = shift; 1981 } 1982 my $filter = shift; 1983 1984 my @candidates = $self->selectNodesByXPath($context, $path); 1985 return @candidates unless $filter; 1986 1987 my @result = (); 1988 while (@candidates) 1989 { 1990 my $node = shift @candidates; 1991 push @result, $node 1992 if $self->_search_content($node, $filter, @_, $node); 1993 } 1994 return @result; 1995 } 1996 1997#------------------------------------------------------------------------------ 1998# get the 1st element matching a given path and on optional content pattern 1999 2000sub selectElement 2001 { 2002 my $self = shift; 2003 my $path = shift; 2004 my $context = $self->{'context'}; 2005 if (ref $path) 2006 { 2007 $context = $path; 2008 $path = shift; 2009 } 2010 return undef unless $path; 2011 my $filter = shift; 2012 2013 my @candidates = $self->selectNodesByXPath($context, $path); 2014 return $candidates[0] unless $filter; 2015 2016 while (@candidates) 2017 { 2018 my $node = shift @candidates; 2019 return $node 2020 if $self->_search_content($node, $filter, @_, $node); 2021 } 2022 return undef; 2023 } 2024 2025#------------------------------------------------------------------------------ 2026# gets the descendants of a given node, with optional in fly search/replacement 2027 2028sub findDescendants 2029 { 2030 my $self = shift; 2031 my $node = shift; 2032 my $pattern = shift; 2033 my $replace = shift; 2034 2035 my @result = (); 2036 2037 my $n = $self->selectNodeByContent($node, $pattern, $replace, @_); 2038 push @result, $n if $n; 2039 foreach my $m ($node->getChildNodes) 2040 { 2041 push @result, 2042 [ $self->findDescendants($m, $pattern, $replace, @_) ]; 2043 } 2044 2045 return @result; 2046 } 2047 2048#------------------------------------------------------------------------------ 2049# search & replace text in an individual node 2050 2051sub selectNodeByContent 2052 { 2053 my $self = shift; 2054 my $node = shift; 2055 my $pattern = shift; 2056 my $replace = shift; 2057 2058 return $node unless $pattern; 2059 my $l = $node->text; 2060 2061 return undef unless $l; 2062 2063 unless (defined $replace) 2064 { 2065 return ($l =~ /$pattern/) ? $node : undef; 2066 } 2067 else 2068 { 2069 if (ref $replace) 2070 { 2071 unless 2072 ($l =~ s/($pattern)/&$replace(@_, $node, $1)/eg) 2073 { 2074 return undef; 2075 } 2076 } 2077 else 2078 { 2079 unless ($l =~ s/$pattern/$replace/g) 2080 { 2081 return undef; 2082 } 2083 } 2084 $node->set_text($l); 2085 return $node; 2086 } 2087 } 2088 2089#------------------------------------------------------------------------------ 2090# gets the text content of a nodelist 2091 2092sub getTextList 2093 { 2094 my $self = shift; 2095 my $path = shift; 2096 my $pattern = shift; 2097 my $context = shift; 2098 2099 return undef unless $path; 2100 2101 ($path, $context) = $self->xpathInContext($path, $context); 2102 my @nodelist = $context->findnodes($path); 2103 my @text = (); 2104 2105 foreach my $n (@nodelist) 2106 { 2107 my $l = $self->outputTextConversion($n->string_value); 2108 push @text, $l if ((! defined $pattern) || ($l =~ /$pattern/)); 2109 } 2110 2111 return wantarray ? @text : join "\n", @text; 2112 } 2113 2114#------------------------------------------------------------------------------ 2115# gets the attributes of an element in the key => value form 2116 2117sub getAttributes 2118 { 2119 my $self = shift; 2120 my $path = shift; 2121 my $pos = (ref $path) ? undef : shift; 2122 2123 my $node = $self->getElement($path, $pos, @_); 2124 return undef unless $path; 2125 2126 my %attributes = (); 2127 my $aa = $node->atts(@_); 2128 my %atts = %{$aa} if $aa; 2129 foreach my $a (keys %atts) 2130 { 2131 $attributes{$a} = $self->outputTextConversion($atts{$a}); 2132 } 2133 2134 return %attributes; 2135 } 2136 2137#------------------------------------------------------------------------------ 2138# gets the value of an attribute by path + name 2139 2140sub getAttribute 2141 { 2142 my $self = shift; 2143 my $path = shift; 2144 my $pos = (ref $path) ? undef : shift; 2145 my $name = shift or return undef; 2146 2147 my $node = $self->getElement($path, $pos, @_); 2148 unless ($name =~ /:/) 2149 { 2150 my $prefix = $node->ns_prefix; 2151 $name = $prefix . ':' . $name if $prefix; 2152 } 2153 $name =~ s/ /-/g; 2154 return $self->outputTextConversion($node->att($name)); 2155 } 2156 2157#------------------------------------------------------------------------------ 2158# set/replace a list of attributes in an element 2159 2160sub setAttributes 2161 { 2162 my $self = shift; 2163 my $path = shift; 2164 my $pos = (ref $path) ? undef : shift; 2165 my %attr = @_; 2166 2167 my $node = $self->getElement($path, $pos, $attr{'context'}); 2168 return undef unless $node; 2169 my $prefix = $node->ns_prefix(); 2170 2171 foreach my $k (keys %attr) 2172 { 2173 my $att_name = $k; 2174 $att_name =~ s/ /-/g; 2175 if (!($k =~ /:/) && $prefix) 2176 { 2177 $att_name = $prefix . ':' . $att_name; 2178 } 2179 if (defined $attr{$k}) 2180 { 2181 $node->set_att 2182 ( 2183 $att_name, 2184 $self->inputTextConversion($attr{$k}) 2185 ); 2186 } 2187 else 2188 { 2189 $node->del_att($att_name) if $node->att($att_name); 2190 } 2191 } 2192 2193 return %attr; 2194 } 2195 2196#------------------------------------------------------------------------------ 2197# set/replace a single attribute in an element 2198 2199sub setAttribute 2200 { 2201 my $self = shift; 2202 my $path = shift; 2203 my $pos = (ref $path) ? undef : shift; 2204 2205 my $attribute = shift or return undef; 2206 my $value = shift; 2207 my $node = $self->getElement($path, $pos, @_) 2208 or return undef; 2209 2210 $attribute =~ s/ /-/g; 2211 unless ($attribute =~ /:/) 2212 { 2213 my $prefix = $node->ns_prefix; 2214 $attribute = $prefix . ':' . $attribute if $prefix; 2215 } 2216 if (defined $value) 2217 { 2218 $node->set_att 2219 ( 2220 $attribute, 2221 $self->inputTextConversion($value) 2222 ); 2223 } 2224 else 2225 { 2226 $node->del_att($attribute) if $node->att($attribute); 2227 } 2228 2229 return $value; 2230 } 2231 2232#------------------------------------------------------------------------------ 2233# removes an attribute in element 2234 2235sub removeAttribute 2236 { 2237 my $self = shift; 2238 my $path = shift; 2239 my $pos = (ref $path) ? undef : shift; 2240 my $name = shift or return undef; 2241 2242 my $node = $self->getElement($path, $pos, @_) 2243 or return undef; 2244 2245 unless ($name =~ /:/) 2246 { 2247 my $prefix = $node->ns_prefix; 2248 $name = $prefix . ':' . $name if $prefix; 2249 } 2250 return $node->del_att($name) if $node->att($name); 2251 } 2252 2253#------------------------------------------------------------------------------ 2254# replicates an existing element, provided as an XPath ref or an XML string 2255 2256sub replicateElement 2257 { 2258 my $self = shift; 2259 my $proto = shift; 2260 my $position = shift; 2261 my %options = @_; 2262 2263 unless ($proto && ref $proto && $proto->isElementNode) 2264 { 2265 warn "[" . __PACKAGE__ . "::replicateElement] No prototype\n"; 2266 return undef; 2267 } 2268 2269 $position = 'end' unless $position; 2270 2271 my $element = $proto->copy; 2272 $self->setAttributes($element, %{$options{'attribute'}}); 2273 2274 if (ref $position) 2275 { 2276 if (! $options{'position'}) 2277 { 2278 $element->paste_last_child($position); 2279 } 2280 elsif ($options{'position'} eq 'before') 2281 { 2282 $element->paste_before($position); 2283 } 2284 elsif ($options{'position'} eq 'after') 2285 { 2286 $element->paste_after($position); 2287 } 2288 elsif ($options{'position'} ne 'free') 2289 { 2290 warn "[" . __PACKAGE__ . "::replicateElement] " . 2291 "No valid attachment option\n"; 2292 } 2293 } 2294 elsif ($position eq 'end') 2295 { 2296 $element->paste_last_child($self->{'xpath'}->root); 2297 } 2298 elsif ($position eq 'body') 2299 { 2300 $element->paste_last_child($self->getBody); 2301 } 2302 2303 return $element; 2304 } 2305 2306#------------------------------------------------------------------------------ 2307# create an element, just with a mandatory name and an optional text 2308# the name can have the namespace:name form 2309# if the $name argument is a '<.*>' string, it's processed as XML and 2310# the new element is completely generated from it 2311 2312sub createElement 2313 { 2314 my $self = shift; 2315 my $name = shift; 2316 my $text = shift; 2317 2318 my $element = OpenOffice::OODoc::XPath::new_element($name, @_); 2319 unless ($element) 2320 { 2321 warn "[" . __PACKAGE__ . "::createElement] " . 2322 "Element creation failure\n"; 2323 return undef; 2324 } 2325 2326 $self->setText($element, $text) if defined $text; 2327 2328 return $element; 2329 } 2330 2331#------------------------------------------------------------------------------ 2332# replaces an element by another one 2333# the new element is inserted before the old one, 2334# then the old element is removed. 2335# the new element can be inserted by copy (default) or by reference 2336# return = new element if success, undef if failure 2337 2338sub replaceElement 2339 { 2340 my $self = shift; 2341 my $path = shift; 2342 my $pos = (ref $path) ? undef : shift; 2343 my $new_element = shift; 2344 my %options = 2345 ( 2346 mode => 'copy', 2347 @_ 2348 ); 2349 unless ($new_element) 2350 { 2351 warn "[" . __PACKAGE__ . "::replaceElement] " . 2352 "Missing new element\n"; 2353 return undef; 2354 } 2355 unless (ref $new_element) 2356 { 2357 $new_element = $self->createElement($new_element); 2358 $options{'mode'} = 'reference'; 2359 } 2360 unless ($new_element && $new_element->isElementNode) 2361 { 2362 warn "[" . __PACKAGE__ . "::replaceElement] " . 2363 "No valid replacement\n"; 2364 return undef; 2365 } 2366 2367 my $result = undef; 2368 2369 my $old_element = $self->getElement 2370 ($path, $pos, $options{'context'}); 2371 unless ($old_element) 2372 { 2373 warn "[" . __PACKAGE__ . "::replaceElement] " . 2374 "Non existing element to be replaced\n"; 2375 return undef; 2376 } 2377 if (! $options{'mode'} || $options{'mode'} eq 'copy') 2378 { 2379 $result = $new_element->copy; 2380 $result->replace($old_element); 2381 return $result; 2382 } 2383 elsif ($options{'mode'} && $options{'mode'} eq 'reference') 2384 { 2385 $result = $self->insertElement 2386 ( 2387 $old_element, 2388 $new_element, 2389 position => 'before' 2390 ); 2391 $old_element->delete; 2392 return $result; 2393 } 2394 else 2395 { 2396 warn "[" . __PACKAGE__ . "::replaceElement] " . 2397 "Unknown option\n"; 2398 } 2399 return undef; 2400 } 2401 2402#------------------------------------------------------------------------------ 2403# appends a new or existing child element to any existing element 2404 2405sub appendElement 2406 { 2407 my $self = shift; 2408 my $path = shift; 2409 my $pos = (ref $path) ? undef : shift; 2410 my $name = shift; 2411 my %opt = @_; 2412 $opt{'attribute'} = $opt{'attributes'} unless ($opt{'attribute'}); 2413 2414 return undef unless $name; 2415 my $element = undef; 2416 2417 unless (ref $name) 2418 { 2419 $element = $self->createElement($name, $opt{'text'}); 2420 } 2421 else 2422 { 2423 $element = $name; 2424 $self->setText($element, $opt{'text'}) if $opt{'text'}; 2425 } 2426 return undef unless $element; 2427 my $parent = $self->getElement 2428 ($path, $pos, $opt{'context'}); 2429 unless ($parent) 2430 { 2431 warn "[" . __PACKAGE__ . 2432 "::appendElement] Position not found\n"; 2433 return undef; 2434 } 2435 $element->paste_last_child($parent); 2436 $self->setAttributes($element, %{$opt{'attribute'}}); 2437 2438 return $element; 2439 } 2440 2441#----------------------------------------------------------------------------- 2442# append an element to the document body 2443 2444sub appendBodyElement 2445 { 2446 my $self = shift; 2447 2448 return $self->appendElement($self->{'body'}, @_); 2449 } 2450 2451#------------------------------------------------------------------------------ 2452# appends a list of children to an existing element 2453 2454sub appendElements 2455 { 2456 my $self = shift; 2457 my $path = shift; 2458 my $pos = (ref $path) ? undef : shift; 2459 my $parent = $self->getElement($path, $pos) or return undef; 2460 my @children = @_; 2461 foreach my $child (@children) 2462 { 2463 $parent->appendChild($child); 2464 } 2465 return $parent; 2466 } 2467 2468#------------------------------------------------------------------------------ 2469# cuts a set of existing elements and pastes them as children of a given one 2470 2471sub moveElements 2472 { 2473 my $self = shift; 2474 my $path = shift; 2475 my $pos = (ref $path) ? undef : shift; 2476 my $parent = $self->getElement($path, $pos) or return undef; 2477 $parent->pickUpChildren(@_); 2478 return $parent; 2479 } 2480 2481#------------------------------------------------------------------------------ 2482# selects a text node in a given element according to offset & expression 2483 2484sub textIndex 2485 { 2486 my $self = shift; 2487 my $path = shift; 2488 my $element = (ref $path) ? $path : $self->getElement($path, shift) 2489 or return undef; 2490 my %opt = @_; 2491 2492 my $offset = $opt{'offset'}; 2493 my $way = $opt{'way'} || 'forward'; 2494 if (defined $offset && $offset < 0) 2495 { 2496 $way = 'backward'; 2497 } 2498 $offset = -abs($offset) if defined $offset && $way eq 'backward'; 2499 2500 my $start_mark = $opt{'start_mark'}; 2501 my $end_mark = $opt{'end_mark'}; 2502 2503 my $expr = undef; 2504 if (defined $opt{'after'}) 2505 { 2506 $expr = $opt{'after'}; 2507 delete @opt{qw(before replace capture content)}; 2508 } 2509 elsif (defined $opt{'before'}) 2510 { 2511 $expr = $opt{'before'}; 2512 delete @opt{qw(replace capture content)}; 2513 } 2514 else 2515 { 2516 $expr = $opt{'content'} || $opt{'replace'} || $opt{'capture'}; 2517 } 2518 $expr = $self->inputTextConversion($expr); 2519 2520 my $node = undef; 2521 my $node_text = undef; 2522 my $node_length = undef; 2523 my $found = undef; 2524 my $end_pos = undef; 2525 my $match = undef; 2526 2527 if ($way ne 'backward') # positive offset, forward 2528 { 2529 if ($element->isTextNode) 2530 { 2531 $node = $element; 2532 } 2533 elsif ($start_mark) 2534 { 2535 unless($start_mark->isTextNode) 2536 { 2537 my $n = $start_mark->last_descendant; 2538 $start_mark = $n if $n; 2539 $node = $n->next_elt($element, '#PCDATA'); 2540 } 2541 else 2542 { 2543 $node = $start_mark; 2544 } 2545 } 2546 else 2547 { 2548 $node = $element->first_descendant('#PCDATA'); 2549 } 2550 if ($end_mark && ! $node->before($end_mark)) 2551 { 2552 $node = undef; 2553 } 2554 ($node_length, $node_text) = $node->textLength if $node; 2555 FORWARD_LOOP: while ($node && !defined $found) 2556 { 2557 if ($end_mark && ! $node->before($end_mark)) 2558 { 2559 $node = undef; 2560 last; 2561 } 2562 if (defined $offset && ($offset > $node_length)) 2563 { # skip node 2564 $offset -= $node_length; 2565 $node = $node->next_elt($element, '#PCDATA'); 2566 ($node_length, $node_text) = $node->textLength 2567 if $node; 2568 } 2569 2570 elsif (defined $expr) 2571 { # look for substring 2572 my $text = $node->text() || ""; 2573 if (defined $offset && $offset > 0) 2574 { 2575 $text = substr($text, $offset); 2576 } 2577 if ($text =~ /($expr)/) 2578 { 2579 $found = length($`); 2580 $found += $offset if defined $offset; 2581 $end_pos = $found + length($&); 2582 $match = $1; 2583 } 2584 unless (defined $found) 2585 { 2586 $offset = undef; 2587 $node = $node->next_elt 2588 ($element, '#PCDATA'); 2589 } 2590 } 2591 else # selected by offset 2592 { 2593 $found = $offset || 0; 2594 } 2595 } 2596 } 2597 else # negative offset, backward 2598 { 2599 if ($element->isTextNode) 2600 { 2601 $node = $element; 2602 } 2603 elsif ($start_mark) 2604 { 2605 unless ($start_mark->isTextNode) 2606 { 2607 $node = $start_mark->prev_elt('#PCDATA'); 2608 } 2609 else 2610 { 2611 $node = $start_mark; 2612 } 2613 } 2614 else 2615 { 2616 $node = $element->last_descendant('#PCDATA'); 2617 } 2618 if ($end_mark) 2619 { 2620 my $n = $end_mark->last_descendant; 2621 $end_mark = $n if $n; 2622 $node = undef if 2623 ($end_mark && ! $node->after($end_mark)); 2624 } 2625 ($node_length, $node_text) = $node->textLength if $node; 2626 BACKWARD_LOOP: while ($node && !defined $found) 2627 { 2628 if ($end_mark && ! $node->after($end_mark)) 2629 { 2630 $node = undef; 2631 last; 2632 } 2633 ($node_length, $node_text) = $node->textLength; 2634 if (defined $offset && (abs($offset) > $node_length)) 2635 { # skip node 2636 $offset += $node_length; 2637 $node = $node->prev_elt($element, '#PCDATA'); 2638 } 2639 elsif (defined $expr) 2640 { 2641 my $text = $node->text() || ""; 2642 if (defined $offset && $offset < 0) 2643 { 2644 $text = substr($text, 0, $offset); 2645 } 2646 my @r = ($text =~ m/($expr)/g); 2647 if (@r) 2648 { 2649 $found = length($`); 2650 $end_pos = $found + length($&); 2651 $match = $1; 2652 } 2653 unless (defined $found) 2654 { 2655 $offset = undef; 2656 $node = $node->prev_elt 2657 ($element, '#PCDATA'); 2658 } 2659 } 2660 else # selected by offset 2661 { 2662 $found = $offset || 0; 2663 } 2664 } 2665 } 2666 2667 return ($node, $found, $end_pos, $match); 2668 } 2669 2670#------------------------------------------------------------------------------ 2671# creates new child elements in a given element and splits the content 2672# according to a regexp 2673 2674sub splitContent 2675 { 2676 my $self = shift; 2677 my $path = shift; 2678 my $pos = (ref $path) ? undef : shift; 2679 my $context = $self->getElement($path, $pos) or return undef; 2680 my $tag = shift or return undef; 2681 my $expr = $self->inputTextConversion(shift); 2682 return undef unless defined $expr; 2683 my %opt = @_; 2684 2685 my $prefix = undef; 2686 if ($tag =~ /(.*):/) 2687 { 2688 $prefix = $1 || 'text'; 2689 } 2690 else 2691 { 2692 $prefix = $context->ns_prefix() || 'text'; 2693 $tag = $prefix . ':' . $tag; 2694 } 2695 2696 my %attr = (); 2697 foreach my $k (keys %opt) 2698 { 2699 my $a = $self->inputTextConversion($opt{$k}); 2700 $k = $prefix . ':' . $k unless $k =~ /:/; 2701 $attr{$k} = $a; 2702 } 2703 %opt = (); 2704 2705 return $context->mark("($expr)", $tag, { %attr }); 2706 } 2707 2708#------------------------------------------------------------------------------ 2709# creates a child element in place within an existing element 2710# at a given position or before/after a given substring 2711 2712sub setChildElement 2713 { 2714 my $self = shift; 2715 my $path = shift; 2716 my $node = (ref $path) ? $path : $self->getElement($path, shift) 2717 or return undef; 2718 my $name = shift or return undef; 2719 my %opt = @_; 2720 if (defined $opt{'text'}) 2721 { 2722 $opt{'replace'} = $opt{'capture'} 2723 unless defined $opt{'replace'}; 2724 delete $opt{'capture'}; 2725 } 2726 my $newnode = undef; 2727 my $function = undef; 2728 2729 if (ref $name) 2730 { 2731 if ((ref $name) eq 'CODE') 2732 { 2733 $function = $name; 2734 $name = undef; 2735 } 2736 else 2737 { 2738 $newnode = $name; 2739 } 2740 } 2741 else 2742 { 2743 unless ($name =~ /:/ || $name =~ /^#/) 2744 { 2745 my $prefix = $node->ns_prefix() || 'text'; 2746 $name = $prefix . ':' . $name; 2747 } 2748 $newnode = OpenOffice::OODoc::XPath::new_element($name); 2749 } 2750 2751 my $offset = $opt{'offset'} || 0; 2752 if (lc($offset) eq 'end') 2753 { 2754 unless ($function) 2755 { 2756 $newnode->paste_last_child($node); 2757 } 2758 else 2759 { 2760 $newnode = &$function($self, $node, 'end'); 2761 } 2762 } 2763 elsif (lc($offset) eq 'start') 2764 { 2765 unless ($function) 2766 { 2767 $newnode->paste_first_child($node); 2768 } 2769 else 2770 { 2771 $newnode = &$function($self, $node, 'start'); 2772 } 2773 } 2774 else 2775 { 2776 my ($text_node, $start_pos, $end_pos, $match) = 2777 $self->textIndex($node, %opt); 2778 if ($text_node) 2779 { 2780 if (defined $opt{'replace'} || defined $opt{'capture'}) 2781 { 2782 my $t = $text_node->text; 2783 substr ( 2784 $t, $start_pos, $end_pos - $start_pos, 2785 "" 2786 ); 2787 $text_node->set_text($t); 2788 unless ($function) 2789 { 2790 $newnode->paste_within 2791 ($text_node, $start_pos); 2792 $newnode->set_text($match) 2793 if defined $opt{'capture'}; 2794 } 2795 else 2796 { 2797 $newnode = &$function 2798 ( 2799 $self, 2800 $text_node, 2801 $start_pos, 2802 $match 2803 ); 2804 } 2805 } 2806 else 2807 { 2808 my $p = defined $opt{'after'} ? 2809 $end_pos : $start_pos; 2810 unless ($function) 2811 { 2812 $newnode->paste_within($text_node, $p); 2813 } 2814 else 2815 { 2816 $newnode = &$function 2817 ( 2818 $self, 2819 $text_node, 2820 $p, 2821 $match 2822 ); 2823 } 2824 } 2825 } 2826 else 2827 { 2828 return undef; 2829 } 2830 } 2831 2832 if ($newnode) 2833 { 2834 $self->setAttributes($newnode, %{$opt{'attributes'}}); 2835 $self->setText($newnode, $opt{'text'}) 2836 unless is_true($opt{'no_text'}); 2837 } 2838 return $newnode; 2839 } 2840 2841#------------------------------------------------------------------------------ 2842# create successive child elements 2843 2844sub setChildElements 2845 { 2846 my $self = shift; 2847 my $path = shift; 2848 my $pos = (ref $path) ? undef : shift; 2849 my $element = $self->getElement($path, $pos) or return undef; 2850 my $name = shift or return undef; 2851 my %opt = @_; 2852 2853 my @elements = (); 2854 my $node = $self->setChildElement($element, $name, %opt); 2855 push @elements, $node if $node; 2856 2857 if (defined $opt{'text'}) 2858 { 2859 $opt{'replace'} = $opt{'capture'} 2860 unless defined $opt{'replace'}; 2861 delete $opt{'capture'}; 2862 } 2863 2864 delete $opt{'attributes'}; 2865 delete $opt{'text'}; 2866 delete $opt{'offset'} if 2867 ( 2868 defined $opt{'after'} || 2869 defined $opt{'before'} || 2870 defined $opt{'replace'} || 2871 defined $opt{'capture'} 2872 ); 2873 $opt{'offset'} = 1 if 2874 ( 2875 ($opt{'way'} ne 'backward' && defined $opt{'before'}) 2876 || 2877 ($opt{'way'} eq 'backward' && defined $opt{'after'}) 2878 ); 2879 2880 while ($node) 2881 { 2882 my $arg = ref($name) eq 'CODE' ? $name : $node->copy; 2883 $node = $self->setChildElement 2884 ($element, $arg, %opt, start_mark => $node); 2885 push @elements, $node if $node; 2886 } 2887 2888 return @elements; 2889 } 2890 2891#------------------------------------------------------------------------------ 2892 2893sub markElement 2894 { 2895 my $self = shift; 2896 my $context = shift or return undef; 2897 my $tag = shift; 2898 my $expression = $self->inputTextConversion(shift); 2899 my %attr = @_; 2900 2901 return $context->mark("($expression)", $tag, { %attr }); 2902 } 2903 2904#------------------------------------------------------------------------------ 2905# inserts a new element before or after a given node 2906 2907sub insertElement 2908 { 2909 my $self = shift; 2910 my $path = shift; 2911 my $pos = (ref $path) ? undef : shift; 2912 my $name = shift; 2913 my %opt = @_; 2914 $opt{'attributes'} = $opt{'attribute'} unless $opt{'attributes'}; 2915 2916 return undef unless $name; 2917 my $element = undef; 2918 unless (ref $name) 2919 { 2920 $element = $self->createElement($name, $opt{'text'}); 2921 } 2922 else 2923 { 2924 $element = $name; 2925 $self->setText($element, $opt{'text'}) if $opt{'text'}; 2926 } 2927 return undef unless $element; 2928 2929 my $posnode = $self->getElement($path, $pos, $opt{'context'}); 2930 unless ($posnode) 2931 { 2932 warn "[" . __PACKAGE__ . "::insertElement] Unknown position\n"; 2933 return undef; 2934 } 2935 2936 if ($opt{'position'}) 2937 { 2938 if ($opt{'position'} eq 'after') 2939 { 2940 $element->paste_after($posnode); 2941 } 2942 elsif ($opt{'position'} eq 'before') 2943 { 2944 $element->paste_before($posnode); 2945 } 2946 elsif ($opt{'position'} eq 'within') 2947 { 2948 my $offset = $opt{'offset'} || 0; 2949 $element->paste_within($posnode, $offset); 2950 } 2951 else 2952 { 2953 warn "[" . __PACKAGE__ . "::insertElement] " . 2954 "Invalid $opt{'position'} option\n"; 2955 return undef; 2956 } 2957 } 2958 else 2959 { 2960 $element->paste_before($posnode); 2961 } 2962 2963 $self->setAttributes($element, %{$opt{'attributes'}}); 2964 2965 return $element; 2966 } 2967 2968#------------------------------------------------------------------------------ 2969# removes the given element & children 2970 2971sub removeElement 2972 { 2973 my $self = shift; 2974 2975 my $e = $self->getElement(@_); 2976 return undef unless $e; 2977 return $e->delete; 2978 } 2979 2980#------------------------------------------------------------------------------ 2981# cuts the given element & children (to be pasted elsewhere) 2982 2983sub cutElement 2984 { 2985 my $self = shift; 2986 2987 my $e = $self->getElement(@_); 2988 return undef unless $e; 2989 $e->cut; 2990 2991 return $e; 2992 } 2993 2994#----------------------------------------------------------------------------- 2995# splits a text element at a given offset 2996 2997sub splitElement 2998 { 2999 my $self = shift; 3000 my $path = shift; 3001 my $old_element = 3002 (ref $path) ? $path : $self->getElement($path, shift); 3003 my $offset = shift; 3004 3005 my $new_element = $old_element->split_at($offset); 3006 $new_element->set_atts($old_element->atts); 3007 return wantarray ? ($old_element, $new_element) : $new_element; 3008 } 3009 3010#------------------------------------------------------------------------------ 3011# get/set ODF element identifier 3012 3013sub getIdentifier 3014 { 3015 my $self = shift; 3016 my $path = shift; 3017 my $element = 3018 (ref $path) ? $path : $self->getElement($path, shift); 3019 return $self->outputTextConversion($element->getID()); 3020 } 3021 3022sub setIdentifier 3023 { 3024 my $self = shift; 3025 my $path = shift; 3026 my $element = 3027 (ref $path) ? $path : $self->getElement($path, shift); 3028 my $value = shift; 3029 return (defined $value) ? 3030 $self->inputTextConversion($element->setID($value)) : 3031 $self->removeIdentifier($element); 3032 } 3033 3034sub identifier 3035 { 3036 my $self = shift; 3037 my $path = shift; 3038 my $element = 3039 (ref $path) ? $path : $self->getElement($path, shift); 3040 my $value = shift; 3041 return (defined $value) ? 3042 $self->setIdentifier($element, $value) : 3043 $self->getIdentifier($element); 3044 } 3045 3046sub removeIdentifier 3047 { 3048 my $self = shift; 3049 my $path = shift; 3050 my $element = 3051 (ref $path) ? $path : $self->getElement($path, shift); 3052 return $element->setID(); 3053 } 3054 3055sub getElementName 3056 { 3057 my $self = shift; 3058 my $path = shift; 3059 my $element = 3060 (ref $path) ? $path : $self->getElement($path, shift); 3061 my $attr = $element->ns_prefix() . ':name'; 3062 return $self->getAttribute($element, $attr); 3063 } 3064 3065sub setElementName 3066 { 3067 my $self = shift; 3068 my $path = shift; 3069 my $element = 3070 (ref $path) ? $path : $self->getElement($path, shift); 3071 my $attr = $element->ns_prefix() . ':name'; 3072 return $self->setAttribute($element, $attr => shift); 3073 } 3074 3075sub elementName 3076 { 3077 my $self = shift; 3078 my $path = shift; 3079 my $element = 3080 (ref $path) ? $path : $self->getElement($path, shift); 3081 my $value = shift; 3082 return (defined $value) ? 3083 $self->setElementName($element, $value) : 3084 $self->getElementName($element); 3085 } 3086 3087#------------------------------------------------------------------------------ 3088# some extensions for XML Twig elements 3089package OpenOffice::OODoc::Element; 3090our @ISA = qw ( XML::Twig::Elt ); 3091#------------------------------------------------------------------------------ 3092 3093BEGIN { 3094 *identifier = *ID; 3095 *getPrefix = *XML::Twig::Elt::ns_prefix; 3096 *getNodeValue = *XML::Twig::Elt::text; 3097 *getValue = *XML::Twig::Elt::text; 3098 *setNodeValue = *XML::Twig::Elt::set_text; 3099 *getAttribute = *XML::Twig::Elt::att; 3100 *setName = *XML::Twig::Elt::set_tag; 3101 *getParentNode = *XML::Twig::Elt::parent; 3102 *getDescendantTextNodes = *getTextDescendants; 3103 *dispose = *XML::Twig::Elt::delete; 3104 } 3105 3106sub hasTag 3107 { 3108 my $node = shift; 3109 my $name = $node->getName; 3110 my $value = shift; 3111 return ($name && ($name eq $value)) ? 1 : undef; 3112 } 3113 3114sub isFrame 3115 { 3116 my $node = shift; 3117 return $node->hasTag('draw:frame'); 3118 } 3119 3120sub getLocalPosition 3121 { 3122 my $node = shift; 3123 my $tag = (shift || $node->getName) or return undef; 3124 my $xpos = $node->pos($tag); 3125 return defined $xpos ? $xpos - 1 : undef; 3126 } 3127 3128sub selectChildElements 3129 { 3130 my $node = shift; 3131 my $filter = shift; 3132 my $condition = ref $filter ? $filter : qr($filter); 3133 return $node->children($condition); 3134 } 3135 3136sub selectChildElement 3137 { 3138 my $node = shift; 3139 my $filter = shift; 3140 my $pos = shift || 0; 3141 3142 my $count = 0; 3143 my $fc = $node->first_child; 3144 return $fc unless defined $filter; 3145 my $name = $fc->name if $fc; 3146 while ($fc) 3147 { 3148 if ($name && ($name =~ /$filter/)) 3149 { 3150 return $fc if ($count >= $pos); 3151 $count++; 3152 } 3153 $fc = $fc->next_sibling; 3154 $name = $fc->name if $fc; 3155 } 3156 return undef; 3157 } 3158 3159sub getFirstChild 3160 { 3161 my $node = shift; 3162 my $fc = $node->first_child(@_); 3163 my $name = $fc->name if $fc; 3164 while ($name && ($name =~ /^#/)) 3165 { 3166 $fc = $fc->next_sibling(@_); 3167 $name = $fc->name if $fc; 3168 } 3169 return $fc; 3170 } 3171 3172sub getLastChild 3173 { 3174 my $node = shift; 3175 my $lc = $node->last_child(@_); 3176 my $name = $lc->name; 3177 while ($name && ($name =~ /^#/)) 3178 { 3179 $lc = $lc->prev_sibling(@_); 3180 $name = $lc->name; 3181 } 3182 return $lc; 3183 } 3184 3185sub getChildrenTextNodes 3186 { 3187 my $node = shift; 3188 return $node->children('#PCDATA'); 3189 } 3190 3191sub getChildTextNode 3192 { 3193 my $node = shift; 3194 my $pos = shift || 0; 3195 my @children = $node->children('#PCDATA'); 3196 return $children[$pos]; 3197 } 3198 3199sub getTextDescendants 3200 { 3201 my ($node, $filter) = @_; 3202 return defined $filter ? 3203 $node->get_xpath('#PCDATA[string()=~/' . $filter . '/]') : 3204 $node->descendants('#PCDATA'); 3205 } 3206 3207sub textLength # length of a text node 3208 { 3209 my $node = shift; 3210 my $text = $node->text; 3211 my $length = length($text); 3212 return wantarray ? ($length, $text) : $length; 3213 } 3214 3215sub appendChild 3216 { 3217 my $node = shift; 3218 my $child = shift; 3219 unless (ref $child) 3220 { 3221 $child = OpenOffice::OODoc::XPath::new_element($child, @_); 3222 } 3223 return $child->paste_last_child($node); 3224 } 3225 3226sub pickUpChildren 3227 { 3228 my $parent = shift; 3229 my @children = @_; 3230 foreach my $child (@children) 3231 { 3232 $child->move(last_child => $parent); 3233 } 3234 return $parent; 3235 } 3236 3237sub insertNewNode 3238 { 3239 my $node = shift; 3240 my $newnode = shift or return undef; 3241 my $position = shift; # 'before', 'after', 'within', ... 3242 my $offset = shift; 3243 unless (ref $newnode) 3244 { 3245 $newnode = OpenOffice::OODoc::XPath::new_element($newnode, @_); 3246 } 3247 if (defined $offset) 3248 { 3249 return $newnode->paste($position => $node, $offset); 3250 } 3251 else 3252 { 3253 return $newnode->paste($position => $node); 3254 } 3255 } 3256 3257sub insertNodes 3258 { 3259 my $node = shift; 3260 my $offset = shift; 3261 my $child = shift or return undef; 3262 $child->paste_within($node, $offset); 3263 my $count = 1; 3264 while (@_) 3265 { 3266 my $next_child = shift; 3267 $next_child->paste_after($child); 3268 $child = $next_child; 3269 $count++; 3270 } 3271 return $count; 3272 } 3273 3274sub replicateNode 3275 { 3276 my $node = shift; 3277 my $number = shift; 3278 $number = 1 unless defined $number; 3279 my $position = shift || 'after'; 3280 my $last_node = $node; 3281 while ($number > 0) 3282 { 3283 my $newnode = $node->copy; 3284 $newnode->paste($position => $last_node); 3285 $last_node = $newnode; 3286 $number--; 3287 } 3288 return $last_node; 3289 } 3290 3291sub flatten 3292 { 3293 my $node = shift; 3294 return $node->set_text($node->text); 3295 } 3296 3297sub appendTextChild 3298 { 3299 my $node = shift; 3300 my $text = shift; 3301 return undef unless defined $text; 3302 my $text_node = OpenOffice::OODoc::Element->new('#PCDATA' => $text); 3303 return $text_node->paste_last_child($node); 3304 } 3305 3306sub insertTextChild 3307 { 3308 my $node = shift; 3309 my $text = shift; 3310 return undef unless defined $text; 3311 my $offset = shift; 3312 return $node->appendTextChild($text) unless defined $offset; 3313 my $text_node = OpenOffice::OODoc::Element->new('#PCDATA' => $text); 3314 return $offset > 0 ? 3315 $text_node->paste_within($node, $offset) : 3316 $text_node->paste_first_child($node); 3317 } 3318 3319sub getAttributes 3320 { 3321 my $node = shift; 3322 return %{$node->atts(@_) || {}}; 3323 } 3324 3325sub setAttribute 3326 { 3327 my $node = shift or return undef; 3328 my $attribute = shift; 3329 my $value = shift; 3330 if (defined $value) 3331 { 3332 return $node->set_att($attribute, $value, @_); 3333 } 3334 else 3335 { 3336 return $node->removeAttribute($attribute); 3337 } 3338 } 3339 3340sub setID 3341 { 3342 my $node = shift; 3343 return $node->setAttribute($ELT_ID, shift); 3344 } 3345 3346sub getID 3347 { 3348 my $node = shift; 3349 return $node->getAttribute($ELT_ID); 3350 } 3351 3352sub ID 3353 { 3354 my $node = shift; 3355 my $new_id = shift; 3356 return (defined $new_id) ? $node->setID($new_id) : $node->getID(); 3357 } 3358 3359sub removeAttribute 3360 { 3361 my $node = shift or return undef; 3362 my $attribute = shift or return undef; 3363 return $node->att($attribute) ? $node->del_att($attribute) : undef; 3364 } 3365 3366#------------------------------------------------------------------------------ 33671; 3368