Profile of XML/Twig.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm
Statements | Executed 74150636 statements in 41.9s

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
364369 | 3 | 2 | 9.97s | 35.2s | XML::Twig::::_twig_start XML::Twig::_twig_start
1095679 | 2 | 1 | 6.34s | 15.8s | XML::Twig::::_ns_info XML::Twig::_ns_info
398167 | 2 | 1 | 5.90s | 22.1s | XML::Twig::::_replace_ns XML::Twig::_replace_ns
364369 | 2 | 2 | 5.66s | 25.4s | XML::Twig::::_twig_end XML::Twig::_twig_end
380001 | 2 | 1 | 5.08s | 7.90s | XML::Twig::::_a_proper_ns_prefix XML::Twig::_a_proper_ns_prefix
364369 | 1 | 1 | 2.12s | 2.69s | XML::Twig::::_replace_prefix XML::Twig::_replace_prefix
364369 | 1 | 1 | 1.71s | 1.82s | XML::Twig::Elt::::new XML::Twig::Elt::new
421560 | 14 | 2 | 1.66s | 2.08s | XML::Twig::Elt::::first_child XML::Twig::Elt::first_child
364369 | 1 | 1 | 1.56s | 1.69s | XML::Twig::Elt::::set_atts XML::Twig::Elt::set_atts
397806 | 2 | 1 | 1.18s | 1.46s | XML::Twig::::_handler XML::Twig::_handler
127292 | 1 | 1 | 968ms | 1.00s | XML::Twig::::_insert_pcdata XML::Twig::_insert_pcdata
202986 | 1 | 1 | 915ms | 958ms | XML::Twig::Elt::::next_sibling XML::Twig::Elt::next_sibling
127292 | 1 | 1 | 829ms | 1.91s | XML::Twig::::_twig_char XML::Twig::_twig_char
33799 | 1 | 1 | 720ms | 8.21s | XML::Twig::::_twig_start_check_roots XML::Twig::_twig_start_check_roots
254582 | 3 | 2 | 678ms | 678ms | XML::Twig::Elt::::text XML::Twig::Elt::text (recurses: max depth 1, inclusive time 145ms)
728738 | 2 | 1 | 599ms | 599ms | XML::Twig::::_add_or_discard_stored_spaces XML::Twig::_add_or_discard_stored_spaces
33813 | 1 | 1 | 545ms | 579ms | XML::Twig::Elt::::cut XML::Twig::Elt::cut
1858243 | 4 | 1 | 524ms | 524ms | XML::Twig::::parser XML::Twig::parser
15651 | 8 | 7 | 500ms | 1.57s | XML::Twig::Elt::::children XML::Twig::Elt::children
33807 | 7 | 1 | 317ms | 1.17s | XML::Twig::::purge XML::Twig::purge
674081 | 45 | 1 | 278ms | 278ms | XML::Twig::Elt::::att XML::Twig::Elt::att
67768 | 3 | 1 | 177ms | 203ms | XML::Twig::Elt::::in XML::Twig::Elt::in
364369 | 1 | 1 | 128ms | 128ms | XML::Twig::Elt::::keep_atts_order XML::Twig::Elt::keep_atts_order
33813 | 2 | 1 | 74.1ms | 653ms | XML::Twig::Elt::::delete XML::Twig::Elt::delete
127487 | 10 | 9 | 64.6ms | 64.6ms | XML::Twig::Elt::::gi XML::Twig::Elt::gi
37 | 2 | 1 | 6.09ms | 7.38ms | XML::Twig::Elt::::_install_cond XML::Twig::Elt::_install_cond
21 | 1 | 1 | 3.22ms | 5.96ms | XML::Twig::::_parse_xpath_handler XML::Twig::_parse_xpath_handler
15 | 1 | 1 | 1.98ms | 3.48ms | XML::Twig::Elt::::_install_xpath XML::Twig::Elt::_install_xpath
7 | 1 | 1 | 1.59ms | 2.49ms | XML::Twig::::_use XML::Twig::_use
1 | 1 | 1 | 1.01ms | 3.56ms | XML::Twig::::BEGIN@151 XML::Twig::BEGIN@151
16 | 1 | 1 | 618µs | 870µs | XML::Twig::Elt::::descendants XML::Twig::Elt::descendants
154 | 2 | 1 | 527µs | 649µs | XML::Twig::Elt::::ancestors XML::Twig::Elt::ancestors
77 | 1 | 1 | 479µs | 1.42ms | XML::Twig::Elt::::cmp XML::Twig::Elt::cmp
7 | 1 | 1 | 392µs | 12.0ms | XML::Twig::::new XML::Twig::new
21 | 2 | 1 | 382µs | 8.48ms | XML::Twig::::_set_handler XML::Twig::_set_handler
1 | 1 | 1 | 307µs | 480µs | XML::Twig::::BEGIN@1125 XML::Twig::BEGIN@1125
117 | 1 | 1 | 242µs | 242µs | XML::Twig::Elt::::set_gi XML::Twig::Elt::set_gi
458 | 2 | 1 | 190µs | 5.29ms | XML::Twig::Elt::::passes XML::Twig::Elt::passes
1 | 1 | 1 | 141µs | 169µs | XML::Twig::::BEGIN@25 XML::Twig::BEGIN@25
1 | 1 | 1 | 136µs | 252µs | XML::Twig::Elt::::next_elt XML::Twig::Elt::next_elt
6 | 3 | 2 | 125µs | 584µs | XML::Twig::::DESTROY XML::Twig::DESTROY
27 | 1 | 1 | 117µs | 120µs | XML::Twig::::_tag_cond XML::Twig::_tag_cond
37 | 1 | 1 | 112µs | 153µs | XML::Twig::Elt::::_gi_test XML::Twig::Elt::_gi_test
21 | 1 | 1 | 94µs | 6.12ms | XML::Twig::::_set_xpath_handler XML::Twig::_set_xpath_handler
16 | 1 | 1 | 86µs | 12.3ms | XML::Twig::Elt::::get_xpath XML::Twig::Elt::get_xpath
16 | 15 | 15 | 84µs | 6.13ms | XML::Twig::::descendants XML::Twig::descendants
16 | 16 | 1 | 82µs | 12.4ms | XML::Twig::::get_xpath XML::Twig::get_xpath
1 | 1 | 1 | 81µs | 81µs | Spreadsheet::ParseXLSX::::BEGIN@11.2 Spreadsheet::ParseXLSX::BEGIN@11.2
1 | 1 | 1 | 79µs | 240µs | XML::Twig::::BEGIN@148 XML::Twig::BEGIN@148
21 | 1 | 1 | 72µs | 72µs | XML::Twig::::_add_handler XML::Twig::_add_handler
7 | 1 | 1 | 65µs | 88µs | XML::Twig::::_twig_final XML::Twig::_twig_final
7 | 1 | 1 | 63µs | 63µs | XML::Twig::::_normalize_args XML::Twig::_normalize_args
1 | 1 | 1 | 61µs | 4.78ms | XML::Twig::::setTwigRoots XML::Twig::setTwigRoots
75 | 3 | 1 | 60µs | 60µs | XML::Twig::::_join_n XML::Twig::_join_n
16 | 15 | 15 | 60µs | 1.56ms | XML::Twig::::_unique_elts XML::Twig::_unique_elts
7 | 1 | 1 | 50µs | 80µs | XML::Twig::::_twig_end_check_roots XML::Twig::_twig_end_check_roots
7 | 3 | 1 | 48µs | 70.4s | XML::Twig::::parse XML::Twig::parse
21 | 1 | 1 | 48µs | 92µs | XML::Twig::::_set_pi_handler XML::Twig::_set_pi_handler
21 | 1 | 1 | 48µs | 88µs | XML::Twig::::_set_special_handler XML::Twig::_set_special_handler
16 | 1 | 1 | 40µs | 40µs | XML::Twig::Elt::::root XML::Twig::Elt::root
16 | 15 | 15 | 38µs | 78µs | XML::Twig::Elt::::twig XML::Twig::Elt::twig
7 | 1 | 1 | 33µs | 44µs | XML::Twig::::_twig_init XML::Twig::_twig_init
1 | 1 | 1 | 33µs | 49µs | XML::Twig::Elt::::BEGIN@5096 XML::Twig::Elt::BEGIN@5096
7 | 1 | 1 | 32µs | 32µs | XML::Twig::::_twig_xmldecl XML::Twig::_twig_xmldecl
21 | 1 | 1 | 31µs | 36µs | XML::Twig::::_set_level_handler XML::Twig::_set_level_handler
1 | 1 | 1 | 29µs | 29µs | XML::Twig::::BEGIN@3842 XML::Twig::BEGIN@3842
21 | 1 | 1 | 29µs | 32µs | XML::Twig::::_set_regexp_handler XML::Twig::_set_regexp_handler
2 | 2 | 1 | 22µs | 6.11ms | XML::Twig::::_set_handlers XML::Twig::_set_handlers
7 | 1 | 1 | 22µs | 24µs | XML::Twig::::set_root XML::Twig::set_root
7 | 1 | 1 | 21µs | 25µs | XML::Twig::Elt::::set_output_filter XML::Twig::Elt::set_output_filter
34 | 4 | 1 | 20µs | 20µs | XML::Twig::::root XML::Twig::root
6 | 1 | 1 | 18µs | 26µs | XML::Twig::Elt::::is_elt XML::Twig::Elt::is_elt
7 | 1 | 1 | 18µs | 20µs | XML::Twig::Elt::::set_output_text_filter XML::Twig::Elt::set_output_text_filter
7 | 1 | 1 | 18µs | 26µs | XML::Twig::::set_keep_encoding XML::Twig::set_keep_encoding
6 | 1 | 1 | 18µs | 23µs | XML::Twig::::_twig_default XML::Twig::_twig_default
7 | 1 | 1 | 17µs | 78µs | XML::Twig::::_checked_parse_result XML::Twig::_checked_parse_result
1 | 1 | 1 | 16µs | 16µs | XML::Twig::Elt::::BEGIN@8119 XML::Twig::Elt::BEGIN@8119
7 | 1 | 1 | 13µs | 13µs | XML::Twig::Entity_list::::new XML::Twig::Entity_list::new
7 | 1 | 1 | 13µs | 13µs | XML::Twig::Elt::::_join_defined XML::Twig::Elt::_join_defined
7 | 1 | 1 | 13µs | 26µs | XML::Twig::Elt::::_and XML::Twig::Elt::_and
7 | 1 | 1 | 11µs | 20µs | XML::Twig::::set_expand_external_entities XML::Twig::set_expand_external_entities
7 | 1 | 1 | 11µs | 11µs | XML::Twig::Elt::::set_quote XML::Twig::Elt::set_quote
7 | 1 | 1 | 11µs | 17µs | XML::Twig::::set_do_not_escape_amp_in_atts XML::Twig::set_do_not_escape_amp_in_atts
7 | 1 | 1 | 11µs | 22µs | XML::Twig::::set_quote XML::Twig::set_quote
7 | 1 | 1 | 10µs | 17µs | XML::Twig::::set_keep_atts_order XML::Twig::set_keep_atts_order
5 | 1 | 1 | 10µs | 10µs | XML::Twig::Elt::::_op XML::Twig::Elt::_op
7 | 1 | 1 | 10µs | 10µs | XML::Twig::Notation_list::::newXML::Twig::Notation_list::new
7 | 1 | 1 | 9µs | 14µs | XML::Twig::::set_remove_cdata XML::Twig::set_remove_cdata
7 | 1 | 1 | 9µs | 34µs | XML::Twig::::set_output_filter XML::Twig::set_output_filter
1 | 1 | 1 | 9µs | 10µs | XML::Twig::Elt::::BEGIN@8108 XML::Twig::Elt::BEGIN@8108
1 | 1 | 1 | 9µs | 9µs | XML::Twig::::_check_illegal_twig_roots_handlers XML::Twig::_check_illegal_twig_roots_handlers
7 | 1 | 1 | 9µs | 28µs | XML::Twig::::set_output_text_filter XML::Twig::set_output_text_filter
7 | 1 | 1 | 8µs | 8µs | XML::Twig::Elt::::set_expand_external_entities XML::Twig::Elt::set_expand_external_entities
1 | 1 | 1 | 8µs | 3.81ms | XML::Twig::::setTwigHandlers XML::Twig::setTwigHandlers
1 | 1 | 1 | 8µs | 10µs | Spreadsheet::ParseXLSX::::BEGIN@1 Spreadsheet::ParseXLSX::BEGIN@1
1 | 1 | 1 | 8µs | 10µs | XML::Twig::::BEGIN@2455 XML::Twig::BEGIN@2455
7 | 1 | 1 | 8µs | 8µs | XML::Twig::Elt::::set_keep_encoding XML::Twig::Elt::set_keep_encoding
1 | 1 | 1 | 8µs | 10µs | XML::Twig::::BEGIN@4636 XML::Twig::BEGIN@4636
1 | 1 | 1 | 8µs | 12µs | XML::Twig::::BEGIN@1327 XML::Twig::BEGIN@1327
1 | 1 | 1 | 8µs | 12µs | XML::Twig::::BEGIN@3229 XML::Twig::BEGIN@3229
7 | 1 | 1 | 8µs | 8µs | XML::Twig::::_set_fh_to_selected_fh XML::Twig::_set_fh_to_selected_fh
1 | 1 | 1 | 7µs | 20µs | XML::Twig::::BEGIN@439 XML::Twig::BEGIN@439
1 | 1 | 1 | 7µs | 31µs | XML::Twig::Elt::::BEGIN@5082 XML::Twig::Elt::BEGIN@5082
1 | 1 | 1 | 7µs | 9µs | XML::Twig::Elt::::BEGIN@7919 XML::Twig::Elt::BEGIN@7919
1 | 1 | 1 | 7µs | 8µs | XML::Twig::::BEGIN@30 XML::Twig::BEGIN@30
7 | 1 | 1 | 7µs | 7µs | XML::Twig::Elt::::set_keep_atts_order XML::Twig::Elt::set_keep_atts_order
1 | 1 | 1 | 7µs | 7µs | XML::Twig::Elt::::BEGIN@8404 XML::Twig::Elt::BEGIN@8404
1 | 1 | 1 | 7µs | 11µs | XML::Twig::::BEGIN@3587 XML::Twig::BEGIN@3587
7 | 1 | 1 | 7µs | 7µs | XML::Twig::Elt::::set_do_not_escape_amp_in_atts XML::Twig::Elt::set_do_not_escape_amp_in_atts
1 | 1 | 1 | 6µs | 10µs | XML::Twig::::BEGIN@4159 XML::Twig::BEGIN@4159
7 | 1 | 1 | 6µs | 6µs | XML::Twig::::_set_fh_to_twig_output_fh XML::Twig::_set_fh_to_twig_output_fh
1 | 1 | 1 | 6µs | 6µs | XML::Twig::Elt::::BEGIN@8906 XML::Twig::Elt::BEGIN@8906
1 | 1 | 1 | 6µs | 10µs | XML::Twig::::BEGIN@3852 XML::Twig::BEGIN@3852
2 | 2 | 1 | 6µs | 6µs | XML::Twig::::_reset_handlers XML::Twig::_reset_handlers
1 | 1 | 1 | 6µs | 6µs | XML::Twig::Elt::::BEGIN@6961 XML::Twig::Elt::BEGIN@6961
1 | 1 | 1 | 6µs | 9µs | XML::Twig::::BEGIN@3619 XML::Twig::BEGIN@3619
1 | 1 | 1 | 6µs | 9µs | XML::Twig::::BEGIN@3648 XML::Twig::BEGIN@3648
1 | 1 | 1 | 5µs | 18µs | XML::Twig::::BEGIN@812 XML::Twig::BEGIN@812
1 | 1 | 1 | 5µs | 6µs | XML::Twig::::BEGIN@4649 XML::Twig::BEGIN@4649
1 | 1 | 1 | 5µs | 8µs | XML::Twig::::BEGIN@4211 XML::Twig::BEGIN@4211
1 | 1 | 1 | 5µs | 8µs | XML::Twig::::BEGIN@4246 XML::Twig::BEGIN@4246
7 | 1 | 1 | 5µs | 5µs | XML::Twig::Elt::::set_remove_cdata XML::Twig::Elt::set_remove_cdata
1 | 1 | 1 | 5µs | 24µs | XML::Twig::::BEGIN@29 XML::Twig::BEGIN@29
1 | 1 | 1 | 5µs | 8µs | XML::Twig::::BEGIN@4175 XML::Twig::BEGIN@4175
1 | 1 | 1 | 4µs | 14µs | XML::Twig::::BEGIN@38 XML::Twig::BEGIN@38
1 | 1 | 1 | 4µs | 4µs | XML::Twig::Elt::::BEGIN@7340 XML::Twig::Elt::BEGIN@7340
1 | 1 | 1 | 4µs | 10µs | XML::Twig::::BEGIN@33 XML::Twig::BEGIN@33
1 | 1 | 1 | 4µs | 21µs | XML::Twig::::BEGIN@31 XML::Twig::BEGIN@31
1 | 1 | 1 | 4µs | 28µs | XML::Twig::::BEGIN@27 XML::Twig::BEGIN@27
1 | 1 | 1 | 4µs | 6µs | XML::Twig::::BEGIN@4181 XML::Twig::BEGIN@4181
1 | 1 | 1 | 4µs | 18µs | Spreadsheet::ParseXLSX::::BEGIN@2 Spreadsheet::ParseXLSX::BEGIN@2
1 | 1 | 1 | 3µs | 3µs | XML::Twig::Notation::::BEGIN@5023 XML::Twig::Notation::BEGIN@5023
1 | 1 | 1 | 3µs | 3µs | XML::Twig::Elt::::BEGIN@6232 XML::Twig::Elt::BEGIN@6232
1 | 1 | 1 | 2µs | 2µs | XML::Twig::::__ANON__[:265] XML::Twig::__ANON__[:265]
1 | 1 | 1 | 1µs | 1µs | Spreadsheet::ParseXLSX::::BEGIN@7 Spreadsheet::ParseXLSX::BEGIN@7
1 | 1 | 1 | 1µs | 1µs | XML::Twig::Elt::::set_destroy XML::Twig::Elt::set_destroy
1 | 1 | 1 | 600ns | 600ns | Spreadsheet::ParseXLSX::::__ANON__ Spreadsheet::ParseXLSX::__ANON__ (xsub)
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::__ANON__[:9636] XML::Twig::Elt::__ANON__[:9636]
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::__ANON__[:9643] XML::Twig::Elt::__ANON__[:9643]
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::__destroy XML::Twig::Elt::__destroy
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::__flush XML::Twig::Elt::__flush
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_ancestors XML::Twig::Elt::_ancestors
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_att_xml_string XML::Twig::Elt::_att_xml_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_atts_to_SAX2 XML::Twig::Elt::_atts_to_SAX2
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_children XML::Twig::Elt::_children
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_comment_escaped_string XML::Twig::Elt::_comment_escaped_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_croak_and_doublecheck_xpath XML::Twig::Elt::_croak_and_doublecheck_xpath
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_current_ns_prefix_map XML::Twig::Elt::_current_ns_prefix_map
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_del_extra_data_before_end_tag XML::Twig::Elt::_del_extra_data_before_end_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_del_extra_data_in_pcdata XML::Twig::Elt::_del_extra_data_in_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_del_flushed XML::Twig::Elt::_del_flushed
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_descendants XML::Twig::Elt::_descendants
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_dump XML::Twig::Elt::_dump
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_dump_extra_data XML::Twig::Elt::_dump_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_end_prefix_mapping XML::Twig::Elt::_end_prefix_mapping
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_end_tag_data_SAX1 XML::Twig::Elt::_end_tag_data_SAX1
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_end_tag_data_SAX2 XML::Twig::Elt::_end_tag_data_SAX2
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_extra_data_before_end_tag XML::Twig::Elt::_extra_data_before_end_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_extra_data_in_pcdata XML::Twig::Elt::_extra_data_in_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_first_child XML::Twig::Elt::_first_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_flush XML::Twig::Elt::_flush
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_flushed XML::Twig::Elt::_flushed
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_following_elt XML::Twig::Elt::_following_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_gen_mark XML::Twig::Elt::_gen_mark
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_inherit_att_through_cut XML::Twig::Elt::_inherit_att_through_cut
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_install_replace_sub XML::Twig::Elt::_install_replace_sub
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_is_private XML::Twig::Elt::_is_private
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_is_private_name XML::Twig::Elt::_is_private_name
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_is_string XML::Twig::Elt::_is_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_keep_encoding XML::Twig::Elt::_keep_encoding
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_key_attr XML::Twig::Elt::_key_attr
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_last_child XML::Twig::Elt::_last_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_last_descendant XML::Twig::Elt::_last_descendant
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_local_name XML::Twig::Elt::_local_name
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_match_expr XML::Twig::Elt::_match_expr
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_match_extra_data XML::Twig::Elt::_match_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_match_extra_data_chars XML::Twig::Elt::_match_extra_data_chars
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_match_extra_data_words XML::Twig::Elt::_match_extra_data_words
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_match_tag XML::Twig::Elt::_match_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_move_extra_data_after_erase XML::Twig::Elt::_move_extra_data_after_erase
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_new_pcdata XML::Twig::Elt::_new_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_next_sibling XML::Twig::Elt::_next_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_next_siblings XML::Twig::Elt::_next_siblings
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_normalize_space XML::Twig::Elt::_normalize_space
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_ns_prefix XML::Twig::Elt::_ns_prefix
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_parent XML::Twig::Elt::_parent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_parse_predicate_in_step XML::Twig::Elt::_parse_predicate_in_step
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_pos_offset XML::Twig::Elt::_pos_offset
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_preceding_elt XML::Twig::Elt::_preceding_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_prefix_extra_data_before_end_tag XML::Twig::Elt::_prefix_extra_data_before_end_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_pretty_print XML::Twig::Elt::_pretty_print
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_pretty_print_styles XML::Twig::Elt::_pretty_print_styles
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_prev_sibling XML::Twig::Elt::_prev_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_prev_siblings XML::Twig::Elt::_prev_siblings
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_protect_extra_data XML::Twig::Elt::_protect_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_push_extra_data_in_pcdata XML::Twig::Elt::_push_extra_data_in_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_repl_match XML::Twig::Elt::_repl_match
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_replace_var XML::Twig::Elt::_replace_var
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_replace_vars_in_text XML::Twig::Elt::_replace_vars_in_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_restore_original_prefix XML::Twig::Elt::_restore_original_prefix
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_root_through_cut XML::Twig::Elt::_root_through_cut
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_self XML::Twig::Elt::_self
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_cdata XML::Twig::Elt::_set_cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_comment XML::Twig::Elt::_set_comment
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_extra_data_before_end_tag XML::Twig::Elt::_set_extra_data_before_end_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_extra_data_in_pcdata XML::Twig::Elt::_set_extra_data_in_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_flushed XML::Twig::Elt::_set_flushed
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_id XML::Twig::Elt::_set_id
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_pcdata XML::Twig::Elt::_set_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_set_pi XML::Twig::Elt::_set_pi
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_short_text XML::Twig::Elt::_short_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_simplify XML::Twig::Elt::_simplify
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_split XML::Twig::Elt::_split
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_sprint XML::Twig::Elt::_sprint
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_start_prefix_mapping XML::Twig::Elt::_start_prefix_mapping
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_start_tag_data_SAX1 XML::Twig::Elt::_start_tag_data_SAX1
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_start_tag_data_SAX2 XML::Twig::Elt::_start_tag_data_SAX2
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_store_var XML::Twig::Elt::_store_var
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_stringify_struct XML::Twig::Elt::_stringify_struct
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_text_with_vars XML::Twig::Elt::_text_with_vars
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_toSAX XML::Twig::Elt::_toSAX
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_try_moving_extra_data XML::Twig::Elt::_try_moving_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_twig_through_cut XML::Twig::Elt::_twig_through_cut
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_unprotect_extra_data XML::Twig::Elt::_unprotect_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_unshift_extra_data_in_pcdata XML::Twig::Elt::_unshift_extra_data_in_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_utf8_ify XML::Twig::Elt::_utf8_ify
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_wrap_range XML::Twig::Elt::_wrap_range
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::_wrap_text XML::Twig::Elt::_wrap_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::add_att_to_class XML::Twig::Elt::add_att_to_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::add_id XML::Twig::Elt::add_id
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::add_tag_to_class XML::Twig::Elt::add_tag_to_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::add_to_class XML::Twig::Elt::add_to_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::after XML::Twig::Elt::after
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::all_children_are XML::Twig::Elt::all_children_are
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ancestors_or_self XML::Twig::Elt::ancestors_or_self
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::append_cdata XML::Twig::Elt::append_cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::append_extra_data XML::Twig::Elt::append_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::append_pcdata XML::Twig::Elt::append_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::att_exists XML::Twig::Elt::att_exists
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::att_names XML::Twig::Elt::att_names
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::att_nb XML::Twig::Elt::att_nb
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::att_to_class XML::Twig::Elt::att_to_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::att_to_field XML::Twig::Elt::att_to_field
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::att_xml_string XML::Twig::Elt::att_xml_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::atts XML::Twig::Elt::atts
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::before XML::Twig::Elt::before
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::cdata XML::Twig::Elt::cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::cdata_string XML::Twig::Elt::cdata_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::change_att_name XML::Twig::Elt::change_att_name
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::child XML::Twig::Elt::child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::child_matches XML::Twig::Elt::child_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::child_text XML::Twig::Elt::child_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::child_trimmed_text XML::Twig::Elt::child_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::children_copy XML::Twig::Elt::children_copy
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::children_count XML::Twig::Elt::children_count
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::children_text XML::Twig::Elt::children_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::children_trimmed_text XML::Twig::Elt::children_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::class XML::Twig::Elt::class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::closed XML::Twig::Elt::closed
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::comment XML::Twig::Elt::comment
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::comment_string XML::Twig::Elt::comment_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::contains_a_single XML::Twig::Elt::contains_a_single
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::contains_only XML::Twig::Elt::contains_only
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::contains_only_text XML::Twig::Elt::contains_only_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::contains_text XML::Twig::Elt::contains_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::copy XML::Twig::Elt::copy
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::current_ns_prefixes XML::Twig::Elt::current_ns_prefixes
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::cut_children XML::Twig::Elt::cut_children
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::cut_descendants XML::Twig::Elt::cut_descendants
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::data XML::Twig::Elt::data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::declare_missing_ns XML::Twig::Elt::declare_missing_ns
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::del_att XML::Twig::Elt::del_att
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::del_atts XML::Twig::Elt::del_atts
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::del_id XML::Twig::Elt::del_id
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::del_twig_current XML::Twig::Elt::del_twig_current
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::descendants_or_self XML::Twig::Elt::descendants_or_self
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::do_not_escape_gt XML::Twig::Elt::do_not_escape_gt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::end_tag XML::Twig::Elt::end_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ent XML::Twig::Elt::ent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ent_name XML::Twig::Elt::ent_name
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ent_string XML::Twig::Elt::ent_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::erase XML::Twig::Elt::erase
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::escape_gt XML::Twig::Elt::escape_gt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::extra_data XML::Twig::Elt::extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::field_to_att XML::Twig::Elt::field_to_att
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::fields XML::Twig::Elt::fields
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::findvalue XML::Twig::Elt::findvalue
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::findvalues XML::Twig::Elt::findvalues
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::first_child_matches XML::Twig::Elt::first_child_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::first_child_text XML::Twig::Elt::first_child_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::first_child_trimmed_text XML::Twig::Elt::first_child_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::first_descendant XML::Twig::Elt::first_descendant
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::flush XML::Twig::Elt::flush
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::following_elt XML::Twig::Elt::following_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::following_elts XML::Twig::Elt::following_elts
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::former_next_sibling XML::Twig::Elt::former_next_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::former_parent XML::Twig::Elt::former_parent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::former_prev_sibling XML::Twig::Elt::former_prev_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ge XML::Twig::Elt::ge
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::getChildNodes XML::Twig::Elt::getChildNodes
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::getElementById XML::Twig::Elt::getElementById
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::get_type XML::Twig::Elt::get_type
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::global_state XML::Twig::Elt::global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::gt XML::Twig::Elt::gt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::has_no_atts XML::Twig::Elt::has_no_atts
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::id XML::Twig::Elt::id
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ignore XML::Twig::Elt::ignore
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::in_class XML::Twig::Elt::in_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::in_context XML::Twig::Elt::in_context
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::inherit_att XML::Twig::Elt::inherit_att
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::init_global_state XML::Twig::Elt::init_global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::insert XML::Twig::Elt::insert
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::insert_new_elt XML::Twig::Elt::insert_new_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_asis XML::Twig::Elt::is_asis
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_cdata XML::Twig::Elt::is_cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_comment XML::Twig::Elt::is_comment
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_empty XML::Twig::Elt::is_empty
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_ent XML::Twig::Elt::is_ent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_first_child XML::Twig::Elt::is_first_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_last_child XML::Twig::Elt::is_last_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_pcdata XML::Twig::Elt::is_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_pi XML::Twig::Elt::is_pi
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::is_text XML::Twig::Elt::is_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::last_child XML::Twig::Elt::last_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::last_child_matches XML::Twig::Elt::last_child_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::last_child_text XML::Twig::Elt::last_child_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::last_child_trimmed_text XML::Twig::Elt::last_child_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::last_descendant XML::Twig::Elt::last_descendant
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::latt XML::Twig::Elt::latt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::lc_attnames XML::Twig::Elt::lc_attnames
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::lclass XML::Twig::Elt::lclass
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::le XML::Twig::Elt::le
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::level XML::Twig::Elt::level
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::local_name XML::Twig::Elt::local_name
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::lt XML::Twig::Elt::lt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::mark XML::Twig::Elt::mark
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::merge XML::Twig::Elt::merge
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::merge_text XML::Twig::Elt::merge_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::move XML::Twig::Elt::move
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::move_att_to_class XML::Twig::Elt::move_att_to_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::namespace XML::Twig::Elt::namespace
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_elt_matches XML::Twig::Elt::next_elt_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_elt_text XML::Twig::Elt::next_elt_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_elt_trimmed_text XML::Twig::Elt::next_elt_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_n_elt XML::Twig::Elt::next_n_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_sibling_matches XML::Twig::Elt::next_sibling_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_sibling_text XML::Twig::Elt::next_sibling_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_sibling_trimmed_text XML::Twig::Elt::next_sibling_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::next_siblings XML::Twig::Elt::next_siblings
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::normalize XML::Twig::Elt::normalize
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::ns_prefix XML::Twig::Elt::ns_prefix
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::output_filter XML::Twig::Elt::output_filter
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::output_text_filter XML::Twig::Elt::output_text_filter
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::parent XML::Twig::Elt::parent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::parent_matches XML::Twig::Elt::parent_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::parent_text XML::Twig::Elt::parent_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::parent_trimmed_text XML::Twig::Elt::parent_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::parse XML::Twig::Elt::parse
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::paste XML::Twig::Elt::paste
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::paste_after XML::Twig::Elt::paste_after
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::paste_before XML::Twig::Elt::paste_before
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::paste_first_child XML::Twig::Elt::paste_first_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::paste_last_child XML::Twig::Elt::paste_last_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::paste_within XML::Twig::Elt::paste_within
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::path XML::Twig::Elt::path
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::pcdata XML::Twig::Elt::pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::pcdata_xml_string XML::Twig::Elt::pcdata_xml_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::pi_string XML::Twig::Elt::pi_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::pos XML::Twig::Elt::pos
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::preceding_elt XML::Twig::Elt::preceding_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::preceding_elts XML::Twig::Elt::preceding_elts
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prefix XML::Twig::Elt::prefix
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_elt XML::Twig::Elt::prev_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_elt_matches XML::Twig::Elt::prev_elt_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_elt_text XML::Twig::Elt::prev_elt_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_elt_trimmed_text XML::Twig::Elt::prev_elt_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_sibling XML::Twig::Elt::prev_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_sibling_matches XML::Twig::Elt::prev_sibling_matches
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_sibling_text XML::Twig::Elt::prev_sibling_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_sibling_trimmed_text XML::Twig::Elt::prev_sibling_trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::prev_siblings XML::Twig::Elt::prev_siblings
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::print XML::Twig::Elt::print
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::print_to_file XML::Twig::Elt::print_to_file
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::purge XML::Twig::Elt::purge
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::remove_cdata XML::Twig::Elt::remove_cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::remove_class XML::Twig::Elt::remove_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::replace XML::Twig::Elt::replace
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::replace_with XML::Twig::Elt::replace_with
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::reset_cond_cache XML::Twig::Elt::reset_cond_cache
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::safe_print_to_file XML::Twig::Elt::safe_print_to_file
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_asis XML::Twig::Elt::set_asis
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_att XML::Twig::Elt::set_att
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_cdata XML::Twig::Elt::set_cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_class XML::Twig::Elt::set_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_comment XML::Twig::Elt::set_comment
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_content XML::Twig::Elt::set_content
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_data XML::Twig::Elt::set_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_empty XML::Twig::Elt::set_empty
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_empty_tag_style XML::Twig::Elt::set_empty_tag_style
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_ent XML::Twig::Elt::set_ent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_extra_data XML::Twig::Elt::set_extra_data
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_field XML::Twig::Elt::set_field
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_first_child XML::Twig::Elt::set_first_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_global_state XML::Twig::Elt::set_global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_id XML::Twig::Elt::set_id
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_id_seed XML::Twig::Elt::set_id_seed
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_indent XML::Twig::Elt::set_indent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_inner_html XML::Twig::Elt::set_inner_html
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_inner_xml XML::Twig::Elt::set_inner_xml
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_last_child XML::Twig::Elt::set_last_child
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_next_sibling XML::Twig::Elt::set_next_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_not_asis XML::Twig::Elt::set_not_asis
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_not_empty XML::Twig::Elt::set_not_empty
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_ns_as_default XML::Twig::Elt::set_ns_as_default
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_ns_decl XML::Twig::Elt::set_ns_decl
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_outer_xml XML::Twig::Elt::set_outer_xml
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_parent XML::Twig::Elt::set_parent
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_pcdata XML::Twig::Elt::set_pcdata
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_pi XML::Twig::Elt::set_pi
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_pretty_print XML::Twig::Elt::set_pretty_print
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_prev_sibling XML::Twig::Elt::set_prev_sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_replaced_ents XML::Twig::Elt::set_replaced_ents
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_tag_class XML::Twig::Elt::set_tag_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_target XML::Twig::Elt::set_target
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_text XML::Twig::Elt::set_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_twig_current XML::Twig::Elt::set_twig_current
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::set_wrap XML::Twig::Elt::set_wrap
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sibling XML::Twig::Elt::sibling
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sibling_text XML::Twig::Elt::sibling_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::siblings XML::Twig::Elt::siblings
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::simplify XML::Twig::Elt::simplify
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sort_children XML::Twig::Elt::sort_children
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sort_children_on_att XML::Twig::Elt::sort_children_on_att
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sort_children_on_field XML::Twig::Elt::sort_children_on_field
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sort_children_on_value XML::Twig::Elt::sort_children_on_value
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::split XML::Twig::Elt::split
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::split_at XML::Twig::Elt::split_at
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::sprint XML::Twig::Elt::sprint
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::start_tag XML::Twig::Elt::start_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::strip_att XML::Twig::Elt::strip_att
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::subs_text XML::Twig::Elt::subs_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::suffix XML::Twig::Elt::suffix
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::tag_to_class XML::Twig::Elt::tag_to_class
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::tag_to_div XML::Twig::Elt::tag_to_div
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::tag_to_span XML::Twig::Elt::tag_to_span
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::target XML::Twig::Elt::target
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::text_only XML::Twig::Elt::text_only
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::toSAX1 XML::Twig::Elt::toSAX1
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::toSAX2 XML::Twig::Elt::toSAX2
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::trim XML::Twig::Elt::trim
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::trimmed_text XML::Twig::Elt::trimmed_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::wrap_children XML::Twig::Elt::wrap_children
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::wrap_in XML::Twig::Elt::wrap_in
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::xml_string XML::Twig::Elt::xml_string
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::xml_text XML::Twig::Elt::xml_text
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::xml_text_only XML::Twig::Elt::xml_text_only
0 | 0 | 0 | 0s | 0s | XML::Twig::Elt::::xpath XML::Twig::Elt::xpath
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::_dump XML::Twig::Entity::_dump
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::_quoted_val XML::Twig::Entity::_quoted_val
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::name XML::Twig::Entity::name
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::ndata XML::Twig::Entity::ndata
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::new XML::Twig::Entity::new
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::param XML::Twig::Entity::param
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::print XML::Twig::Entity::print
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::pubid XML::Twig::Entity::pubid
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::sprint XML::Twig::Entity::sprint
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::sysid XML::Twig::Entity::sysid
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::text XML::Twig::Entity::text
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity::::val XML::Twig::Entity::val
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::_add_list XML::Twig::Entity_list::_add_list
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::add XML::Twig::Entity_list::add
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::add_new_ent XML::Twig::Entity_list::add_new_ent
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::delete XML::Twig::Entity_list::delete
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::ent XML::Twig::Entity_list::ent
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::entity_names XML::Twig::Entity_list::entity_names
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::list XML::Twig::Entity_list::list
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::print XML::Twig::Entity_list::print
0 | 0 | 0 | 0s | 0s | XML::Twig::Entity_list::::text XML::Twig::Entity_list::text
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::_dump XML::Twig::Notation::_dump
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::_quoted_val XML::Twig::Notation::_quoted_val
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::base XML::Twig::Notation::base
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::name XML::Twig::Notation::name
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::new XML::Twig::Notation::new
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::print XML::Twig::Notation::print
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::pubid XML::Twig::Notation::pubid
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::sysid XML::Twig::Notation::sysid
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation::::text XML::Twig::Notation::text
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::_add_listXML::Twig::Notation_list::_add_list
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::addXML::Twig::Notation_list::add
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::add_new_notationXML::Twig::Notation_list::add_new_notation
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::deleteXML::Twig::Notation_list::delete
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::listXML::Twig::Notation_list::list
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::notationXML::Twig::Notation_list::notation
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::notation_namesXML::Twig::Notation_list::notation_names
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::printXML::Twig::Notation_list::print
0 | 0 | 0 | 0s | 0s | XML::Twig::Notation_list::::textXML::Twig::Notation_list::text
0 | 0 | 0 | 0s | 0s | XML::Twig::::_DTD_toSAX XML::Twig::_DTD_toSAX
0 | 0 | 0 | 0s | 0s | XML::Twig::::_XmlUtf8Decode XML::Twig::_XmlUtf8Decode
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:1183] XML::Twig::__ANON__[:1183]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:1415] XML::Twig::__ANON__[:1415]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:1591] XML::Twig::__ANON__[:1591]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:1607] XML::Twig::__ANON__[:1607]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:2115] XML::Twig::__ANON__[:2115]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:278] XML::Twig::__ANON__[:278]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:297] XML::Twig::__ANON__[:297]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:313] XML::Twig::__ANON__[:313]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:332] XML::Twig::__ANON__[:332]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:3599] XML::Twig::__ANON__[:3599]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:3629] XML::Twig::__ANON__[:3629]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:3657] XML::Twig::__ANON__[:3657]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:3856] XML::Twig::__ANON__[:3856]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:4358] XML::Twig::__ANON__[:4358]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:4368] XML::Twig::__ANON__[:4368]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:505] XML::Twig::__ANON__[:505]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:544] XML::Twig::__ANON__[:544]
0 | 0 | 0 | 0s | 0s | XML::Twig::::__ANON__[:814] XML::Twig::__ANON__[:814]
0 | 0 | 0 | 0s | 0s | XML::Twig::::_add_cpi_outside_of_root XML::Twig::_add_cpi_outside_of_root
0 | 0 | 0 | 0s | 0s | XML::Twig::::_allow_use XML::Twig::_allow_use
0 | 0 | 0 | 0s | 0s | XML::Twig::::_as_XML XML::Twig::_as_XML
0 | 0 | 0 | 0s | 0s | XML::Twig::::_based_filename XML::Twig::_based_filename
0 | 0 | 0 | 0s | 0s | XML::Twig::::_check_xml XML::Twig::_check_xml
0 | 0 | 0 | 0s | 0s | XML::Twig::::_children XML::Twig::_children
0 | 0 | 0 | 0s | 0s | XML::Twig::::_comment_elt_handler XML::Twig::_comment_elt_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_comment_text_handler XML::Twig::_comment_text_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_croak XML::Twig::_croak
0 | 0 | 0 | 0s | 0s | XML::Twig::::_disallow_use XML::Twig::_disallow_use
0 | 0 | 0 | 0s | 0s | XML::Twig::::_dump XML::Twig::_dump
0 | 0 | 0 | 0s | 0s | XML::Twig::::_encoding_filter XML::Twig::_encoding_filter
0 | 0 | 0 | 0s | 0s | XML::Twig::::_encoding_from_meta XML::Twig::_encoding_from_meta
0 | 0 | 0 | 0s | 0s | XML::Twig::::_fill_default_atts XML::Twig::_fill_default_atts
0 | 0 | 0 | 0s | 0s | XML::Twig::::_first_n XML::Twig::_first_n
0 | 0 | 0 | 0s | 0s | XML::Twig::::_fix_xml XML::Twig::_fix_xml
0 | 0 | 0 | 0s | 0s | XML::Twig::::_flush_toSAX XML::Twig::_flush_toSAX
0 | 0 | 0 | 0s | 0s | XML::Twig::::_html2xml XML::Twig::_html2xml
0 | 0 | 0 | 0s | 0s | XML::Twig::::_indent_xhtml XML::Twig::_indent_xhtml
0 | 0 | 0 | 0s | 0s | XML::Twig::::_is_fh XML::Twig::_is_fh
0 | 0 | 0 | 0s | 0s | XML::Twig::::_is_well_formed_xml XML::Twig::_is_well_formed_xml
0 | 0 | 0 | 0s | 0s | XML::Twig::::_leading_cpi XML::Twig::_leading_cpi
0 | 0 | 0 | 0s | 0s | XML::Twig::::_level_in_stack XML::Twig::_level_in_stack
0 | 0 | 0 | 0s | 0s | XML::Twig::::_output_ignored XML::Twig::_output_ignored
0 | 0 | 0 | 0s | 0s | XML::Twig::::_parse_as_xml_or_html XML::Twig::_parse_as_xml_or_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::_parse_inplace XML::Twig::_parse_inplace
0 | 0 | 0 | 0s | 0s | XML::Twig::::_parse_predicate_in_handler XML::Twig::_parse_predicate_in_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_parse_start_tag XML::Twig::_parse_start_tag
0 | 0 | 0 | 0s | 0s | XML::Twig::::_parseurl XML::Twig::_parseurl
0 | 0 | 0 | 0s | 0s | XML::Twig::::_pass_url_content XML::Twig::_pass_url_content
0 | 0 | 0 | 0s | 0s | XML::Twig::::_pi_elt_handlers XML::Twig::_pi_elt_handlers
0 | 0 | 0 | 0s | 0s | XML::Twig::::_pi_text_handler XML::Twig::_pi_text_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_pretty_print_styles XML::Twig::_pretty_print_styles
0 | 0 | 0 | 0s | 0s | XML::Twig::::_prolog_toSAX XML::Twig::_prolog_toSAX
0 | 0 | 0 | 0s | 0s | XML::Twig::::_reset_twig XML::Twig::_reset_twig
0 | 0 | 0 | 0s | 0s | XML::Twig::::_reset_twig_after_error XML::Twig::_reset_twig_after_error
0 | 0 | 0 | 0s | 0s | XML::Twig::::_return_debug_handler XML::Twig::_return_debug_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_set_debug_handler XML::Twig::_set_debug_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_set_weakrefs XML::Twig::_set_weakrefs
0 | 0 | 0 | 0s | 0s | XML::Twig::::_slurp XML::Twig::_slurp
0 | 0 | 0 | 0s | 0s | XML::Twig::::_slurp_fh XML::Twig::_slurp_fh
0 | 0 | 0 | 0s | 0s | XML::Twig::::_slurp_uri XML::Twig::_slurp_uri
0 | 0 | 0 | 0s | 0s | XML::Twig::::_space_policy XML::Twig::_space_policy
0 | 0 | 0 | 0s | 0s | XML::Twig::::_this_perl XML::Twig::_this_perl
0 | 0 | 0 | 0s | 0s | XML::Twig::::_tidy_html XML::Twig::_tidy_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::_toSAX XML::Twig::_toSAX
0 | 0 | 0 | 0s | 0s | XML::Twig::::_to_utf8 XML::Twig::_to_utf8
0 | 0 | 0 | 0s | 0s | XML::Twig::::_trailing_cpi XML::Twig::_trailing_cpi
0 | 0 | 0 | 0s | 0s | XML::Twig::::_trailing_cpi_text XML::Twig::_trailing_cpi_text
0 | 0 | 0 | 0s | 0s | XML::Twig::::_trigger_tdh XML::Twig::_trigger_tdh
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_attlist XML::Twig::_twig_attlist
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_cdataend XML::Twig::_twig_cdataend
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_cdatastart XML::Twig::_twig_cdatastart
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_comment XML::Twig::_twig_comment
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_doctype XML::Twig::_twig_doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_doctype_fin_print XML::Twig::_twig_doctype_fin_print
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_element XML::Twig::_twig_element
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_entity XML::Twig::_twig_entity
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_extern_ent XML::Twig::_twig_extern_ent
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_ignore_end XML::Twig::_twig_ignore_end
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_ignore_start XML::Twig::_twig_ignore_start
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_insert_ent XML::Twig::_twig_insert_ent
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_notation XML::Twig::_twig_notation
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_pi XML::Twig::_twig_pi
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_pi_check_roots XML::Twig::_twig_pi_check_roots
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_pi_comment XML::Twig::_twig_pi_comment
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print XML::Twig::_twig_print
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_check_doctype XML::Twig::_twig_print_check_doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_doctype XML::Twig::_twig_print_doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_end_original XML::Twig::_twig_print_end_original
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_entity XML::Twig::_twig_print_entity
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_original XML::Twig::_twig_print_original
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_original_check_doctype XML::Twig::_twig_print_original_check_doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_original_default XML::Twig::_twig_print_original_default
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_print_original_doctype XML::Twig::_twig_print_original_doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_stop_storing_internal_dtd XML::Twig::_twig_stop_storing_internal_dtd
0 | 0 | 0 | 0s | 0s | XML::Twig::::_twig_store_internal_dtd XML::Twig::_twig_store_internal_dtd
0 | 0 | 0 | 0s | 0s | XML::Twig::::_unescape_cdata XML::Twig::_unescape_cdata
0 | 0 | 0 | 0s | 0s | XML::Twig::::_use_perlio XML::Twig::_use_perlio
0 | 0 | 0 | 0s | 0s | XML::Twig::::_warn_debug_handler XML::Twig::_warn_debug_handler
0 | 0 | 0 | 0s | 0s | XML::Twig::::_weakrefs XML::Twig::_weakrefs
0 | 0 | 0 | 0s | 0s | XML::Twig::::_xml_escape XML::Twig::_xml_escape
0 | 0 | 0 | 0s | 0s | XML::Twig::::_xml_parser_encodings XML::Twig::_xml_parser_encodings
0 | 0 | 0 | 0s | 0s | XML::Twig::::_xmldecl_toSAX XML::Twig::_xmldecl_toSAX
0 | 0 | 0 | 0s | 0s | XML::Twig::::active_twig XML::Twig::active_twig
0 | 0 | 0 | 0s | 0s | XML::Twig::::add_options XML::Twig::add_options
0 | 0 | 0 | 0s | 0s | XML::Twig::::add_stylesheet XML::Twig::add_stylesheet
0 | 0 | 0 | 0s | 0s | XML::Twig::::att_accessors XML::Twig::att_accessors
0 | 0 | 0 | 0s | 0s | XML::Twig::::change_gi XML::Twig::change_gi
0 | 0 | 0 | 0s | 0s | XML::Twig::::child XML::Twig::child
0 | 0 | 0 | 0s | 0s | XML::Twig::::children XML::Twig::children
0 | 0 | 0 | 0s | 0s | XML::Twig::::dispose XML::Twig::dispose
0 | 0 | 0 | 0s | 0s | XML::Twig::::do_not_escape_gt XML::Twig::do_not_escape_gt
0 | 0 | 0 | 0s | 0s | XML::Twig::::doctype XML::Twig::doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::doctype_name XML::Twig::doctype_name
0 | 0 | 0 | 0s | 0s | XML::Twig::::dtd XML::Twig::dtd
0 | 0 | 0 | 0s | 0s | XML::Twig::::dtd_print XML::Twig::dtd_print
0 | 0 | 0 | 0s | 0s | XML::Twig::::dtd_text XML::Twig::dtd_text
0 | 0 | 0 | 0s | 0s | XML::Twig::::elt_accessors XML::Twig::elt_accessors
0 | 0 | 0 | 0s | 0s | XML::Twig::::elt_id XML::Twig::elt_id
0 | 0 | 0 | 0s | 0s | XML::Twig::::encode_convert XML::Twig::encode_convert
0 | 0 | 0 | 0s | 0s | XML::Twig::::encoding XML::Twig::encoding
0 | 0 | 0 | 0s | 0s | XML::Twig::::entity XML::Twig::entity
0 | 0 | 0 | 0s | 0s | XML::Twig::::entity_list XML::Twig::entity_list
0 | 0 | 0 | 0s | 0s | XML::Twig::::entity_names XML::Twig::entity_names
0 | 0 | 0 | 0s | 0s | XML::Twig::::escape_gt XML::Twig::escape_gt
0 | 0 | 0 | 0s | 0s | XML::Twig::::field_accessors XML::Twig::field_accessors
0 | 0 | 0 | 0s | 0s | XML::Twig::::findvalue XML::Twig::findvalue
0 | 0 | 0 | 0s | 0s | XML::Twig::::findvalues XML::Twig::findvalues
0 | 0 | 0 | 0s | 0s | XML::Twig::::finish XML::Twig::finish
0 | 0 | 0 | 0s | 0s | XML::Twig::::finish_now XML::Twig::finish_now
0 | 0 | 0 | 0s | 0s | XML::Twig::::finish_print XML::Twig::finish_print
0 | 0 | 0 | 0s | 0s | XML::Twig::::first_elt XML::Twig::first_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::::flush XML::Twig::flush
0 | 0 | 0 | 0s | 0s | XML::Twig::::flush_toSAX1 XML::Twig::flush_toSAX1
0 | 0 | 0 | 0s | 0s | XML::Twig::::flush_toSAX2 XML::Twig::flush_toSAX2
0 | 0 | 0 | 0s | 0s | XML::Twig::::flush_up_to XML::Twig::flush_up_to
0 | 0 | 0 | 0s | 0s | XML::Twig::::getChildNodes XML::Twig::getChildNodes
0 | 0 | 0 | 0s | 0s | XML::Twig::::getParentNode XML::Twig::getParentNode
0 | 0 | 0 | 0s | 0s | XML::Twig::::getRootNode XML::Twig::getRootNode
0 | 0 | 0 | 0s | 0s | XML::Twig::::global_state XML::Twig::global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::::html_encode XML::Twig::html_encode
0 | 0 | 0 | 0s | 0s | XML::Twig::::iconv_convert XML::Twig::iconv_convert
0 | 0 | 0 | 0s | 0s | XML::Twig::::ignore XML::Twig::ignore
0 | 0 | 0 | 0s | 0s | XML::Twig::::index XML::Twig::index
0 | 0 | 0 | 0s | 0s | XML::Twig::::internal_subset XML::Twig::internal_subset
0 | 0 | 0 | 0s | 0s | XML::Twig::::keep_atts_order XML::Twig::keep_atts_order
0 | 0 | 0 | 0s | 0s | XML::Twig::::last_elt XML::Twig::last_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::::latin1 XML::Twig::latin1
0 | 0 | 0 | 0s | 0s | XML::Twig::::model XML::Twig::model
0 | 0 | 0 | 0s | 0s | XML::Twig::::next_n_elt XML::Twig::next_n_elt
0 | 0 | 0 | 0s | 0s | XML::Twig::::normalize XML::Twig::normalize
0 | 0 | 0 | 0s | 0s | XML::Twig::::notation XML::Twig::notation
0 | 0 | 0 | 0s | 0s | XML::Twig::::notation_list XML::Twig::notation_list
0 | 0 | 0 | 0s | 0s | XML::Twig::::notation_names XML::Twig::notation_names
0 | 0 | 0 | 0s | 0s | XML::Twig::::nparse XML::Twig::nparse
0 | 0 | 0 | 0s | 0s | XML::Twig::::nparse_e XML::Twig::nparse_e
0 | 0 | 0 | 0s | 0s | XML::Twig::::nparse_pp XML::Twig::nparse_pp
0 | 0 | 0 | 0s | 0s | XML::Twig::::nparse_ppe XML::Twig::nparse_ppe
0 | 0 | 0 | 0s | 0s | XML::Twig::::original_uri XML::Twig::original_uri
0 | 0 | 0 | 0s | 0s | XML::Twig::::output_encoding XML::Twig::output_encoding
0 | 0 | 0 | 0s | 0s | XML::Twig::::output_filter XML::Twig::output_filter
0 | 0 | 0 | 0s | 0s | XML::Twig::::output_text_filter XML::Twig::output_text_filter
0 | 0 | 0 | 0s | 0s | XML::Twig::::parse_html XML::Twig::parse_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::parsefile XML::Twig::parsefile
0 | 0 | 0 | 0s | 0s | XML::Twig::::parsefile_html XML::Twig::parsefile_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::parsefile_html_inplace XML::Twig::parsefile_html_inplace
0 | 0 | 0 | 0s | 0s | XML::Twig::::parsefile_inplace XML::Twig::parsefile_inplace
0 | 0 | 0 | 0s | 0s | XML::Twig::::parseurl XML::Twig::parseurl
0 | 0 | 0 | 0s | 0s | XML::Twig::::parseurl_html XML::Twig::parseurl_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::path XML::Twig::path
0 | 0 | 0 | 0s | 0s | XML::Twig::::print XML::Twig::print
0 | 0 | 0 | 0s | 0s | XML::Twig::::print_prolog XML::Twig::print_prolog
0 | 0 | 0 | 0s | 0s | XML::Twig::::print_to_file XML::Twig::print_to_file
0 | 0 | 0 | 0s | 0s | XML::Twig::::prolog XML::Twig::prolog
0 | 0 | 0 | 0s | 0s | XML::Twig::::public_id XML::Twig::public_id
0 | 0 | 0 | 0s | 0s | XML::Twig::::purge_up_to XML::Twig::purge_up_to
0 | 0 | 0 | 0s | 0s | XML::Twig::::regexp2latin1 XML::Twig::regexp2latin1
0 | 0 | 0 | 0s | 0s | XML::Twig::::restore_global_state XML::Twig::restore_global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_encode XML::Twig::safe_encode
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_encode_hex XML::Twig::safe_encode_hex
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_parse XML::Twig::safe_parse
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_parse_html XML::Twig::safe_parse_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_parsefile XML::Twig::safe_parsefile
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_parsefile_html XML::Twig::safe_parsefile_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_parseurl XML::Twig::safe_parseurl
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_parseurl_html XML::Twig::safe_parseurl_html
0 | 0 | 0 | 0s | 0s | XML::Twig::::safe_print_to_file XML::Twig::safe_print_to_file
0 | 0 | 0 | 0s | 0s | XML::Twig::::save_global_state XML::Twig::save_global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::::setCharHandler XML::Twig::setCharHandler
0 | 0 | 0 | 0s | 0s | XML::Twig::::setEndTagHandler XML::Twig::setEndTagHandler
0 | 0 | 0 | 0s | 0s | XML::Twig::::setEndTagHandlers XML::Twig::setEndTagHandlers
0 | 0 | 0 | 0s | 0s | XML::Twig::::setIgnoreEltsHandler XML::Twig::setIgnoreEltsHandler
0 | 0 | 0 | 0s | 0s | XML::Twig::::setIgnoreEltsHandlers XML::Twig::setIgnoreEltsHandlers
0 | 0 | 0 | 0s | 0s | XML::Twig::::setStartTagHandler XML::Twig::setStartTagHandler
0 | 0 | 0 | 0s | 0s | XML::Twig::::setStartTagHandlers XML::Twig::setStartTagHandlers
0 | 0 | 0 | 0s | 0s | XML::Twig::::setTwigHandler XML::Twig::setTwigHandler
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_doctype XML::Twig::set_doctype
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_empty_tag_style XML::Twig::set_empty_tag_style
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_encoding XML::Twig::set_encoding
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_global_state XML::Twig::set_global_state
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_id_seed XML::Twig::set_id_seed
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_indent XML::Twig::set_indent
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_input_filter XML::Twig::set_input_filter
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_output_encoding XML::Twig::set_output_encoding
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_pretty_print XML::Twig::set_pretty_print
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_standalone XML::Twig::set_standalone
0 | 0 | 0 | 0s | 0s | XML::Twig::::set_xml_version XML::Twig::set_xml_version
0 | 0 | 0 | 0s | 0s | XML::Twig::::simplify XML::Twig::simplify
0 | 0 | 0 | 0s | 0s | XML::Twig::::sprint XML::Twig::sprint
0 | 0 | 0 | 0s | 0s | XML::Twig::::standalone XML::Twig::standalone
0 | 0 | 0 | 0s | 0s | XML::Twig::::subs_text XML::Twig::subs_text
0 | 0 | 0 | 0s | 0s | XML::Twig::::system_id XML::Twig::system_id
0 | 0 | 0 | 0s | 0s | XML::Twig::::toSAX1 XML::Twig::toSAX1
0 | 0 | 0 | 0s | 0s | XML::Twig::::toSAX2 XML::Twig::toSAX2
0 | 0 | 0 | 0s | 0s | XML::Twig::::trim XML::Twig::trim
0 | 0 | 0 | 0s | 0s | XML::Twig::::unicode_convert XML::Twig::unicode_convert
0 | 0 | 0 | 0s | 0s | XML::Twig::::xml_version XML::Twig::xml_version
0 | 0 | 0 | 0s | 0s | XML::Twig::::xmldecl XML::Twig::xmldecl
0 | 0 | 0 | 0s | 0s | XML::Twig::::xparse XML::Twig::xparse
0 | 0 | 0 | 0s | 0s | main::::CDATA main::CDATA
0 | 0 | 0 | 0s | 0s | main::::PCDATA main::PCDATA

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 | 2 | 17µs | 2 | 11µs | # spent 10µs (8+2) within Spreadsheet::ParseXLSX::BEGIN@1 which was called: # once (8µs+2µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 1 use strict; # spent 10µs making 1 call to Spreadsheet::ParseXLSX::BEGIN@1 # spent 2µs making 1 call to strict::import
2 | 2 | 29µs | 2 | 32µs | # spent 18µs (4+14) within Spreadsheet::ParseXLSX::BEGIN@2 which was called: # once (4µs+14µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 2 use warnings; # > perl 5.5 # spent 18µs making 1 call to Spreadsheet::ParseXLSX::BEGIN@2 # spent 14µs making 1 call to warnings::import
3 |  |  |  |  |
4 |  |  |  |  | # This is created in the caller's space
5 |  |  |  |  | # I realize (now!) that it's not clean, but it's been there for 10+ years...
6 |  |  |  |  | BEGIN
7 |  |  |  |  | # spent 1µs within Spreadsheet::ParseXLSX::BEGIN@7 which was called: # once (1µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 9 { sub ::PCDATA { '#PCDATA' } ## no critic (Subroutines::ProhibitNestedSubs);
8 |  |  |  |  | sub ::CDATA { '#CDATA' } ## no critic (Subroutines::ProhibitNestedSubs);
9 | 1 | 8µs | 1 | 1µs | } # spent 1µs making 1 call to Spreadsheet::ParseXLSX::BEGIN@7
10 |  |  |  |  |
11 | 2 | 106µs | 1 | 81µs | # spent 81µs within Spreadsheet::ParseXLSX::BEGIN@11.2 which was called: # once (81µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 11 use UNIVERSAL(); # spent 81µs making 1 call to Spreadsheet::ParseXLSX::BEGIN@11.2
12 |  |  |  |  |
13 |  |  |  |  | ## if a sub returns a scalar, it better not bloody disappear in list context
14 |  |  |  |  | ## no critic (Subroutines::ProhibitExplicitReturnUndef);
15 |  |  |  |  |
16 | 1 | 300ns |  |  | my $perl_version;
17 |  |  |  |  | my $parser_version;
18 |  |  |  |  |
19 |  |  |  |  | ######################################################################
20 |  |  |  |  | package XML::Twig;
21 |  |  |  |  | ######################################################################
22 |  |  |  |  |
23 | 1 | 12µs |  |  | require 5.004;
24 |  |  |  |  |
25 | 2 | 67µs | 2 | 171µs | # spent 169µs (141+28) within XML::Twig::BEGIN@25 which was called: # once (141µs+28µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 25 use utf8; # > perl 5.5 # spent 169µs making 1 call to XML::Twig::BEGIN@25 # spent 2µs making 1 call to utf8::import
26 |  |  |  |  |
27 | 2 | 20µs | 2 | 52µs | # spent 28µs (4+24) within XML::Twig::BEGIN@27 which was called: # once (4µs+24µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 27 use vars qw($VERSION @ISA %valid_option); # spent 28µs making 1 call to XML::Twig::BEGIN@27 # spent 24µs making 1 call to vars::import
28 |  |  |  |  |
29 | 2 | 15µs | 2 | 44µs | # spent 24µs (5+19) within XML::Twig::BEGIN@29 which was called: # once (5µs+19µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 29 use Carp; # spent 24µs making 1 call to XML::Twig::BEGIN@29 # spent 19µs making 1 call to Exporter::import
30 | 2 | 14µs | 2 | 8µs | # spent 8µs (7+700ns) within XML::Twig::BEGIN@30 which was called: # once (7µs+700ns) by Spreadsheet::ParseXLSX::BEGIN@15 at line 30 use File::Spec; # spent 8µs making 1 call to XML::Twig::BEGIN@30 # spent 700ns making 1 call to UNIVERSAL::import
31 | 2 | 14µs | 2 | 37µs | # spent 21µs (4+16) within XML::Twig::BEGIN@31 which was called: # once (4µs+16µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 31 use File::Basename; # spent 21µs making 1 call to XML::Twig::BEGIN@31 # spent 16µs making 1 call to Exporter::import
32 |  |  |  |  |
33 | 2 | 22µs | 2 | 16µs | # spent 10µs (4+6) within XML::Twig::BEGIN@33 which was called: # once (4µs+6µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 33 use Config; # to get perl's path name in case we need to know if perlio is available # spent 10µs making 1 call to XML::Twig::BEGIN@33 # spent 6µs making 1 call to Config::import
34 |  |  |  |  |
35 | 1 | 1µs |  |  | *isa= *UNIVERSAL::isa;
36 |  |  |  |  |
37 |  |  |  |  | # flag, set to true if the weaken sub is available
38 | 2 | 283µs | 2 | 23µs | # spent 14µs (4+9) within XML::Twig::BEGIN@38 which was called: # once (4µs+9µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 38 use vars qw( $weakrefs); # spent 14µs making 1 call to XML::Twig::BEGIN@38 # spent 9µs making 1 call to vars::import
39 |  |  |  |  |
40 |  |  |  |  | # flag set to true if the version of expat seems to be 1.95.2, which has annoying bugs
41 |  |  |  |  | # wrt doctype handling. This is global for performance reasons.
42 | 1 | 200ns |  |  | my $expat_1_95_2=0;
43 |  |  |  |  |
44 |  |  |  |  | # a slight non-xml mod: # is allowed as a first character
45 | 1 | 200ns |  |  | my $REG_TAG_FIRST_LETTER;
46 |  |  |  |  | #$REG_TAG_FIRST_LETTER= q{(?:[^\W\d]|[:#_])}; # < perl 5.6 - does not work for leading non-ascii letters
47 | 1 | 300ns |  |  | $REG_TAG_FIRST_LETTER= q{(?:[[:alpha:]:#_])}; # >= perl 5.6
48 |  |  |  |  |
49 | 1 | 200ns |  |  | my $REG_TAG_LETTER= q{(?:[\w_.-]*)};
50 |  |  |  |  |
51 |  |  |  |  | # a simple name (no colon)
52 | 1 | 500ns |  |  | my $REG_NAME_TOKEN= qq{(?:$REG_TAG_FIRST_LETTER$REG_TAG_LETTER*)};
53 |  |  |  |  |
54 |  |  |  |  | # a tag name, possibly including namespace
55 | 1 | 300ns |  |  | my $REG_NAME= qq{(?:(?:$REG_NAME_TOKEN:)?$REG_NAME_TOKEN)};
56 |  |  |  |  |
57 |  |  |  |  | # tag name (leading # allowed)
58 |  |  |  |  | # first line is for perl 5.005, second line for modern perl, that accept character classes
59 | 1 | 200ns |  |  | my $REG_TAG_NAME=$REG_NAME;
60 |  |  |  |  |
61 |  |  |  |  | # name or wildcard (* or '') (leading # allowed)
62 | 1 | 300ns |  |  | my $REG_NAME_W = qq{(?:$REG_NAME|[*])};
63 |  |  |  |  |
64 |  |  |  |  | # class and ids are deliberately permissive
65 | 1 | 100ns |  |  | my $REG_NTOKEN_FIRST_LETTER;
66 |  |  |  |  | #$REG_NTOKEN_FIRST_LETTER= q{(?:[^\W\d]|[:_])}; # < perl 5.6 - does not work for leading non-ascii letters
67 | 1 | 100ns |  |  | $REG_NTOKEN_FIRST_LETTER= q{(?:[[:alpha:]:_])}; # >= perl 5.6
68 |  |  |  |  |
69 | 1 | 200ns |  |  | my $REG_NTOKEN_LETTER= q{(?:[\w_:.-]*)};
70 |  |  |  |  |
71 | 1 | 200ns |  |  | my $REG_NTOKEN= qq{(?:$REG_NTOKEN_FIRST_LETTER$REG_NTOKEN_LETTER*)};
72 | 1 | 100ns |  |  | my $REG_CLASS = $REG_NTOKEN;
73 | 1 | 100ns |  |  | my $REG_ID = $REG_NTOKEN;
74 |  |  |  |  |
75 |  |  |  |  | # allow <tag> #<tag> (private elt) * <tag>.<class> *.<class> <tag>#<id> *#<id>
76 | 1 | 400ns |  |  | my $REG_TAG_PART= qq{(?:$REG_NAME_W(?:[.]$REG_CLASS|[#]$REG_ID)?|[.]$REG_CLASS)};
77 |  |  |  |  |
78 | 1 | 200ns |  |  | my $REG_REGEXP = q{(?:/(?:[^\\/]|\\.)*/[eimsox]*)}; # regexp
79 | 1 | 200ns |  |  | my $REG_MATCH = q{[!=]~}; # match (or not)
80 | 1 | 100ns |  |  | my $REG_STRING = q{(?:"(?:[^\\"]|\\.)*"|'(?:[^\\']|\\.)*')}; # string (simple or double quoted)
81 | 1 | 100ns |  |  | my $REG_NUMBER = q{(?:\d+(?:\.\d*)?|\.\d+)}; # number
82 | 1 | 200ns |  |  | my $REG_VALUE = qq{(?:$REG_STRING|$REG_NUMBER)}; # value
83 | 1 | 200ns |  |  | my $REG_OP = q{==|!=|>|<|>=|<=|eq|ne|lt|gt|le|ge|=}; # op
84 | 1 | 100ns |  |  | my $REG_FUNCTION = q{(?:string|text)\(\s*\)};
85 | 1 | 200ns |  |  | my $REG_STRING_ARG = qq{(?:string|text)\\(\\s*$REG_NAME_W\\s*\\)};
86 | 1 | 100ns |  |  | my $REG_COMP = q{(?:>=|<=|!=|<|>|=)};
87 |  |  |  |  |
88 | 1 | 200ns |  |  | my $REG_TAG_IN_PREDICATE= $REG_NAME_W . q{(?=\s*(?i:and\b|or\b|\]|$))};
89 |  |  |  |  |
90 |  |  |  |  | # keys in the context stack, chosen not to interfere with att names, even private (#-prefixed) ones
91 | 1 | 100ns |  |  | my $ST_TAG = '##tag';
92 | 1 | 100ns |  |  | my $ST_ELT = '##elt';
93 | 1 | 100ns |  |  | my $ST_NS = '##ns' ;
94 |  |  |  |  |
95 |  |  |  |  | # used in the handler trigger code
96 | 1 | 500ns |  |  | my $REG_NAKED_PREDICATE= qq{((?:"[^"]*"|'[^']*'|$REG_STRING_ARG|$REG_FUNCTION|\@$REG_NAME_W|$REG_MATCH\\s*$REG_REGEXP|[\\s\\d><=!()+.-]|(?i:and)|(?i:or)|$REG_TAG_IN_PREDICATE)*)};
97 | 1 | 200ns |  |  | my $REG_PREDICATE= qq{\\[$REG_NAKED_PREDICATE\\]};
98 |  |  |  |  |
99 |  |  |  |  | # not all axis, only supported ones (in get_xpath)
100 | 1 | 2µs |  |  | my @supported_axis= ( 'ancestor', 'ancestor-or-self', 'child', 'descendant', 'descendant-or-self',
101 |  |  |  |  | 'following', 'following-sibling', 'parent', 'preceding', 'preceding-sibling', 'self'
102 |  |  |  |  | );
103 | 1 | 1µs |  |  | my $REG_AXIS = "(?:" . join( '|', @supported_axis) .")";
104 |  |  |  |  |
105 |  |  |  |  | # only used in the "xpath"engine (for get_xpath/findnodes) for now
106 | 1 | 232µs | 2 | 226µs | my $REG_PREDICATE_ALT = qr{\[(?:(?:string\(\s*\)|\@$REG_TAG_NAME)\s*$REG_MATCH\s*$REG_REGEXP\s*|[^\]]*)\]}; # spent 224µs making 1 call to CORE::regcomp # spent 2µs making 1 call to CORE::qr
107 |  |  |  |  |
108 |  |  |  |  | # used to convert XPath tests on strings to the perl equivalent
109 | 1 | 2µs |  |  | my %PERL_ALPHA_TEST= ( '=' => ' eq ', '!=' => ' ne ', '>' => ' gt ', '>=' => ' ge ', '<' => ' lt ', '<=' => ' le ');
110 |  |  |  |  |
111 | 1 | 200ns |  |  | my( $FB_HTMLCREF, $FB_XMLCREF);
112 |  |  |  |  |
113 | 1 | 400ns |  |  | my $NO_WARNINGS= $perl_version >= 5.006 ? 'no warnings' : 'local $^W=0';
114 |  |  |  |  |
115 |  |  |  |  | # default namespaces, both ways
116 | 1 | 800ns |  |  | my %DEFAULT_NS= ( xml => "http://www.w3.org/XML/1998/namespace",
117 |  |  |  |  | xmlns => "http://www.w3.org/2000/xmlns/",
118 |  |  |  |  | );
119 | 1 | 3µs |  |  | my %DEFAULT_URI2NS= map { $DEFAULT_NS{$_} => $_ } keys %DEFAULT_NS;
120 |  |  |  |  |
121 |  |  |  |  | # constants
122 | 1 | 100ns |  |  | my( $PCDATA, $CDATA, $PI, $COMMENT, $ENT, $ELT, $NOTATION, $TEXT, $ASIS, $EMPTY, $BUFSIZE);
123 |  |  |  |  |
124 |  |  |  |  | # used when an HTML doc only has a PUBLIC declaration, to generate the SYSTEM one
125 |  |  |  |  | # this should really be done by HTML::TreeBuilder, but as of HTML::TreeBuilder 4.2 it isn't
126 |  |  |  |  | # the various declarations are taken from http://en.wikipedia.org/wiki/Document_Type_Declaration
127 | 1 | 4µs |  |  | my %HTML_DECL= ( "-//W3C//DTD HTML 4.0 Transitional//EN" => "http://www.w3.org/TR/REC-html40/loose.dtd",
128 |  |  |  |  | "-//W3C//DTD HTML 4.01//EN" => "http://www.w3.org/TR/html4/strict.dtd",
129 |  |  |  |  | "-//W3C//DTD HTML 4.01 Transitional//EN" => "http://www.w3.org/TR/html4/loose.dtd",
130 |  |  |  |  | "-//W3C//DTD HTML 4.01 Frameset//EN" => "http://www.w3.org/TR/html4/frameset.dtd",
131 |  |  |  |  | "-//W3C//DTD XHTML 1.0 Strict//EN" => "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd",
132 |  |  |  |  | "-//W3C//DTD XHTML 1.0 Transitional//EN" => "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd",
133 |  |  |  |  | "-//W3C//DTD XHTML 1.0 Frameset//EN" => "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd",
134 |  |  |  |  | "-//W3C//DTD XHTML 1.1//EN" => "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd",
135 |  |  |  |  | "-//W3C//DTD XHTML Basic 1.0//EN" => "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd",
136 |  |  |  |  | "-//W3C//DTD XHTML Basic 1.1//EN" => "http://www.w3.org/TR/xhtml-basic/xhtml-basic11.dtd",
137 |  |  |  |  | "-//WAPFORUM//DTD XHTML Mobile 1.0//EN" => "http://www.wapforum.org/DTD/xhtml-mobile10.dtd",
138 |  |  |  |  | "-//WAPFORUM//DTD XHTML Mobile 1.1//EN" => "http://www.openmobilealliance.org/tech/DTD/xhtml-mobile11.dtd",
139 |  |  |  |  | "-//WAPFORUM//DTD XHTML Mobile 1.2//EN" => "http://www.openmobilealliance.org/tech/DTD/xhtml-mobile12.dtd",
140 |  |  |  |  | "-//W3C//DTD XHTML+RDFa 1.0//EN" => "http://www.w3.org/MarkUp/DTD/xhtml-rdfa-1.dtd",
141 |  |  |  |  | );
142 |  |  |  |  |
143 | 1 | 100ns |  |  | my $DEFAULT_HTML_TYPE= "-//W3C//DTD HTML 4.0 Transitional//EN";
144 |  |  |  |  |
145 | 1 | 2µs | 1 | 800ns | my $SEP= qr/\s*(?:$|\|)/; # spent 800ns making 1 call to CORE::qr
146 |  |  |  |  |
147 |  |  |  |  | BEGIN
148 |  |  |  |  | # spent 240µs (79+162) within XML::Twig::BEGIN@148 which was called: # once (79µs+162µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 225 {
149 | 1 | 300ns |  |  | $VERSION = '3.52';
150 |  |  |  |  |
151 | 2 | 307µs | 2 | 3.56ms | # spent 3.56ms (1.01+2.55) within XML::Twig::BEGIN@151 which was called: # once (1.01ms+2.55ms) by Spreadsheet::ParseXLSX::BEGIN@15 at line 151 use XML::Parser; # spent 3.56ms making 1 call to XML::Twig::BEGIN@151 # spent 1µs making 1 call to UNIVERSAL::import
152 | 1 | 200ns |  |  | my $needVersion = '2.23';
153 | 1 | 7µs | 1 | 600ns | ($parser_version= $XML::Parser::VERSION)=~ s{_\d+}{}; # remove _<n> from version so numeric tests do not warn # spent 600ns making 1 call to CORE::subst
154 | 1 | 2µs |  |  | croak "need at least XML::Parser version $needVersion" unless $parser_version >= $needVersion;
155 |  |  |  |  |
156 | 1 | 2µs | 1 | 200ns | ($perl_version= $])=~ s{_\d+}{}; # spent 200ns making 1 call to CORE::subst
157 |  |  |  |  |
158 | 1 | 400ns |  |  | if( $perl_version >= 5.008)
159 | 1 | 25µs |  |  | { eval "use Encode qw( :all)"; ## no critic ProhibitStringyEval # spent 11µs executing statements in string eval # includes 7µs spent executing 1 call to 1 sub defined therein.
160 | 1 | 200ns |  |  | $FB_XMLCREF = 0x0400; # Encode::FB_XMLCREF;
161 | 1 | 200ns |  |  | $FB_HTMLCREF = 0x0200; # Encode::FB_HTMLCREF;
162 |  |  |  |  | }
163 |  |  |  |  |
164 |  |  |  |  | # test whether we can use weak references
165 |  |  |  |  | # set local empty signal handler to trap error messages
166 | 2 | 2µs |  |  | { local $SIG{__DIE__};
167 | 1 | 12µs |  |  | if( eval( 'require Scalar::Util') && defined( \&Scalar::Util::weaken)) # spent 2µs executing statements in string eval
168 | 2 | 2µs | 1 | 13µs | { import Scalar::Util( 'weaken'); $weakrefs= 1; } # spent 13µs making 1 call to Exporter::import
169 |  |  |  |  | elsif( eval( 'require WeakRef'))
170 |  |  |  |  | { import WeakRef; $weakrefs= 1; }
171 |  |  |  |  | else
172 |  |  |  |  | { $weakrefs= 0; }
173 |  |  |  |  | }
174 |  |  |  |  |
175 | 1 | 1µs | 1 | 600ns | import XML::Twig::Elt; # spent 600ns making 1 call to UNIVERSAL::import
176 | 1 | 1µs | 1 | 100ns | import XML::Twig::Entity; # spent 100ns making 1 call to UNIVERSAL::import
177 | 1 | 1µs | 1 | 100ns | import XML::Twig::Entity_list; # spent 100ns making 1 call to UNIVERSAL::import
178 |  |  |  |  |
179 |  |  |  |  | # used to store the gi's
180 |  |  |  |  | # should be set for each twig really, at least when there are several
181 |  |  |  |  | # the init ensures that special gi's are always the same
182 |  |  |  |  |
183 |  |  |  |  | # constants: element types
184 | 1 | 200ns |  |  | $PCDATA = '#PCDATA';
185 | 1 | 100ns |  |  | $CDATA = '#CDATA';
186 | 1 | 0s |  |  | $PI = '#PI';
187 | 1 | 100ns |  |  | $COMMENT = '#COMMENT';
188 | 1 | 100ns |  |  | $ENT = '#ENT';
189 | 1 | 0s |  |  | $NOTATION = '#NOTATION';
190 |  |  |  |  |
191 |  |  |  |  | # element classes
192 | 1 | 100ns |  |  | $ELT = '#ELT';
193 | 1 | 100ns |  |  | $TEXT = '#TEXT';
194 |  |  |  |  |
195 |  |  |  |  | # element properties
196 | 1 | 100ns |  |  | $ASIS = '#ASIS';
197 | 1 | 100ns |  |  | $EMPTY = '#EMPTY';
198 |  |  |  |  |
199 |  |  |  |  | # used in parseurl to set the buffer size to the same size as in XML::Parser::Expat
200 | 1 | 100ns |  |  | $BUFSIZE = 32768;
201 |  |  |  |  |
202 |  |  |  |  |
203 |  |  |  |  | # gi => index
204 | 1 | 2µs |  |  | %XML::Twig::gi2index=( '', 0, $PCDATA => 1, $CDATA => 2, $PI => 3, $COMMENT => 4, $ENT => 5);
205 |  |  |  |  | # list of gi's
206 | 1 | 700ns |  |  | @XML::Twig::index2gi=( '', $PCDATA, $CDATA, $PI, $COMMENT, $ENT);
207 |  |  |  |  |
208 |  |  |  |  | # gi's under this value are special
209 | 1 | 300ns |  |  | $XML::Twig::SPECIAL_GI= @XML::Twig::index2gi;
210 |  |  |  |  |
211 | 1 | 1µs |  |  | %XML::Twig::base_ent= ( '>' => '&gt;', '<' => '&lt;', '&' => '&amp;', "'" => '&apos;', '"' => '&quot;',);
212 | 4 | 3µs |  |  | foreach my $c ( "\n", "\r", "\t") { $XML::Twig::base_ent{$c}= sprintf( "&#x%02x;", ord( $c)); }
213 |  |  |  |  |
214 |  |  |  |  | # now set some aliases
215 | 1 | 600ns |  |  | *find_nodes = *get_xpath; # same as XML::XPath
216 | 1 | 200ns |  |  | *findnodes = *get_xpath; # same as XML::LibXML
217 | 1 | 100ns |  |  | *getElementsByTagName = *descendants;
218 | 1 | 100ns |  |  | *descendants_or_self = *descendants; # valid in XML::Twig, not in XML::Twig::Elt
219 | 1 | 100ns |  |  | *find_by_tag_name = *descendants;
220 | 1 | 100ns |  |  | *getElementById = *elt_id;
221 | 1 | 100ns |  |  | *getEltById = *elt_id;
222 | 1 | 100ns |  |  | *toString = *sprint;
223 | 1 | 2µs |  |  | *create_accessors = *att_accessors;
224 |  |  |  |  |
225 | 1 | 489µs | 1 | 240µs | } # spent 240µs making 1 call to XML::Twig::BEGIN@148
226 |  |  |  |  |
227 | 1 | 8µs |  |  | @ISA = qw(XML::Parser);
228 |  |  |  |  |
229 |  |  |  |  | # fake gi's used in twig_handlers and start_tag_handlers
230 | 1 | 200ns |  |  | my $ALL = '_all_'; # the associated function is always called
231 | 1 | 200ns |  |  | my $DEFAULT= '_default_'; # the function is called if no other handler has been
232 |  |  |  |  |
233 |  |  |  |  | # some defaults
234 | 1 | 100ns |  |  | my $COMMENTS_DEFAULT= 'keep';
235 | 1 | 200ns |  |  | my $PI_DEFAULT = 'keep';
236 |  |  |  |  |
237 |  |  |  |  |
238 |  |  |  |  | # handlers used in regular mode
239 | 1 | 4µs |  |  | my %twig_handlers=( Start => \&_twig_start,
240 |  |  |  |  | End => \&_twig_end,
241 |  |  |  |  | Char => \&_twig_char,
242 |  |  |  |  | Entity => \&_twig_entity,
243 |  |  |  |  | Notation => \&_twig_notation,
244 |  |  |  |  | XMLDecl => \&_twig_xmldecl,
245 |  |  |  |  | Doctype => \&_twig_doctype,
246 |  |  |  |  | Element => \&_twig_element,
247 |  |  |  |  | Attlist => \&_twig_attlist,
248 |  |  |  |  | CdataStart => \&_twig_cdatastart,
249 |  |  |  |  | CdataEnd => \&_twig_cdataend,
250 |  |  |  |  | Proc => \&_twig_pi,
251 |  |  |  |  | Comment => \&_twig_comment,
252 |  |  |  |  | Default => \&_twig_default,
253 |  |  |  |  | ExternEnt => \&_twig_extern_ent,
254 |  |  |  |  | );
255 |  |  |  |  |
256 |  |  |  |  | # handlers used when twig_roots is used and we are outside of the roots
257 |  |  |  |  | my %twig_handlers_roots=
258 |  |  |  |  | ( Start => \&_twig_start_check_roots,
259 |  |  |  |  | End => \&_twig_end_check_roots,
260 |  |  |  |  | Doctype => \&_twig_doctype,
261 |  |  |  |  | Char => undef, Entity => undef, XMLDecl => \&_twig_xmldecl,
262 |  |  |  |  | Element => undef, Attlist => undef, CdataStart => undef,
263 |  |  |  |  | CdataEnd => undef, Proc => undef, Comment => undef,
264 |  |  |  |  | Proc => \&_twig_pi_check_roots,
265 | 1 | 3µs |  |  | # spent 2µs within XML::Twig::__ANON__[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:265] which was called: # once (2µs+0s) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm Default => sub {}, # hack needed for XML::Parser 2.27
266 | 1 | 4µs |  |  | ExternEnt => \&_twig_extern_ent,
267 |  |  |  |  | );
268 |  |  |  |  |
269 |  |  |  |  | # handlers used when twig_roots and print_outside_roots are used and we are
270 |  |  |  |  | # outside of the roots
271 |  |  |  |  | my %twig_handlers_roots_print_2_30=
272 |  |  |  |  | ( Start => \&_twig_start_check_roots,
273 |  |  |  |  | End => \&_twig_end_check_roots,
274 |  |  |  |  | Char => \&_twig_print,
275 |  |  |  |  | Entity => \&_twig_print_entity,
276 |  |  |  |  | ExternEnt => \&_twig_print_entity,
277 |  |  |  |  | DoctypeFin => \&_twig_doctype_fin_print,
278 |  |  |  |  | XMLDecl => sub { _twig_xmldecl( @_); _twig_print( @_); },
279 | 1 | 4µs |  |  | Doctype => \&_twig_print_doctype, # because recognized_string is broken here
280 |  |  |  |  | # Element => \&_twig_print, Attlist => \&_twig_print,
281 |  |  |  |  | CdataStart => \&_twig_print, CdataEnd => \&_twig_print,
282 |  |  |  |  | Proc => \&_twig_pi_check_roots, Comment => \&_twig_print,
283 |  |  |  |  | Default => \&_twig_print_check_doctype,
284 |  |  |  |  | ExternEnt => \&_twig_extern_ent,
285 |  |  |  |  | );
286 |  |  |  |  |
287 |  |  |  |  | # handlers used when twig_roots, print_outside_roots and keep_encoding are used
288 |  |  |  |  | # and we are outside of the roots
289 |  |  |  |  | my %twig_handlers_roots_print_original_2_30=
290 |  |  |  |  | ( Start => \&_twig_start_check_roots,
291 |  |  |  |  | End => \&_twig_end_check_roots,
292 |  |  |  |  | Char => \&_twig_print_original,
293 |  |  |  |  | # I have no idea why I should not be using this handler!
294 |  |  |  |  | Entity => \&_twig_print_entity,
295 |  |  |  |  | ExternEnt => \&_twig_print_entity,
296 |  |  |  |  | DoctypeFin => \&_twig_doctype_fin_print,
297 |  |  |  |  | XMLDecl => sub { _twig_xmldecl( @_); _twig_print_original( @_) },
298 | 1 | 3µs |  |  | Doctype => \&_twig_print_original_doctype, # because original_string is broken here
299 |  |  |  |  | Element => \&_twig_print_original, Attlist => \&_twig_print_original,
300 |  |  |  |  | CdataStart => \&_twig_print_original, CdataEnd => \&_twig_print_original,
301 |  |  |  |  | Proc => \&_twig_pi_check_roots, Comment => \&_twig_print_original,
302 |  |  |  |  | Default => \&_twig_print_original_check_doctype,
303 |  |  |  |  | );
304 |  |  |  |  |
305 |  |  |  |  | # handlers used when twig_roots and print_outside_roots are used and we are
306 |  |  |  |  | # outside of the roots
307 |  |  |  |  | my %twig_handlers_roots_print_2_27=
308 |  |  |  |  | ( Start => \&_twig_start_check_roots,
309 |  |  |  |  | End => \&_twig_end_check_roots,
310 |  |  |  |  | Char => \&_twig_print,
311 |  |  |  |  | # if the Entity handler is set then it prints the entity declaration
312 |  |  |  |  | # before the entire internal subset (including the declaration!) is output
313 |  |  |  |  | Entity => sub {},
314 | 1 | 2µs |  |  | XMLDecl => \&_twig_print, Doctype => \&_twig_print,
315 |  |  |  |  | CdataStart => \&_twig_print, CdataEnd => \&_twig_print,
316 |  |  |  |  | Proc => \&_twig_pi_check_roots, Comment => \&_twig_print,
317 |  |  |  |  | Default => \&_twig_print,
318 |  |  |  |  | ExternEnt => \&_twig_extern_ent,
319 |  |  |  |  | );
320 |  |  |  |  |
321 |  |  |  |  | # handlers used when twig_roots, print_outside_roots and keep_encoding are used
322 |  |  |  |  | # and we are outside of the roots
323 |  |  |  |  | my %twig_handlers_roots_print_original_2_27=
324 |  |  |  |  | ( Start => \&_twig_start_check_roots,
325 |  |  |  |  | End => \&_twig_end_check_roots,
326 |  |  |  |  | Char => \&_twig_print_original,
327 |  |  |  |  | # for some reason original_string is wrong here
328 |  |  |  |  | # this can be a problem if the doctype includes non ascii characters
329 |  |  |  |  | XMLDecl => \&_twig_print, Doctype => \&_twig_print,
330 |  |  |  |  | # if the Entity handler is set then it prints the entity declaration
331 |  |  |  |  | # before the entire internal subset (including the declaration!) is output
332 |  |  |  |  | Entity => sub {},
333 |  |  |  |  | #Element => undef, Attlist => undef,
334 | 1 | 2µs |  |  | CdataStart => \&_twig_print_original, CdataEnd => \&_twig_print_original,
335 |  |  |  |  | Proc => \&_twig_pi_check_roots, Comment => \&_twig_print_original,
336 |  |  |  |  | Default => \&_twig_print, # _twig_print_original does not work
337 |  |  |  |  | ExternEnt => \&_twig_extern_ent,
338 |  |  |  |  | );
339 |  |  |  |  |
340 |  |  |  |  |
341 | 1 | 2µs |  |  | my %twig_handlers_roots_print= $parser_version > 2.27
342 |  |  |  |  | ? %twig_handlers_roots_print_2_30
343 |  |  |  |  | : %twig_handlers_roots_print_2_27;
344 | 1 | 2µs |  |  | my %twig_handlers_roots_print_original= $parser_version > 2.27
345 |  |  |  |  | ? %twig_handlers_roots_print_original_2_30
346 |  |  |  |  | : %twig_handlers_roots_print_original_2_27;
347 |  |  |  |  |
348 |  |  |  |  |
349 |  |  |  |  | # handlers used when the finish_print method has been called
350 | 1 | 2µs |  |  | my %twig_handlers_finish_print=
351 |  |  |  |  | ( Start => \&_twig_print,
352 |  |  |  |  | End => \&_twig_print, Char => \&_twig_print,
353 |  |  |  |  | Entity => \&_twig_print, XMLDecl => \&_twig_print,
354 |  |  |  |  | Doctype => \&_twig_print, Element => \&_twig_print,
355 |  |  |  |  | Attlist => \&_twig_print, CdataStart => \&_twig_print,
356 |  |  |  |  | CdataEnd => \&_twig_print, Proc => \&_twig_print,
357 |  |  |  |  | Comment => \&_twig_print, Default => \&_twig_print,
358 |  |  |  |  | ExternEnt => \&_twig_extern_ent,
359 |  |  |  |  | );
360 |  |  |  |  |
361 |  |  |  |  | # handlers used when the finish_print method has been called and the keep_encoding
362 |  |  |  |  | # option is used
363 | 1 | 1µs |  |  | my %twig_handlers_finish_print_original=
364 |  |  |  |  | ( Start => \&_twig_print_original, End => \&_twig_print_end_original,
365 |  |  |  |  | Char => \&_twig_print_original, Entity => \&_twig_print_original,
366 |  |  |  |  | XMLDecl => \&_twig_print_original, Doctype => \&_twig_print_original,
367 |  |  |  |  | Element => \&_twig_print_original, Attlist => \&_twig_print_original,
368 |  |  |  |  | CdataStart => \&_twig_print_original, CdataEnd => \&_twig_print_original,
369 |  |  |  |  | Proc => \&_twig_print_original, Comment => \&_twig_print_original,
370 |  |  |  |  | Default => \&_twig_print_original,
371 |  |  |  |  | );
372 |  |  |  |  |
373 |  |  |  |  | # handlers used within ignored elements
374 | 1 | 1µs |  |  | my %twig_handlers_ignore=
375 |  |  |  |  | ( Start => \&_twig_ignore_start,
376 |  |  |  |  | End => \&_twig_ignore_end,
377 |  |  |  |  | Char => undef, Entity => undef, XMLDecl => undef,
378 |  |  |  |  | Doctype => undef, Element => undef, Attlist => undef,
379 |  |  |  |  | CdataStart => undef, CdataEnd => undef, Proc => undef,
380 |  |  |  |  | Comment => undef, Default => undef,
381 |  |  |  |  | ExternEnt => undef,
382 |  |  |  |  | );
383 |  |  |  |  |
384 |  |  |  |  |
385 |  |  |  |  | # those handlers are only used if the entities are NOT to be expanded
386 | 1 | 400ns |  |  | my %twig_noexpand_handlers= ( ExternEnt => undef, Default => \&_twig_default );
387 |  |  |  |  |
388 | 1 | 100ns |  |  | my @saved_default_handler;
389 |  |  |  |  |
390 | 1 | 100ns |  |  | my $ID= 'id'; # default value, set by the Id argument
391 | 1 | 200ns |  |  | my $css_sel=0; # set through the css_sel option to allow .class selectors in triggers
392 |  |  |  |  |
393 |  |  |  |  | # all allowed options
394 | 1 | 21µs |  |  | %valid_option=
395 |  |  |  |  | ( # XML::Twig options
396 |  |  |  |  | TwigHandlers => 1, Id => 1,
397 |  |  |  |  | TwigRoots => 1, TwigPrintOutsideRoots => 1,
398 |  |  |  |  | StartTagHandlers => 1, EndTagHandlers => 1,
399 |  |  |  |  | ForceEndTagHandlersUsage => 1,
400 |  |  |  |  | DoNotChainHandlers => 1,
401 |  |  |  |  | IgnoreElts => 1,
402 |  |  |  |  | Index => 1,
403 |  |  |  |  | AttAccessors => 1,
404 |  |  |  |  | EltAccessors => 1,
405 |  |  |  |  | FieldAccessors => 1,
406 |  |  |  |  | CharHandler => 1,
407 |  |  |  |  | TopDownHandlers => 1,
408 |  |  |  |  | KeepEncoding => 1, DoNotEscapeAmpInAtts => 1,
409 |  |  |  |  | ParseStartTag => 1, KeepAttsOrder => 1,
410 |  |  |  |  | LoadDTD => 1, DTDHandler => 1, DTDBase => 1, NoXxe => 1,
411 |  |  |  |  | DoNotOutputDTD => 1, NoProlog => 1,
412 |  |  |  |  | ExpandExternalEnts => 1,
413 |  |  |  |  | DiscardSpaces => 1, KeepSpaces => 1, DiscardAllSpaces => 1,
414 |  |  |  |  | DiscardSpacesIn => 1, KeepSpacesIn => 1,
415 |  |  |  |  | PrettyPrint => 1, EmptyTags => 1,
416 |  |  |  |  | EscapeGt => 1,
417 |  |  |  |  | Quote => 1,
418 |  |  |  |  | Comments => 1, Pi => 1,
419 |  |  |  |  | OutputFilter => 1, InputFilter => 1,
420 |  |  |  |  | OutputTextFilter => 1,
421 |  |  |  |  | OutputEncoding => 1,
422 |  |  |  |  | RemoveCdata => 1,
423 |  |  |  |  | EltClass => 1,
424 |  |  |  |  | MapXmlns => 1, KeepOriginalPrefix => 1,
425 |  |  |  |  | SkipMissingEnts => 1,
426 |  |  |  |  | # XML::Parser options
427 |  |  |  |  | ErrorContext => 1, ProtocolEncoding => 1,
428 |  |  |  |  | Namespaces => 1, NoExpand => 1,
429 |  |  |  |  | Stream_Delimiter => 1, ParseParamEnt => 1,
430 |  |  |  |  | NoLWP => 1, Non_Expat_Options => 1,
431 |  |  |  |  | Xmlns => 1, CssSel => 1,
432 |  |  |  |  | UseTidy => 1, TidyOptions => 1,
433 |  |  |  |  | OutputHtmlDoctype => 1,
434 |  |  |  |  | );
435 |  |  |  |  |
436 | 1 | 100ns |  |  | my $active_twig; # last active twig,for XML::Twig::s
437 |  |  |  |  |
438 |  |  |  |  | # predefined input and output filters
439 | 2 | 1.47ms | 2 | 34µs | # spent 20µs (7+13) within XML::Twig::BEGIN@439 which was called: # once (7µs+13µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 439 use vars qw( %filter); # spent 20µs making 1 call to XML::Twig::BEGIN@439 # spent 13µs making 1 call to vars::import
440 | 1 | 900ns |  |  | %filter= ( html => \&html_encode,
441 |  |  |  |  | safe => \&safe_encode,
442 |  |  |  |  | safe_hex => \&safe_encode_hex,
443 |  |  |  |  | );
444 |  |  |  |  |
445 |  |  |  |  |
446 |  |  |  |  | # trigger types (used to sort them)
447 | 1 | 600ns |  |  | my ($LEVEL_TRIGGER, $REGEXP_TRIGGER, $XPATH_TRIGGER)=(1..3);
448 |  |  |  |  |
449 |  |  |  |  | sub new
450 | 7 | 8µs |  |  | # spent 12.0ms (392µs+11.6) within XML::Twig::new which was called 7 times, avg 1.71ms/call: # 7 times (392µs+11.6ms) by Spreadsheet::ParseXLSX::_new_twig at line 1177 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 1.71ms/call { my ($class, %args) = @_;
451 | 7 | 800ns |  |  | my $handlers;
452 |  |  |  |  |
453 |  |  |  |  | # change all nice_perlish_names into nicePerlishNames
454 | 7 | 14µs | 7 | 63µs | %args= _normalize_args( %args); # spent 63µs making 7 calls to XML::Twig::_normalize_args, avg 9µs/call
455 |  |  |  |  |
456 |  |  |  |  | # check options
457 | 7 | 7µs |  |  | unless( $args{MoreOptions})
458 |  |  |  |  | { foreach my $arg (keys %args)
459 | 23 | 8µs |  |  | { carp "invalid option $arg" unless $valid_option{$arg}; }
460 |  |  |  |  | }
461 |  |  |  |  |
462 |  |  |  |  | # a twig is really an XML::Parser
463 |  |  |  |  | # my $self= XML::Parser->new(%args);
464 | 7 | 600ns |  |  | my $self;
465 | 7 | 13µs | 7 | 82µs | $self= XML::Parser->new(%args); # spent 82µs making 7 calls to XML::Parser::new, avg 12µs/call
466 |  |  |  |  |
467 | 7 | 2µs |  |  | bless $self, $class;
468 |  |  |  |  |
469 | 7 | 3µs |  |  | $self->{_twig_context_stack}= [];
470 |  |  |  |  |
471 |  |  |  |  | # allow tag.class selectors in handler triggers
472 | 7 | 2µs |  |  | $css_sel= $args{CssSel} || 0;
473 |  |  |  |  |
474 |  |  |  |  |
475 | 7 | 2µs |  |  | if( exists $args{TwigHandlers})
476 | 1 | 400ns |  |  | { $handlers= $args{TwigHandlers};
477 | 1 | 2µs | 1 | 3.81ms | $self->setTwigHandlers( $handlers); # spent 3.81ms making 1 call to XML::Twig::setTwigHandlers
478 | 1 | 500ns |  |  | delete $args{TwigHandlers};
479 |  |  |  |  | }
480 |  |  |  |  |
481 |  |  |  |  | # take care of twig-specific arguments
482 | 7 | 1µs |  |  | if( exists $args{StartTagHandlers})
483 |  |  |  |  | { $self->setStartTagHandlers( $args{StartTagHandlers});
484 |  |  |  |  | delete $args{StartTagHandlers};
485 |  |  |  |  | }
486 |  |  |  |  |
487 | 7 | 1µs |  |  | if( exists $args{DoNotChainHandlers})
488 |  |  |  |  | { $self->{twig_do_not_chain_handlers}= $args{DoNotChainHandlers}; }
489 |  |  |  |  |
490 | 7 | 1µs |  |  | if( exists $args{IgnoreElts})
491 |  |  |  |  | { # change array to hash so you can write ignore_elts => [ qw(foo bar baz)]
492 |  |  |  |  | if( isa( $args{IgnoreElts}, 'ARRAY')) { $args{IgnoreElts}= { map { $_ => 1 } @{$args{IgnoreElts}} }; }
493 |  |  |  |  | $self->setIgnoreEltsHandlers( $args{IgnoreElts});
494 |  |  |  |  | delete $args{IgnoreElts};
495 |  |  |  |  | }
496 |  |  |  |  |
497 | 7 | 1µs |  |  | if( exists $args{Index})
498 |  |  |  |  | { my $index= $args{Index};
499 |  |  |  |  | # we really want a hash name => path, we turn an array into a hash if necessary
500 |  |  |  |  | if( ref( $index) eq 'ARRAY')
501 |  |  |  |  | { my %index= map { $_ => $_ } @$index;
502 |  |  |  |  | $index= \%index;
503 |  |  |  |  | }
504 |  |  |  |  | while( my( $name, $exp)= each %$index)
505 |  |  |  |  | { $self->setTwigHandler( $exp, sub { push @{$_[0]->{_twig_index}->{$name}}, $_; 1; }); }
506 |  |  |  |  | }
507 |  |  |  |  |
508 | 7 | 5µs |  |  | $self->{twig_elt_class}= $args{EltClass} || 'XML::Twig::Elt';
509 | 7 | 1µs |  |  | if( defined( $args{EltClass}) && $args{EltClass} ne 'XML::Twig::Elt') { $self->{twig_alt_elt_class}=1; }
510 | 7 | 1µs |  |  | if( exists( $args{EltClass})) { delete $args{EltClass}; }
511 |  |  |  |  |
512 | 7 | 2µs |  |  | if( exists( $args{MapXmlns}))
513 | 7 | 3µs |  |  | { $self->{twig_map_xmlns}= $args{MapXmlns};
514 | 7 | 2µs |  |  | $self->{Namespaces}=1;
515 | 7 | 2µs |  |  | delete $args{MapXmlns};
516 |  |  |  |  | }
517 |  |  |  |  |
518 | 7 | 1µs |  |  | if( exists( $args{KeepOriginalPrefix}))
519 | 7 | 2µs |  |  | { $self->{twig_keep_original_prefix}= $args{KeepOriginalPrefix};
520 | 7 | 800ns |  |  | delete $args{KeepOriginalPrefix};
521 |  |  |  |  | }
522 |  |  |  |  |
523 | 7 | 2µs |  |  | $self->{twig_dtd_handler}= $args{DTDHandler};
524 | 7 | 1µs |  |  | delete $args{DTDHandler};
525 |  |  |  |  |
526 | 7 | 2µs |  |  | if( $args{ExpandExternalEnts})
527 |  |  |  |  | { $self->set_expand_external_entities( 1);
528 |  |  |  |  | $self->{twig_expand_external_ents}= $args{ExpandExternalEnts};
529 |  |  |  |  | $self->{twig_read_external_dtd}= 1; # implied by ExpandExternalEnts
530 |  |  |  |  | if( $args{ExpandExternalEnts} == -1)
531 |  |  |  |  | { $self->{twig_extern_ent_nofail}= 1;
532 |  |  |  |  | $self->setHandlers( ExternEnt => \&_twig_extern_ent_nofail);
533 |  |  |  |  | }
534 |  |  |  |  | delete $args{LoadDTD};
535 |  |  |  |  | delete $args{ExpandExternalEnts};
536 |  |  |  |  | }
537 |  |  |  |  | else
538 | 7 | 7µs | 7 | 20µs | { $self->set_expand_external_entities( 0); } # spent 20µs making 7 calls to XML::Twig::set_expand_external_entities, avg 3µs/call
539 |  |  |  |  |
540 | 7 | 9µs | 7 | 2.49ms | if( !$args{NoLWP} && ! _use( 'URI') && ! _use( 'URI::File') && ! _use( 'LWP')) # spent 2.49ms making 7 calls to XML::Twig::_use, avg 356µs/call
541 |  |  |  |  | { $self->{twig_ext_ent_handler}= \&XML::Parser::initial_ext_ent_handler }
542 |  |  |  |  | elsif( $args{NoXxe})
543 |  |  |  |  | { $self->{twig_ext_ent_handler}=
544 | 7 | 11µs |  |  | sub { my($xp, $base, $path) = @_; $xp->{ErrorMessage}.= "cannot use entities in document when the no_xxe option is on"; return undef; };
545 |  |  |  |  | }
546 |  |  |  |  | else
547 |  |  |  |  | { $self->{twig_ext_ent_handler}= \&XML::Parser::file_ext_ent_handler }
548 |  |  |  |  |
549 | 7 | 2µs |  |  | if( $args{DoNotEscapeAmpInAtts})
550 |  |  |  |  | { $self->set_do_not_escape_amp_in_atts( 1);
551 |  |  |  |  | $self->{twig_do_not_escape_amp_in_atts}=1;
552 |  |  |  |  | }
553 |  |  |  |  | else
554 | 7 | 5µs | 7 | 17µs | { $self->set_do_not_escape_amp_in_atts( 0); # spent 17µs making 7 calls to XML::Twig::set_do_not_escape_amp_in_atts, avg 2µs/call
555 | 7 | 5µs |  |  | $self->{twig_do_not_escape_amp_in_atts}=0;
556 |  |  |  |  | }
557 |  |  |  |  |
558 |  |  |  |  | # deal with TwigRoots argument, a hash of elements for which
559 |  |  |  |  | # subtrees will be built (and associated handlers)
560 |  |  |  |  |
561 | 7 | 2µs |  |  | if( $args{TwigRoots})
562 | 1 | 2µs | 1 | 4.78ms | { $self->setTwigRoots( $args{TwigRoots}); # spent 4.78ms making 1 call to XML::Twig::setTwigRoots
563 | 1 | 500ns |  |  | delete $args{TwigRoots};
564 |  |  |  |  | }
565 |  |  |  |  |
566 | 7 | 1µs |  |  | if( $args{EndTagHandlers})
567 |  |  |  |  | { unless ($self->{twig_roots} || $args{ForceEndTagHandlersUsage})
568 |  |  |  |  | { croak "you should not use EndTagHandlers without TwigRoots\n",
569 |  |  |  |  | "if you want to use it anyway, normally because you have ",
570 |  |  |  |  | "a start_tag_handlers that calls 'ignore' and you want to ",
571 |  |  |  |  | "call an ent_tag_handlers at the end of the element, then ",
572 |  |  |  |  | "pass 'force_end_tag_handlers_usage => 1' as an argument ",
573 |  |  |  |  | "to new";
574 |  |  |  |  | }
575 |  |  |  |  |
576 |  |  |  |  | $self->setEndTagHandlers( $args{EndTagHandlers});
577 |  |  |  |  | delete $args{EndTagHandlers};
578 |  |  |  |  | }
579 |  |  |  |  |
580 | 7 | 1µs |  |  | if( $args{TwigPrintOutsideRoots})
581 |  |  |  |  | { croak "cannot use twig_print_outside_roots without twig_roots"
582 |  |  |  |  | unless( $self->{twig_roots});
583 |  |  |  |  | # if the arg is a filehandle then store it
584 |  |  |  |  | if( _is_fh( $args{TwigPrintOutsideRoots}) )
585 |  |  |  |  | { $self->{twig_output_fh}= $args{TwigPrintOutsideRoots}; }
586 |  |  |  |  | $self->{twig_default_print}= $args{TwigPrintOutsideRoots};
587 |  |  |  |  | }
588 |  |  |  |  |
589 |  |  |  |  | # space policy
590 | 7 | 1µs |  |  | if( $args{KeepSpaces})
591 |  |  |  |  | { croak "cannot use both keep_spaces and discard_spaces" if( $args{DiscardSpaces});
592 |  |  |  |  | croak "cannot use both keep_spaces and discard_all_spaces" if( $args{DiscardAllSpaces});
593 |  |  |  |  | croak "cannot use both keep_spaces and keep_spaces_in" if( $args{KeepSpacesIn});
594 |  |  |  |  | $self->{twig_keep_spaces}=1;
595 |  |  |  |  | delete $args{KeepSpaces};
596 |  |  |  |  | }
597 | 7 | 1µs |  |  | if( $args{DiscardSpaces})
598 |  |  |  |  | {
599 |  |  |  |  | croak "cannot use both discard_spaces and keep_spaces_in" if( $args{KeepSpacesIn});
600 |  |  |  |  | croak "cannot use both discard_spaces and discard_all_spaces" if( $args{DiscardAllSpaces});
601 |  |  |  |  | croak "cannot use both discard_spaces and discard_spaces_in" if( $args{DiscardSpacesIn});
602 |  |  |  |  | $self->{twig_discard_spaces}=1;
603 |  |  |  |  | delete $args{DiscardSpaces};
604 |  |  |  |  | }
605 | 7 | 1µs |  |  | if( $args{KeepSpacesIn})
606 |  |  |  |  | { croak "cannot use both keep_spaces_in and discard_spaces_in" if( $args{DiscardSpacesIn});
607 |  |  |  |  | croak "cannot use both keep_spaces_in and discard_all_spaces" if( $args{DiscardAllSpaces});
608 |  |  |  |  | $self->{twig_discard_spaces}=1;
609 |  |  |  |  | $self->{twig_keep_spaces_in}={};
610 |  |  |  |  | my @tags= @{$args{KeepSpacesIn}};
611 |  |  |  |  | foreach my $tag (@tags) { $self->{twig_keep_spaces_in}->{$tag}=1; }
612 |  |  |  |  | delete $args{KeepSpacesIn};
613 |  |  |  |  | }
614 |  |  |  |  |
615 | 7 | 1µs |  |  | if( $args{DiscardAllSpaces})
616 |  |  |  |  | {
617 |  |  |  |  | croak "cannot use both discard_all_spaces and discard_spaces_in" if( $args{DiscardSpacesIn});
618 |  |  |  |  | $self->{twig_discard_all_spaces}=1;
619 |  |  |  |  | delete $args{DiscardAllSpaces};
620 |  |  |  |  | }
621 |  |  |  |  |
622 | 7 | 1µs |  |  | if( $args{DiscardSpacesIn})
623 |  |  |  |  | { $self->{twig_keep_spaces}=1;
624 |  |  |  |  | $self->{twig_discard_spaces_in}={};
625 |  |  |  |  | my @tags= @{$args{DiscardSpacesIn}};
626 |  |  |  |  | foreach my $tag (@tags) { $self->{twig_discard_spaces_in}->{$tag}=1; }
627 |  |  |  |  | delete $args{DiscardSpacesIn};
628 |  |  |  |  | }
629 |  |  |  |  | # discard spaces by default
630 | 7 | 6µs |  |  | $self->{twig_discard_spaces}= 1 unless( $self->{twig_keep_spaces});
631 |  |  |  |  |
632 | 7 | 3µs |  |  | $args{Comments}||= $COMMENTS_DEFAULT;
633 | 7 | 7µs |  |  | if( $args{Comments} eq 'drop') { $self->{twig_keep_comments}= 0; }
634 |  |  |  |  | elsif( $args{Comments} eq 'keep') { $self->{twig_keep_comments}= 1; }
635 |  |  |  |  | elsif( $args{Comments} eq 'process') { $self->{twig_process_comments}= 1; }
636 |  |  |  |  | else { croak "wrong value for comments argument: '$args{Comments}' (should be 'drop', 'keep' or 'process')"; }
637 | 7 | 2µs |  |  | delete $args{Comments};
638 |  |  |  |  |
639 | 7 | 3µs |  |  | $args{Pi}||= $PI_DEFAULT;
640 | 7 | 4µs |  |  | if( $args{Pi} eq 'drop') { $self->{twig_keep_pi}= 0; }
641 |  |  |  |  | elsif( $args{Pi} eq 'keep') { $self->{twig_keep_pi}= 1; }
642 |  |  |  |  | elsif( $args{Pi} eq 'process') { $self->{twig_process_pi}= 1; }
643 |  |  |  |  | else { croak "wrong value for pi argument: '$args{Pi}' (should be 'drop', 'keep' or 'process')"; }
644 | 7 | 1µs |  |  | delete $args{Pi};
645 |  |  |  |  |
646 | 7 | 2µs |  |  | if( $args{KeepEncoding})
647 |  |  |  |  | {
648 |  |  |  |  | # set it in XML::Twig::Elt so print functions know what to do
649 |  |  |  |  | $self->set_keep_encoding( 1);
650 |  |  |  |  | $self->{parse_start_tag}= $args{ParseStartTag} || \&_parse_start_tag;
651 |  |  |  |  | delete $args{ParseStartTag} if defined( $args{ParseStartTag}) ;
652 |  |  |  |  | delete $args{KeepEncoding};
653 |  |  |  |  | }
654 |  |  |  |  | else
655 | 7 | 5µs | 7 | 26µs | { $self->set_keep_encoding( 0); # spent 26µs making 7 calls to XML::Twig::set_keep_encoding, avg 4µs/call
656 | 7 | 2µs |  |  | if( $args{ParseStartTag})
657 |  |  |  |  | { $self->{parse_start_tag}= $args{ParseStartTag}; }
658 |  |  |  |  | else
659 | 7 | 1µs |  |  | { delete $self->{parse_start_tag}; }
660 | 7 | 1µs |  |  | delete $args{ParseStartTag};
661 |  |  |  |  | }
662 |  |  |  |  |
663 | 7 | 2µs |  |  | if( $args{OutputFilter})
664 |  |  |  |  | { $self->set_output_filter( $args{OutputFilter});
665 |  |  |  |  | delete $args{OutputFilter};
666 |  |  |  |  | }
667 |  |  |  |  | else
668 | 7 | 5µs | 7 | 34µs | { $self->set_output_filter( 0); } # spent 34µs making 7 calls to XML::Twig::set_output_filter, avg 5µs/call
669 |  |  |  |  |
670 | 7 | 1µs |  |  | if( $args{RemoveCdata})
671 |  |  |  |  | { $self->set_remove_cdata( $args{RemoveCdata});
672 |  |  |  |  | delete $args{RemoveCdata};
673 |  |  |  |  | }
674 |  |  |  |  | else
675 | 7 | 4µs | 7 | 14µs | { $self->set_remove_cdata( 0); } # spent 14µs making 7 calls to XML::Twig::set_remove_cdata, avg 2µs/call
676 |  |  |  |  |
677 | 7 | 1µs |  |  | if( $args{OutputTextFilter})
678 |  |  |  |  | { $self->set_output_text_filter( $args{OutputTextFilter});
679 |  |  |  |  | delete $args{OutputTextFilter};
680 |  |  |  |  | }
681 |  |  |  |  | else
682 | 7 | 5µs | 7 | 28µs | { $self->set_output_text_filter( 0); } # spent 28µs making 7 calls to XML::Twig::set_output_text_filter, avg 4µs/call
683 |  |  |  |  |
684 | 7 | 1µs |  |  | if( $args{KeepAttsOrder})
685 |  |  |  |  | { $self->{keep_atts_order}= $args{KeepAttsOrder};
686 |  |  |  |  | if( _use( 'Tie::IxHash'))
687 |  |  |  |  | { $self->set_keep_atts_order( $self->{keep_atts_order}); }
688 |  |  |  |  | else
689 |  |  |  |  | { croak "Tie::IxHash not available, option keep_atts_order not allowed"; }
690 |  |  |  |  | }
691 |  |  |  |  | else
692 | 7 | 5µs | 7 | 17µs | { $self->set_keep_atts_order( 0); } # spent 17µs making 7 calls to XML::Twig::set_keep_atts_order, avg 2µs/call
693 |  |  |  |  |
694 |  |  |  |  |
695 | 7 | 1µs |  |  | if( $args{PrettyPrint}) { $self->set_pretty_print( $args{PrettyPrint}); }
696 | 7 | 900ns |  |  | if( $args{EscapeGt}) { $self->escape_gt( $args{EscapeGt}); }
697 | 7 | 1µs |  |  | if( $args{EmptyTags}) { $self->set_empty_tag_style( $args{EmptyTags}) }
698 |  |  |  |  |
699 | 7 | 1µs |  |  | if( exists $args{Id}) { $ID= $args{Id}; delete $args{ID}; }
700 | 7 | 1µs |  |  | if( $args{NoProlog}) { $self->{no_prolog}= 1; delete $args{NoProlog}; }
701 | 7 | 700ns |  |  | if( $args{DoNotOutputDTD}) { $self->{no_dtd_output}= 1; delete $args{DoNotOutputDTD}; }
702 | 7 | 900ns |  |  | if( $args{LoadDTD}) { $self->{twig_read_external_dtd}= 1; delete $args{LoadDTD}; }
703 | 7 | 900ns |  |  | if( $args{CharHandler}) { $self->setCharHandler( $args{CharHandler}); delete $args{CharHandler}; }
704 |  |  |  |  |
705 | 7 | 1µs |  |  | if( $args{InputFilter}) { $self->set_input_filter( $args{InputFilter}); delete $args{InputFilter}; }
706 | 7 | 800ns |  |  | if( $args{NoExpand}) { $self->setHandlers( %twig_noexpand_handlers); $self->{twig_no_expand}=1; }
707 | 7 | 2µs |  |  | if( my $output_encoding= $args{OutputEncoding}) { $self->set_output_encoding( $output_encoding); delete $args{OutputFilter}; }
708 |  |  |  |  |
709 | 7 | 1µs |  |  | if( my $tdh= $args{TopDownHandlers}) { $self->{twig_tdh}=1; delete $args{TopDownHandlers}; }
710 |  |  |  |  |
711 | 7 | 1µs |  |  | if( my $acc_a= $args{AttAccessors}) { $self->att_accessors( @$acc_a); }
712 | 7 | 900ns |  |  | if( my $acc_e= $args{EltAccessors}) { $self->elt_accessors( isa( $acc_e, 'ARRAY') ? @$acc_e : $acc_e); }
713 | 7 | 800ns |  |  | if( my $acc_f= $args{FieldAccessors}) { $self->field_accessors( isa( $acc_f, 'ARRAY') ? @$acc_f : $acc_f); }
714 |  |  |  |  |
715 | 7 | 800ns |  |  | if( $args{UseTidy}) { $self->{use_tidy}= 1; }
716 | 7 | 3µs |  |  | $self->{tidy_options}= $args{TidyOptions} || {};
717 |  |  |  |  |
718 | 7 | 800ns |  |  | if( $args{OutputHtmlDoctype}) { $self->{html_doctype}= 1; }
719 |  |  |  |  |
720 | 7 | 6µs | 7 | 22µs | $self->set_quote( $args{Quote} || 'double'); # spent 22µs making 7 calls to XML::Twig::set_quote, avg 3µs/call
721 |  |  |  |  |
722 |  |  |  |  | # set handlers
723 | 7 | 4µs |  |  | if( $self->{twig_roots})
724 |  |  |  |  | { if( $self->{twig_default_print})
725 |  |  |  |  | { if( $self->{twig_keep_encoding})
726 |  |  |  |  | { $self->setHandlers( %twig_handlers_roots_print_original); }
727 |  |  |  |  | else
728 |  |  |  |  | { $self->setHandlers( %twig_handlers_roots_print); }
729 |  |  |  |  | }
730 |  |  |  |  | else
731 | 1 | 2µs | 1 | 16µs | { $self->setHandlers( %twig_handlers_roots); } # spent 16µs making 1 call to XML::Parser::setHandlers
732 |  |  |  |  | }
733 |  |  |  |  | else
734 | 6 | 11µs | 6 | 104µs | { $self->setHandlers( %twig_handlers); } # spent 104µs making 6 calls to XML::Parser::setHandlers, avg 17µs/call
735 |  |  |  |  |
736 |  |  |  |  | # XML::Parser::Expat does not like these handler to be set. So in order to
737 |  |  |  |  | # use the various sets of handlers on XML::Parser or XML::Parser::Expat
738 |  |  |  |  | # objects when needed, these ones have to be set only once, here, at
739 |  |  |  |  | # XML::Parser level
740 | 7 | 7µs | 7 | 22µs | $self->setHandlers( Init => \&_twig_init, Final => \&_twig_final); # spent 22µs making 7 calls to XML::Parser::setHandlers, avg 3µs/call
741 |  |  |  |  |
742 | 7 | 20µs | 7 | 13µs | $self->{twig_entity_list}= XML::Twig::Entity_list->new; # spent 13µs making 7 calls to XML::Twig::Entity_list::new, avg 2µs/call
743 | 7 | 13µs | 7 | 10µs | $self->{twig_notation_list}= XML::Twig::Notation_list->new; # spent 10µs making 7 calls to XML::Twig::Notation_list::new, avg 1µs/call
744 |  |  |  |  |
745 | 7 | 2µs |  |  | $self->{twig_id}= $ID;
746 | 7 | 2µs |  |  | $self->{twig_stored_spaces}='';
747 |  |  |  |  |
748 | 7 | 2µs |  |  | $self->{twig_autoflush}= 1; # auto flush by default
749 |  |  |  |  |
750 | 7 | 2µs |  |  | $self->{twig}= $self;
751 | 7 | 13µs | 7 | 4µs | if( $weakrefs) { weaken( $self->{twig}); } # spent 4µs making 7 calls to Scalar::Util::weaken, avg 629ns/call
752 |  |  |  |  |
753 | 7 | 23µs |  |  | return $self;
754 |  |  |  |  | }
755 |  |  |  |  |
756 |  |  |  |  | sub parse
757 |  |  |  |  | # spent 70.4s (48µs+70.4) within XML::Twig::parse which was called 7 times, avg 10.1s/call: # 5 times (34µs+46.3ms) by Spreadsheet::ParseXLSX::_parse_xml at line 1033 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 9.28ms/call # once (8µs+70.4s) by Spreadsheet::ParseXLSX::_parse_sheet at line 447 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (6µs+7.19ms) by Spreadsheet::ParseXLSX::_parse_shared_strings at line 658 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm {
758 | 7 | 1µs |  |  | my $t= shift;
759 |  |  |  |  | # if called as a class method, calls nparse, which creates the twig then parses it
760 | 7 | 14µs | 7 | 4µs | if( !ref( $t) || !isa( $t, 'XML::Twig')) { return $t->nparse( @_); } # spent 4µs making 7 calls to UNIVERSAL::isa, avg 643ns/call
761 |  |  |  |  |
762 |  |  |  |  | # requires 5.006 at least (or the ${^UNICODE} causes a problem) # > perl 5.5
763 |  |  |  |  | # trap underlying bug in IO::Handle (see RT #17500) # > perl 5.5
764 |  |  |  |  | # croak if perl 5.8+, -CD (or PERL_UNICODE set to D) and parsing a pipe # > perl 5.5
765 | 7 | 5µs |  |  | if( $perl_version>=5.008 && ${^UNICODE} && (${^UNICODE} & 24) && isa( $_[0], 'GLOB') && -p $_[0] ) # > perl 5.5
766 |  |  |  |  | { croak "cannot parse the output of a pipe when perl is set to use the UTF8 perlIO layer\n" # > perl 5.5
767 |  |  |  |  | . "set the environment variable PERL_UNICODE or use the -C option (see perldoc perlrun)\n" # > perl 5.5
768 |  |  |  |  | . "not to include 'D'"; # > perl 5.5
769 |  |  |  |  | } # > perl 5.5
770 | 14 | 13µs | 7 | 70.4s | $t= eval { $t->SUPER::parse( @_); }; # spent 70.4s making 7 calls to XML::Parser::parse, avg 10.1s/call
771 |  |  |  |  |
772 | 7 | 3µs |  |  | if( !$t
773 |  |  |  |  | && $@=~m{(syntax error at line 1, column 0, byte 0|not well-formed \(invalid token\) at line 1, column 1, byte 1)}
774 |  |  |  |  | && -f $_[0]
775 |  |  |  |  | && ( ! ref( $_[0]) || ref( $_[0])) ne 'GLOB' # -f works on a filehandle, so this make sure $_[0] is a real file
776 |  |  |  |  | )
777 |  |  |  |  | { croak "you seem to have used the parse method on a filename ($_[0]), you probably want parsefile instead"; }
778 | 7 | 18µs | 7 | 78µs | return _checked_parse_result( $t, $@); # spent 78µs making 7 calls to XML::Twig::_checked_parse_result, avg 11µs/call
779 |  |  |  |  | }
780 |  |  |  |  |
781 |  |  |  |  | sub parsefile
782 |  |  |  |  | { my $t= shift;
783 |  |  |  |  | if( -f $_[0] && ! -s $_[0]) { return _checked_parse_result( undef, "empty file '$_[0]'"); }
784 |  |  |  |  | $t= eval { $t->SUPER::parsefile( @_); };
785 |  |  |  |  | return _checked_parse_result( $t, $@);
786 |  |  |  |  | }
787 |  |  |  |  |
788 |  |  |  |  | sub _checked_parse_result
789 | 7 | 2µs |  |  | # spent 78µs (17+61) within XML::Twig::_checked_parse_result which was called 7 times, avg 11µs/call: # 7 times (17µs+61µs) by XML::Twig::parse at line 778, avg 11µs/call { my( $t, $returned)= @_;
790 | 7 | 1µs |  |  | if( !$t)
791 |  |  |  |  | { if( isa( $returned, 'XML::Twig') && $returned->{twig_finish_now})
792 |  |  |  |  | { $t= $returned;
793 |  |  |  |  | delete $t->{twig_finish_now};
794 |  |  |  |  | return $t->_twig_final;
795 |  |  |  |  | }
796 |  |  |  |  | else
797 |  |  |  |  | { _croak( $returned, 0); }
798 |  |  |  |  | }
799 |  |  |  |  |
800 | 7 | 4µs |  |  | $active_twig= $t;
801 | 7 | 7µs | 1 | 61µs | return $t; # spent 61µs making 1 call to XML::Twig::DESTROY
802 |  |  |  |  | }
803 |  |  |  |  |
804 |  |  |  |  | sub active_twig { return $active_twig; }
805 |  |  |  |  |
806 |  |  |  |  | sub finish_now
807 |  |  |  |  | { my $t= shift;
808 |  |  |  |  | $t->{twig_finish_now}=1;
809 |  |  |  |  | # XML::Parser 2.43 changed xpcroak in a way that caused test failures for XML::Twig
810 |  |  |  |  | # the change was reverted in 2.44, but this is here to ensure that tests pass with 2.43
811 |  |  |  |  | if( $XML::Parser::VERSION == 2.43)
812 | 2 | 1.82ms | 2 | 30µs | # spent 18µs (5+13) within XML::Twig::BEGIN@812 which was called: # once (5µs+13µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 812 { no warnings; # spent 18µs making 1 call to XML::Twig::BEGIN@812 # spent 12µs making 1 call to warnings::unimport
813 |  |  |  |  | $t->parser->{twig_error}= $t;
814 |  |  |  |  | *XML::Parser::Expat::xpcroak= sub { die $_[0]->{twig_error}; };
815 |  |  |  |  | die $t;
816 |  |  |  |  | }
817 |  |  |  |  | else
818 |  |  |  |  | { die $t; }
819 |  |  |  |  | }
820 |  |  |  |  |
821 |  |  |  |  |
822 |  |  |  |  | sub parsefile_inplace { shift->_parse_inplace( parsefile => @_); }
823 |  |  |  |  | sub parsefile_html_inplace { shift->_parse_inplace( parsefile_html => @_); }
824 |  |  |  |  |
825 |  |  |  |  | sub _parse_inplace
826 |  |  |  |  | { my( $t, $method, $file, $suffix)= @_;
827 |  |  |  |  | _use( 'File::Temp') || croak "need File::Temp to use inplace methods\n";
828 |  |  |  |  | _use( 'File::Basename');
829 |  |  |  |  |
830 |  |  |  |  |
831 |  |  |  |  | my $tmpdir= dirname( $file);
832 |  |  |  |  | my( $tmpfh, $tmpfile)= File::Temp::tempfile( DIR => $tmpdir);
833 |  |  |  |  | my $original_fh= select $tmpfh;
834 |  |  |  |  |
835 |  |  |  |  | # we can only use binmode :utf8 if perl was compiled with useperlio
836 |  |  |  |  | # might be a problem if keep_encoding used but the file is already in utf8
837 |  |  |  |  | if( $perl_version > 5.006 && !$t->{twig_keep_encoding} && _use_perlio()) { binmode( $tmpfh, ":utf8" ); }
838 |  |  |  |  |
839 |  |  |  |  | $t->$method( $file);
840 |  |  |  |  |
841 |  |  |  |  | select $original_fh;
842 |  |  |  |  | close $tmpfh;
843 |  |  |  |  | my $mode= (stat( $file))[2] & oct(7777);
844 |  |  |  |  | chmod $mode, $tmpfile or croak "cannot change temp file mode to $mode: $!";
845 |  |  |  |  |
846 |  |  |  |  | if( $suffix)
847 |  |  |  |  | { my $backup;
848 |  |  |  |  | if( $suffix=~ m{\*}) { ($backup = $suffix) =~ s/\*/$file/g; }
849 |  |  |  |  | else { $backup= $file . $suffix; }
850 |  |  |  |  |
851 |  |  |  |  | rename( $file, $backup) or croak "cannot backup initial file ($file) to $backup: $!";
852 |  |  |  |  | }
853 |  |  |  |  | rename( $tmpfile, $file) or croak "cannot rename temp file ($tmpfile) to initial file ($file): $!";
854 |  |  |  |  |
855 |  |  |  |  | return $t;
856 |  |  |  |  | }
857 |  |  |  |  |
858 |  |  |  |  |
859 |  |  |  |  | sub parseurl
860 |  |  |  |  | { my $t= shift;
861 |  |  |  |  | $t->_parseurl( 0, @_);
862 |  |  |  |  | }
863 |  |  |  |  |
864 |  |  |  |  | sub safe_parseurl
865 |  |  |  |  | { my $t= shift;
866 |  |  |  |  | $t->_parseurl( 1, @_);
867 |  |  |  |  | }
868 |  |  |  |  |
869 |  |  |  |  | sub safe_parsefile_html
870 |  |  |  |  | { my $t= shift;
871 |  |  |  |  | eval { $t->parsefile_html( @_); };
872 |  |  |  |  | return $@ ? $t->_reset_twig_after_error : $t;
873 |  |  |  |  | }
874 |  |  |  |  |
875 |  |  |  |  | sub safe_parseurl_html
876 |  |  |  |  | { my $t= shift;
877 |  |  |  |  | _use( 'LWP::Simple') or croak "missing LWP::Simple";
878 |  |  |  |  | eval { $t->parse_html( LWP::Simple::get( shift()), @_); } ;
879 |  |  |  |  | return $@ ? $t->_reset_twig_after_error : $t;
880 |  |  |  |  | }
881 |  |  |  |  |
882 |  |  |  |  | sub parseurl_html
883 |  |  |  |  | { my $t= shift;
884 |  |  |  |  | _use( 'LWP::Simple') or croak "missing LWP::Simple";
885 |  |  |  |  | $t->parse_html( LWP::Simple::get( shift()), @_);
886 |  |  |  |  | }
887 |  |  |  |  |
888 |  |  |  |  |
889 |  |  |  |  | # uses eval to catch the parser's death
890 |  |  |  |  | sub safe_parse_html
891 |  |  |  |  | { my $t= shift;
892 |  |  |  |  | eval { $t->parse_html( @_); } ;
893 |  |  |  |  | return $@ ? $t->_reset_twig_after_error : $t;
894 |  |  |  |  | }
895 |  |  |  |  |
896 |  |  |  |  | sub parsefile_html
897 |  |  |  |  | { my $t= shift;
898 |  |  |  |  | my $file= shift;
899 |  |  |  |  | my $indent= $t->{ErrorContext} ? 1 : 0;
900 |  |  |  |  | $t->set_empty_tag_style( 'html');
901 |  |  |  |  | my $html2xml= $t->{use_tidy} ? \&_tidy_html : \&_html2xml;
902 |  |  |  |  | my $options= $t->{use_tidy} ? $t->{tidy_options} || {} : { indent => $indent, html_doctype => $t->{html_doctype} };
903 |  |  |  |  | $t->parse( $html2xml->( _slurp( $file), $options), @_);
904 |  |  |  |  | return $t;
905 |  |  |  |  | }
906 |  |  |  |  |
907 |  |  |  |  | sub parse_html
908 |  |  |  |  | { my $t= shift;
909 |  |  |  |  | my $options= ref $_[0] && ref $_[0] eq 'HASH' ? shift() : {};
910 |  |  |  |  | my $use_tidy= exists $options->{use_tidy} ? $options->{use_tidy} : $t->{use_tidy};
911 |  |  |  |  | my $content= shift;
912 |  |  |  |  | my $indent= $t->{ErrorContext} ? 1 : 0;
913 |  |  |  |  | $t->set_empty_tag_style( 'html');
914 |  |  |  |  | my $html2xml= $use_tidy ? \&_tidy_html : \&_html2xml;
915 |  |  |  |  | my $conv_options= $use_tidy ? $t->{tidy_options} || {} : { indent => $indent, html_doctype => $t->{html_doctype} };
916 |  |  |  |  | $t->parse( $html2xml->( isa( $content, 'GLOB') ? _slurp_fh( $content) : $content, $conv_options), @_);
917 |  |  |  |  | return $t;
918 |  |  |  |  | }
919 |  |  |  |  |
920 |  |  |  |  | sub xparse
921 |  |  |  |  | { my $t= shift;
922 |  |  |  |  | my $to_parse= $_[0];
923 |  |  |  |  | if( isa( $to_parse, 'GLOB')) { $t->parse( @_); }
924 |  |  |  |  | elsif( $to_parse=~ m{^\s*<}) { $to_parse=~ m{<html}i ? $t->_parse_as_xml_or_html( @_)
925 |  |  |  |  | : $t->parse( @_);
926 |  |  |  |  | }
927 |  |  |  |  | elsif( $to_parse=~ m{^\w+://.*\.html?$}) { _use( 'LWP::Simple') or croak "missing LWP::Simple";
928 |  |  |  |  | $t->_parse_as_xml_or_html( LWP::Simple::get( shift()), @_);
929 |  |  |  |  | }
930 |  |  |  |  | elsif( $to_parse=~ m{^\w+://}) { _use( 'LWP::Simple') or croak "missing LWP::Simple";
931 |  |  |  |  | my $doc= LWP::Simple::get( shift);
932 |  |  |  |  | if( ! defined $doc) { $doc=''; }
933 |  |  |  |  | my $xml_parse_ok= $t->safe_parse( $doc, @_);
934 |  |  |  |  | if( $xml_parse_ok)
935 |  |  |  |  | { return $xml_parse_ok; }
936 |  |  |  |  | else
937 |  |  |  |  | { my $diag= $@;
938 |  |  |  |  | if( $doc=~ m{<html}i)
939 |  |  |  |  | { $t->parse_html( $doc, @_); }
940 |  |  |  |  | else
941 |  |  |  |  | { croak $diag; }
942 |  |  |  |  | }
943 |  |  |  |  | }
944 |  |  |  |  | elsif( $to_parse=~ m{\.html?$}) { my $content= _slurp( shift);
945 |  |  |  |  | $t->_parse_as_xml_or_html( $content, @_);
946 |  |  |  |  | }
947 |  |  |  |  | else { $t->parsefile( @_); }
948 |  |  |  |  | }
949 |  |  |  |  |
950 |  |  |  |  | sub _parse_as_xml_or_html
951 |  |  |  |  | { my $t= shift;
952 |  |  |  |  | if( _is_well_formed_xml( $_[0]))
953 |  |  |  |  | { $t->parse( @_) }
954 |  |  |  |  | else
955 |  |  |  |  | { my $html2xml= $t->{use_tidy} ? \&_tidy_html : \&_html2xml;
956 |  |  |  |  | my $options= $t->{use_tidy} ? $t->{tidy_options} || {} : { indent => 0, html_doctype => $t->{html_doctype} };
957 |  |  |  |  | my $html= $html2xml->( $_[0], $options, @_);
958 |  |  |  |  | if( _is_well_formed_xml( $html))
959 |  |  |  |  | { $t->parse( $html); }
960 |  |  |  |  | else
961 |  |  |  |  | { croak $@; } # can't really test this because HTML::Parser or HTML::Tidy may change how they deal with bas HTML between versions
962 |  |  |  |  | }
963 |  |  |  |  | }
964 |  |  |  |  |
965 | 1 | 200ns |  |  | { my $parser;
966 |  |  |  |  | sub _is_well_formed_xml
967 |  |  |  |  | { $parser ||= XML::Parser->new;
968 |  |  |  |  | eval { $parser->parse( $_[0]); };
969 |  |  |  |  | return $@ ? 0 : 1;
970 |  |  |  |  | }
971 |  |  |  |  | }
972 |  |  |  |  |
973 |  |  |  |  | sub nparse
974 | 1 | 300ns |  |  | { my $class= shift;
975 |  |  |  |  | my $to_parse= pop;
976 |  |  |  |  | $class->new( @_)->xparse( $to_parse);
977 |  |  |  |  | }
978 |  |  |  |  |
979 |  |  |  |  | sub nparse_pp { shift()->nparse( pretty_print => 'indented', @_); }
980 |  |  |  |  | sub nparse_e { shift()->nparse( error_context => 1, @_); }
981 |  |  |  |  | sub nparse_ppe { shift()->nparse( pretty_print => 'indented', error_context => 1, @_); }
982 |  |  |  |  |
983 |  |  |  |  |
984 |  |  |  |  | sub _html2xml
985 |  |  |  |  | { my( $html, $options)= @_;
986 |  |  |  |  | _use( 'HTML::TreeBuilder', '3.13') or croak "cannot parse HTML: missing HTML::TreeBuilder v >= 3.13\n";
987 |  |  |  |  | my $tree= HTML::TreeBuilder->new;
988 |  |  |  |  | $tree->ignore_ignorable_whitespace( 0);
989 |  |  |  |  | $tree->ignore_unknown( 0);
990 |  |  |  |  | $tree->no_space_compacting( 1);
991 |  |  |  |  | $tree->store_comments( 1);
992 |  |  |  |  | $tree->store_pis(1);
993 |  |  |  |  | $tree->parse( $html);
994 |  |  |  |  | $tree->eof;
995 |  |  |  |  |
996 |  |  |  |  | my $xml='';
997 |  |  |  |  | if( $options->{html_doctype} && exists $tree->{_decl} )
998 |  |  |  |  | { my $decl= $tree->{_decl}->as_XML;
999 |  |  |  |  |
1000 |  |  |  |  | # first try to fix declarations that are missing the SYSTEM part
1001 |  |  |  |  | $decl =~ s{^\s*<!DOCTYPE \s+ ((?i)html) \s+ PUBLIC \s+ "([^"]*)" \s* >}
1002 |  |  |  |  | { my $system= $HTML_DECL{$2} || $HTML_DECL{$DEFAULT_HTML_TYPE};
1003 |  |  |  |  | qq{<!DOCTYPE $1 PUBLIC "$2" "$system">}
1004 |  |  |  |  |
1005 |  |  |  |  | }xe;
1006 |  |  |  |  |
1007 |  |  |  |  | # then check that the declaration looks OK (so it parses), if not remove it,
1008 |  |  |  |  | # better to parse without the declaration than to die stupidly
1009 |  |  |  |  | if( $decl =~ m{<!DOCTYPE \s+ (?i:HTML) (\s+ PUBLIC \s+ "[^"]*" \s+ (SYSTEM \s+)? "[^"]*")? \s*>}x # PUBLIC then SYSTEM
1010 |  |  |  |  | || $decl =~ m{<!DOCTYPE \s+ (?i:HTML) \s+ SYSTEM \s+ "[^"]*" \s*>}x # just SYSTEM
1011 |  |  |  |  | )
1012 |  |  |  |  | { $xml= $decl; }
1013 |  |  |  |  | }
1014 |  |  |  |  |
1015 |  |  |  |  | $xml.= _as_XML( $tree);
1016 |  |  |  |  |
1017 |  |  |  |  |
1018 |  |  |  |  | _fix_xml( $tree, \$xml);
1019 |  |  |  |  |
1020 |  |  |  |  | if( $options->{indent}) { _indent_xhtml( \$xml); }
1021 |  |  |  |  | $tree->delete;
1022 |  |  |  |  | $xml=~ s{\s+$}{}s; # trim end
1023 |  |  |  |  | return $xml;
1024 |  |  |  |  | }
1025 |  |  |  |  |
1026 |  |  |  |  | sub _tidy_html
1027 |  |  |  |  | { my( $html, $options)= @_;
1028 |  |  |  |  | _use( 'HTML::Tidy') or croak "cannot cleanup HTML using HTML::Tidy (required by the use_tidy option): $@\n"; ;
1029 |  |  |  |  | my $TIDY_DEFAULTS= { output_xhtml => 1, # duh!
1030 |  |  |  |  | tidy_mark => 0, # do not add the "generated by tidy" comment
1031 |  |  |  |  | numeric_entities => 1,
1032 |  |  |  |  | char_encoding => 'utf8',
1033 |  |  |  |  | bare => 1,
1034 |  |  |  |  | clean => 1,
1035 |  |  |  |  | doctype => 'transitional',
1036 |  |  |  |  | fix_backslash => 1,
1037 |  |  |  |  | merge_divs => 0,
1038 |  |  |  |  | merge_spans => 0,
1039 |  |  |  |  | sort_attributes => 'alpha',
1040 |  |  |  |  | indent => 0,
1041 |  |  |  |  | wrap => 0,
1042 |  |  |  |  | break_before_br => 0,
1043 |  |  |  |  | };
1044 |  |  |  |  | $options ||= {};
1045 |  |  |  |  | my $tidy_options= { %$TIDY_DEFAULTS, %$options};
1046 |  |  |  |  | my $tidy = HTML::Tidy->new( $tidy_options);
1047 |  |  |  |  | $tidy->ignore( type => 1, type => 2 ); # 1 is TIDY_WARNING, 2 is TIDY_ERROR, not clean
1048 |  |  |  |  | my $xml= $tidy->clean( $html );
1049 |  |  |  |  | return $xml;
1050 |  |  |  |  | }
1051 |  |  |  |  |
1052 |  |  |  |  |
1053 | 1 | 200ns |  |  | { my %xml_parser_encoding;
1054 |  |  |  |  | sub _fix_xml
1055 |  |  |  |  | { my( $tree, $xml)= @_; # $xml is a ref to the xml string
1056 |  |  |  |  |
1057 |  |  |  |  | my $max_tries=5;
1058 |  |  |  |  | my $add_decl;
1059 |  |  |  |  |
1060 |  |  |  |  | while( ! _check_xml( $xml) && $max_tries--)
1061 |  |  |  |  | {
1062 |  |  |  |  | # a couple of fixes for weird HTML::TreeBuilder errors
1063 |  |  |  |  | if( $@=~ m{^\s*xml (or text )?declaration not at start of (external )?entity}i)
1064 |  |  |  |  | { $$xml=~ s{<\?xml.*?\?>}{}g;
1065 |  |  |  |  | #warn " fixed xml declaration in the wrong place\n";
1066 |  |  |  |  | }
1067 |  |  |  |  | elsif( $@=~ m{undefined entity})
1068 |  |  |  |  | { $$xml=~ s{&(amp;)?Amp;}{&amp;}g if $HTML::TreeBuilder::VERSION < 4.00;
1069 |  |  |  |  | if( _use( 'HTML::Entities::Numbered')) { $$xml=name2hex_xml( $$xml); }
1070 |  |  |  |  | $$xml=~ s{&(\w+);}{ my $ent= $1; if( $ent !~ m{^(amp|lt|gt|apos|quote)$}) { "&amp;$ent;" } }eg;
1071 |  |  |  |  | }
1072 |  |  |  |  | elsif( $@=~ m{&Amp; used in html})
1073 |  |  |  |  | # if $Amp; is used instead of &amp; then HTML::TreeBuilder's as_xml is tripped (old version)
1074 |  |  |  |  | { $$xml=~ s{&(amp;)?Amp;}{&amp;}g if $HTML::TreeBuilder::VERSION < 4.00;
1075 |  |  |  |  | }
1076 |  |  |  |  | elsif( $@=~ m{^\s*not well-formed \(invalid token\)})
1077 |  |  |  |  | { if( $HTML::TreeBuilder::VERSION < 4.00)
1078 |  |  |  |  | { $$xml=~ s{&(amp;)?Amp;}{&amp;}g;
1079 |  |  |  |  | $$xml=~ s{(<[^>]* )(\d+=)"}{$1a$2"}g; # <table 1> comes out as <table 1="1">, "fix the attribute
1080 |  |  |  |  | }
1081 |  |  |  |  | my $q= '<img "="&#34;" '; # extracted so vim doesn't get confused
1082 |  |  |  |  | if( _use( 'HTML::Entities::Numbered')) { $$xml=name2hex_xml( $$xml); }
1083 |  |  |  |  | if( $$xml=~ m{$q})
1084 |  |  |  |  | { $$xml=~ s{$q}{<img }g; # happens with <img src="foo.png"" ...
1085 |  |  |  |  | }
1086 |  |  |  |  | else
1087 |  |  |  |  | { my $encoding= _encoding_from_meta( $tree);
1088 |  |  |  |  | unless( keys %xml_parser_encoding) { %xml_parser_encoding= _xml_parser_encodings(); }
1089 |  |  |  |  |
1090 |  |  |  |  | if( ! $add_decl)
1091 |  |  |  |  | { if( $xml_parser_encoding{$encoding})
1092 |  |  |  |  | { $add_decl=1; }
1093 |  |  |  |  | elsif( $encoding eq 'euc-jp' && $xml_parser_encoding{'x-euc-jp-jisx0221'})
1094 |  |  |  |  | { $encoding="x-euc-jp-jisx0221"; $add_decl=1;}
1095 |  |  |  |  | elsif( $encoding eq 'shift-jis' && $xml_parser_encoding{'x-sjis-jisx0221'})
1096 |  |  |  |  | { $encoding="x-sjis-jisx0221"; $add_decl=1;}
1097 |  |  |  |  |
1098 |  |  |  |  | if( $add_decl)
1099 |  |  |  |  | { $$xml=~ s{^(<\?xml.*?\?>)?}{<?xml version="1.0" encoding="$encoding"?>}s;
1100 |  |  |  |  | #warn " added decl (encoding $encoding)\n";
1101 |  |  |  |  | }
1102 |  |  |  |  | else
1103 |  |  |  |  | { $$xml=~ s{^(<\?xml.*?\?>)?}{}s;
1104 |  |  |  |  | #warn " converting to utf8 from $encoding\n";
1105 |  |  |  |  | $$xml= _to_utf8( $encoding, $$xml);
1106 |  |  |  |  | }
1107 |  |  |  |  | }
1108 |  |  |  |  | else
1109 |  |  |  |  | { $$xml=~ s{^(<\?xml.*?\?>)?}{}s;
1110 |  |  |  |  | #warn " converting to utf8 from $encoding\n";
1111 |  |  |  |  | $$xml= _to_utf8( $encoding, $$xml);
1112 |  |  |  |  | }
1113 |  |  |  |  | }
1114 |  |  |  |  | }
1115 |  |  |  |  | }
1116 |  |  |  |  |
1117 |  |  |  |  | # some versions of HTML::TreeBuilder escape CDATA sections
1118 |  |  |  |  | $$xml=~ s{(&lt;!\[CDATA\[.*?\]\]&gt;)}{_unescape_cdata( $1)}eg;
1119 |  |  |  |  |
1120 |  |  |  |  | }
1121 |  |  |  |  |
1122 |  |  |  |  | sub _xml_parser_encodings
1123 |  |  |  |  | { my @encodings=( 'iso-8859-1'); # this one is included by default, there is no map for it in @INC
1124 |  |  |  |  | foreach my $inc (@INC)
1125 | 2 | 1.27ms | 1 | 480µs | # spent 480µs (307+173) within XML::Twig::BEGIN@1125 which was called: # once (307µs+173µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 1125 { push @encodings, map { basename( $_, '.enc') } glob( File::Spec->catdir( $inc => XML => Parser => Encodings => '*.enc')); } # spent 480µs making 1 call to XML::Twig::BEGIN@1125
1126 |  |  |  |  | return map { $_ => 1 } @encodings;
1127 |  |  |  |  | }
1128 |  |  |  |  | }
1129 |  |  |  |  |
1130 |  |  |  |  |
1131 |  |  |  |  | sub _unescape_cdata
1132 | 1 | 100ns |  |  | { my( $cdata)= @_;
1133 |  |  |  |  | $cdata=~s{&lt;}{<}g;
1134 |  |  |  |  | $cdata=~s{&gt;}{>}g;
1135 |  |  |  |  | $cdata=~s{&amp;}{&}g;
1136 |  |  |  |  | return $cdata;
1137 |  |  |  |  | }
1138 |  |  |  |  |
1139 |  |  |  |  | sub _as_XML {
1140 |  |  |  |  |
1141 |  |  |  |  | # fork of HTML::Element::as_XML, which is a little too buggy and inconsistent between versions for my liking
1142 |  |  |  |  | my ($elt) = @_;
1143 |  |  |  |  | my $xml= '';
1144 |  |  |  |  | my $empty_element_map = $elt->_empty_element_map;
1145 |  |  |  |  |
1146 |  |  |  |  | my ( $tag, $node, $start ); # per-iteration scratch
1147 |  |  |  |  | $elt->traverse(
1148 |  |  |  |  | sub {
1149 |  |  |  |  | ( $node, $start ) = @_;
1150 |  |  |  |  | if ( ref $node )
1151 |  |  |  |  | { # it's an element
1152 |  |  |  |  | $tag = $node->{'_tag'};
1153 |  |  |  |  | if ($start)
1154 |  |  |  |  | { # on the way in
1155 |  |  |  |  | foreach my $att ( grep { ! m{^(_|/$)} } keys %$node )
1156 |  |  |  |  | { # fix attribute names instead of dying
1157 |  |  |  |  | my $new_att= $att;
1158 |  |  |  |  | if( $att=~ m{^\d}) { $new_att= "a$att"; }
1159 |  |  |  |  | $new_att=~ s{[^\w\d:_-]}{}g;
1160 |  |  |  |  | $new_att ||= 'a';
1161 |  |  |  |  | if( $new_att ne $att) { $node->{$new_att}= delete $node->{$att}; }
1162 |  |  |  |  | }
1163 |  |  |  |  |
1164 |  |  |  |  | if ( $empty_element_map->{$tag} && (!@{ $node->{'_content'} || []}) )
1165 |  |  |  |  | { $xml.= $node->starttag_XML( undef, 1 ); }
1166 |  |  |  |  | else
1167 |  |  |  |  | { $xml.= $node->starttag_XML(undef); }
1168 |  |  |  |  | }
1169 |  |  |  |  | else
1170 |  |  |  |  | { # on the way out
1171 |  |  |  |  | unless ( $empty_element_map->{$tag} and !@{ $node->{'_content'} || [] } )
1172 |  |  |  |  | { $xml.= $node->endtag_XML();
1173 |  |  |  |  | } # otherwise it will have been an <... /> tag.
1174 |  |  |  |  | }
1175 |  |  |  |  | }
1176 |  |  |  |  | elsif( $node=~ /<!\[CDATA\[/) # the content includes CDATA
1177 |  |  |  |  | { foreach my $chunk (split /(<!\[CDATA\[.*?\]\]>)/s, $node) # chunks are CDATA sections or normal text
1178 |  |  |  |  | { $xml.= $chunk =~ m{<!\[CDATA\[} ? $chunk : _xml_escape( $chunk); }
1179 |  |  |  |  | }
1180 |  |  |  |  | else # it's just text
1181 |  |  |  |  | { $xml .= _xml_escape($node); }
1182 |  |  |  |  | 1; # keep traversing
1183 |  |  |  |  | }
1184 |  |  |  |  | );
1185 |  |  |  |  | return $xml;
1186 |  |  |  |  | }
1187 |  |  |  |  |
1188 |  |  |  |  | sub _xml_escape
1189 |  |  |  |  | { my( $html)= @_;
1190 |  |  |  |  | $html =~ s{&(?! # An ampersand that isn't followed by...
1191 |  |  |  |  | {&amp;}gx if 0; # Needs to be escaped to amp
1192 |  |  |  |  | \#x[0-9a-fA-F]+; | # A hash mark, "x", hex digits and semicolon, or
1193 |  |  |  |  | [\w]+; # A valid unicode entity name and semicolon
1194 |  |  |  |  | )
1195 |  |  |  |  | )
1196 |  |  |  |  | }
1197 |  |  |  |  |
1198 |  |  |  |  |
1199 |  |  |  |  | $html=~ s{&}{&amp;}g;
1200 |  |  |  |  |
1201 |  |  |  |  | # in old versions of HTML::TreeBuilder &amp; can come out as &Amp;
1202 |  |  |  |  | if( $HTML::TreeBuilder::VERSION && $HTML::TreeBuilder::VERSION <= 3.23) { $html=~ s{&Amp;}{&amp;}g; }
1203 |  |  |  |  |
1204 |  |  |  |  | # simple character escapes
1205 |  |  |  |  | $html =~ s/</&lt;/g;
1206 |  |  |  |  | $html =~ s/>/&gt;/g;
1207 |  |  |  |  | $html =~ s/"/&quot;/g;
1208 |  |  |  |  | $html =~ s/'/&apos;/g;
1209 |  |  |  |  |
1210 |  |  |  |  | return $html;
1211 |  |  |  |  | }
1212 |  |  |  |  |
- - |  |  |  |  |
1216 |  |  |  |  | sub _check_xml
1217 |  |  |  |  | { my( $xml)= @_; # $xml is a ref to the xml string
1218 |  |  |  |  | my $ok= eval { XML::Parser->new->parse( $$xml); };
1219 |  |  |  |  | #if( $ok) { warn " parse OK\n"; }
1220 |  |  |  |  | return $ok;
1221 |  |  |  |  | }
1222 |  |  |  |  |
1223 |  |  |  |  | sub _encoding_from_meta
1224 |  |  |  |  | { my( $tree)= @_;
1225 |  |  |  |  | my $enc="iso-8859-1";
1226 |  |  |  |  | my @meta= $tree->find( 'meta');
1227 |  |  |  |  | foreach my $meta (@meta)
1228 |  |  |  |  | { if( $meta->{'http-equiv'} && ($meta->{'http-equiv'} =~ m{^\s*content-type\s*}i)
1229 |  |  |  |  | && $meta->{content} && ($meta->{content} =~ m{^\s*text/html\s*;\s*charset\s*=\s*(\S*)\s*}i)
1230 |  |  |  |  | )
1231 |  |  |  |  | { $enc= lc $1;
1232 |  |  |  |  | #warn " encoding from meta tag is '$enc'\n";
1233 |  |  |  |  | last;
1234 |  |  |  |  | }
1235 |  |  |  |  | }
1236 |  |  |  |  | return $enc;
1237 |  |  |  |  | }
1238 |  |  |  |  |
1239 |  |  |  |  | { sub _to_utf8
1240 |  |  |  |  | { my( $encoding, $string)= @_;
1241 |  |  |  |  | local $SIG{__DIE__};
1242 |  |  |  |  | if( _use( 'Encode'))
1243 |  |  |  |  | { Encode::from_to( $string, $encoding => 'utf8', 0x0400); } # 0x0400 is Encode::FB_XMLCREF
1244 |  |  |  |  | elsif( _use( 'Text::Iconv'))
1245 |  |  |  |  | { my $converter = eval { Text::Iconv->new( $encoding => "utf8") };
1246 |  |  |  |  | if( $converter) { $string= $converter->convert( $string); }
1247 |  |  |  |  | }
1248 |  |  |  |  | elsif( _use( 'Unicode::Map8') && _use( 'Unicode::String'))
1249 |  |  |  |  | { my $map= Unicode::Map8->new( $encoding);
1250 |  |  |  |  | $string= $map->tou( $string)->utf8;
1251 |  |  |  |  | }
1252 |  |  |  |  | $string=~ s{[\x00-\x08\x0B\x0C\x0E-\x1F]}{}g; # get rid of control chars, portable in 5.6
1253 |  |  |  |  | return $string;
1254 |  |  |  |  | }
1255 |  |  |  |  | }
1256 |  |  |  |  |
1257 |  |  |  |  |
1258 |  |  |  |  | sub _indent_xhtml
1259 | 1 | 200ns |  |  | { my( $xhtml)= @_; # $xhtml is a ref
1260 |  |  |  |  | my %block_tag= map { $_ => 1 } qw( html
1261 |  |  |  |  | head
1262 |  |  |  |  | meta title link script base
1263 |  |  |  |  | body
1264 |  |  |  |  | h1 h2 h3 h4 h5 h6
1265 |  |  |  |  | p br address blockquote pre
1266 |  |  |  |  | ol ul li dd dl dt
1267 |  |  |  |  | table tr td th tbody tfoot thead col colgroup caption
1268 |  |  |  |  | div frame frameset hr
1269 |  |  |  |  | );
1270 |  |  |  |  |
1271 |  |  |  |  | my $level=0;
1272 |  |  |  |  | $$xhtml=~ s{( (?:<!(?:--.*?-->|[CDATA[.*?]]>)) # ignore comments and CDATA sections
1273 |  |  |  |  | { if( $2 && $block_tag{$2}) { my $indent= " " x $level;
1274 |  |  |  |  | "\n$indent<$2$3";
1275 |  |  |  |  | }
1276 |  |  |  |  | elsif( $4 && $block_tag{$4}) { my $indent= " " x $level;
1277 |  |  |  |  | $level++ unless( $4=~ m{/>});
1278 |  |  |  |  | my $nl= $4 eq 'html' ? '' : "\n";
1279 |  |  |  |  | "$nl$indent<$4";
1280 |  |  |  |  | }
1281 |  |  |  |  | elsif( $5 && $block_tag{$5}) { $level--; "</$5"; }
1282 |  |  |  |  | else { $1; }
1283 |  |  |  |  | }xesg;
1284 |  |  |  |  |
- - |  |  |  |  |
1289 |  |  |  |  | }
1290 |  |  |  |  |
1291 |  |  |  |  |
1292 |  |  |  |  | sub add_stylesheet
1293 |  |  |  |  | { my( $t, $type, $href)= @_;
1294 |  |  |  |  | my %text_type= map { $_ => 1 } qw( xsl css);
1295 |  |  |  |  | my $ss= $t->{twig_elt_class}->new( $PI);
1296 |  |  |  |  | if( $text_type{$type})
1297 |  |  |  |  | { $ss->_set_pi( 'xml-stylesheet', qq{type="text/$type" href="$href"}); }
1298 |  |  |  |  | else
1299 |  |  |  |  | { croak "unsupported style sheet type '$type'"; }
1300 |  |  |  |  |
1301 |  |  |  |  | $t->_add_cpi_outside_of_root( leading_cpi => $ss);
1302 |  |  |  |  | return $t;
1303 |  |  |  |  | }
1304 |  |  |  |  |
1305 | 1 | 100ns |  |  | { my %used; # module => 1 if require ok, 0 otherwise
1306 | 1 | 100ns |  |  | my %disallowed; # for testing, refuses to _use modules in this hash
1307 |  |  |  |  |
1308 |  |  |  |  | sub _disallow_use ## no critic (Subroutines::ProhibitNestedSubs);
1309 |  |  |  |  | { my( @modules)= @_;
1310 |  |  |  |  | $disallowed{$_}= 1 foreach (@modules);
1311 |  |  |  |  | }
1312 |  |  |  |  |
1313 |  |  |  |  | sub _allow_use ## no critic (Subroutines::ProhibitNestedSubs);
1314 |  |  |  |  | { my( @modules)= @_;
1315 |  |  |  |  | $disallowed{$_}= 0 foreach (@modules);
1316 |  |  |  |  | }
1317 |  |  |  |  |
1318 |  |  |  |  | sub _use ## no critic (Subroutines::ProhibitNestedSubs);
1319 | 7 | 2µs |  |  | # spent 2.49ms (1.59+902µs) within XML::Twig::_use which was called 7 times, avg 356µs/call: # 7 times (1.59ms+902µs) by XML::Twig::new at line 540, avg 356µs/call { my( $module, $version)= @_;
1320 | 7 | 2µs |  |  | $version ||= 0;
1321 | 7 | 2µs |  |  | if( $disallowed{$module}) { return 0; }
1322 | 7 | 9µs |  |  | if( $used{$module}) { return 1; }
1323 | 3 | 26µs | 1 | 2µs | if( eval "require $module") { import $module; $used{$module}= 1; # no critic ProhibitStringyEval # spent 2µs making 1 call to UNIVERSAL::import # spent 66µs executing statements in string eval
1324 | 1 | 300ns |  |  | if( $version)
1325 |  |  |  |  | {
1326 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
1327 | 2 | 5.26ms | 2 | 17µs | # spent 12µs (8+5) within XML::Twig::BEGIN@1327 which was called: # once (8µs+5µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 1327 no strict 'refs'; # spent 12µs making 1 call to XML::Twig::BEGIN@1327 # spent 4µs making 1 call to strict::unimport
1328 |  |  |  |  | if( ${"${module}::VERSION"} >= $version ) { return 1; }
1329 |  |  |  |  | else { return 0; }
1330 |  |  |  |  | }
1331 |  |  |  |  | else
1332 | 1 | 3µs |  |  | { return 1; }
1333 |  |  |  |  | }
1334 |  |  |  |  | else { $used{$module}= 0; return 0; }
1335 |  |  |  |  | }
1336 |  |  |  |  | }
1337 |  |  |  |  |
1338 |  |  |  |  | # used to solve the [n] predicates while avoiding getting the entire list
1339 |  |  |  |  | # needs a prototype to accept passing bare blocks
1340 | 1 | 100ns |  |  | sub _first_n(&$@) ## no critic (Subroutines::ProhibitSubroutinePrototypes);
1341 |  |  |  |  | { my $coderef= shift;
1342 |  |  |  |  | my $n= shift;
1343 |  |  |  |  | my $i=0;
1344 |  |  |  |  | if( $n > 0)
1345 |  |  |  |  | { foreach (@_) { if( &$coderef) { $i++; return $_ if( $i == $n); } } }
1346 |  |  |  |  | elsif( $n < 0)
1347 |  |  |  |  | { foreach (reverse @_) { if( &$coderef) { $i--; return $_ if( $i == $n); } } }
1348 |  |  |  |  | else
1349 |  |  |  |  | { croak "illegal position number 0"; }
1350 |  |  |  |  | return undef;
1351 |  |  |  |  | }
1352 |  |  |  |  |
1353 |  |  |  |  | sub _slurp_uri
1354 |  |  |  |  | { my( $uri, $base)= @_;
1355 |  |  |  |  | if( $uri=~ m{^\w+://}) { _use( 'LWP::Simple'); return LWP::Simple::get( $uri); }
1356 |  |  |  |  | else { return _slurp( _based_filename( $uri, $base)); }
1357 |  |  |  |  | }
1358 |  |  |  |  |
1359 |  |  |  |  | sub _based_filename
1360 |  |  |  |  | { my( $filename, $base)= @_;
1361 |  |  |  |  | # cf. XML/Parser.pm's file_ext_ent_handler
1362 |  |  |  |  | if (defined($base) and not ($filename =~ m{^(?:[\\/]|\w+:)}))
1363 |  |  |  |  | { my $newpath = $base;
1364 |  |  |  |  | $newpath =~ s{[^\\/:]*$}{$filename};
1365 |  |  |  |  | $filename = $newpath;
1366 |  |  |  |  | }
1367 |  |  |  |  | return $filename;
1368 |  |  |  |  | }
1369 |  |  |  |  |
1370 |  |  |  |  | sub _slurp
1371 |  |  |  |  | { my( $filename)= @_;
1372 |  |  |  |  | my $to_slurp;
1373 |  |  |  |  | open( $to_slurp, "<$filename") or croak "cannot open '$filename': $!";
1374 |  |  |  |  | local $/= undef;
1375 |  |  |  |  | my $content= <$to_slurp>;
1376 |  |  |  |  | close $to_slurp;
1377 |  |  |  |  | return $content;
1378 |  |  |  |  | }
1379 |  |  |  |  |
1380 |  |  |  |  | sub _slurp_fh
1381 |  |  |  |  | { my( $fh)= @_;
1382 |  |  |  |  | local $/= undef;
1383 |  |  |  |  | my $content= <$fh>;
1384 |  |  |  |  | return $content;
1385 |  |  |  |  | }
1386 |  |  |  |  |
1387 |  |  |  |  | # I should really add extra options to allow better configuration of the
1388 |  |  |  |  | # LWP::UserAgent object
1389 |  |  |  |  | # this method forks (except on VMS!)
1390 |  |  |  |  | # - the child gets the data and copies it to the pipe,
1391 |  |  |  |  | # - the parent reads the stream and sends it to XML::Parser
1392 |  |  |  |  | # the data is cut it chunks the size of the XML::Parser::Expat buffer
1393 |  |  |  |  | # the method returns the twig and the status
1394 |  |  |  |  | sub _parseurl
1395 |  |  |  |  | { my( $t, $safe, $url, $agent)= @_;
1396 |  |  |  |  | _use( 'LWP') || croak "LWP not available, needed to use parseurl methods";
1397 |  |  |  |  | if( $^O ne 'VMS')
1398 |  |  |  |  | { pipe( README, WRITEME) or croak "cannot create connected pipes: $!";
1399 |  |  |  |  | if( my $pid= fork)
1400 |  |  |  |  | { # parent code: parse the incoming file
1401 |  |  |  |  | close WRITEME; # no need to write
1402 |  |  |  |  | my $result= $safe ? $t->safe_parse( \*README) : $t->parse( \*README);
1403 |  |  |  |  | close README;
1404 |  |  |  |  | return $@ ? 0 : $t;
1405 |  |  |  |  | }
1406 |  |  |  |  | else
1407 |  |  |  |  | { # child
1408 |  |  |  |  | close README; # no need to read
1409 |  |  |  |  | local $|=1;
1410 |  |  |  |  | $agent ||= LWP::UserAgent->new;
1411 |  |  |  |  | my $request = HTTP::Request->new( GET => $url);
1412 |  |  |  |  | # _pass_url_content is called with chunks of data the same size as
1413 |  |  |  |  | # the XML::Parser buffer
1414 |  |  |  |  | my $response = $agent->request( $request,
1415 |  |  |  |  | sub { _pass_url_content( \*WRITEME, @_); }, $BUFSIZE);
1416 |  |  |  |  | $response->is_success or croak "$url ", $response->message;
1417 |  |  |  |  | close WRITEME;
1418 |  |  |  |  | CORE::exit(); # CORE is there for mod_perl (which redefines exit)
1419 |  |  |  |  | }
1420 |  |  |  |  | }
1421 |  |  |  |  | else
1422 |  |  |  |  | { # VMS branch (hard to test!)
1423 |  |  |  |  | local $|=1;
1424 |  |  |  |  | $agent ||= LWP::UserAgent->new;
1425 |  |  |  |  | my $request = HTTP::Request->new( GET => $url);
1426 |  |  |  |  | my $response = $agent->request( $request);
1427 |  |  |  |  | $response->is_success or croak "$url ", $response->message;
1428 |  |  |  |  | my $result= $safe ? $t->safe_parse($response->content) : $t->parse($response->content);
1429 |  |  |  |  | return $@ ? 0 : $t;
1430 |  |  |  |  | }
1431 |  |  |  |  |
1432 |  |  |  |  | }
1433 |  |  |  |  |
1434 |  |  |  |  | # get the (hopefully!) XML data from the URL and
1435 |  |  |  |  | sub _pass_url_content
1436 |  |  |  |  | { my( $fh, $data, $response, $protocol)= @_;
1437 |  |  |  |  | print {$fh} $data;
1438 |  |  |  |  | }
1439 |  |  |  |  |
1440 |  |  |  |  | sub add_options
1441 |  |  |  |  | { my %args= map { $_, 1 } @_;
1442 |  |  |  |  | %args= _normalize_args( %args);
1443 |  |  |  |  | foreach (keys %args) { $valid_option{$_}++; }
1444 |  |  |  |  | }
1445 |  |  |  |  |
1446 |  |  |  |  | sub _pretty_print_styles { return XML::Twig::Elt::_pretty_print_styles(); }
1447 |  |  |  |  |
1448 |  |  |  |  | sub _twig_store_internal_dtd
1449 |  |  |  |  | {
1450 |  |  |  |  | # warn " in _twig_store_internal_dtd...\n"; # DEBUG handler
1451 |  |  |  |  | my( $p, $string)= @_;
1452 |  |  |  |  | my $t= $p->{twig};
1453 |  |  |  |  | if( $t->{twig_keep_encoding}) { $string= $p->original_string(); }
1454 |  |  |  |  | $t->{twig_doctype}->{internal} .= $string;
1455 |  |  |  |  | return;
1456 |  |  |  |  | }
1457 |  |  |  |  |
1458 |  |  |  |  | sub _twig_stop_storing_internal_dtd
1459 |  |  |  |  | { # warn " in _twig_stop_storing_internal_dtd...\n"; # DEBUG handler
1460 |  |  |  |  | my $p= shift;
1461 |  |  |  |  | if( @saved_default_handler && defined $saved_default_handler[1])
1462 |  |  |  |  | { $p->setHandlers( @saved_default_handler); }
1463 |  |  |  |  | else
1464 |  |  |  |  | {
1465 |  |  |  |  | $p->setHandlers( Default => undef);
1466 |  |  |  |  | }
1467 |  |  |  |  | $p->{twig}->{twig_doctype}->{internal}=~ s{^\s*\[}{};
1468 |  |  |  |  | $p->{twig}->{twig_doctype}->{internal}=~ s{\]\s*$}{};
1469 |  |  |  |  | return;
1470 |  |  |  |  | }
1471 |  |  |  |  |
1472 |  |  |  |  | sub _twig_doctype_fin_print
1473 |  |  |  |  | { # warn " in _twig_doctype_fin_print...\n"; # DEBUG handler
1474 |  |  |  |  | my( $p)= shift;
1475 |  |  |  |  | if( $p->{twig}->{twig_doctype}->{has_internal} && !$expat_1_95_2) { print ' ]>'; }
1476 |  |  |  |  | return;
1477 |  |  |  |  | }
1478 |  |  |  |  |
1479 |  |  |  |  |
1480 |  |  |  |  | sub _normalize_args
1481 | 7 | 900ns |  |  | # spent 63µs within XML::Twig::_normalize_args which was called 7 times, avg 9µs/call: # 7 times (63µs+0s) by XML::Twig::new at line 454, avg 9µs/call { my %normalized_args;
1482 | 7 | 9µs |  |  | while( my $key= shift )
1483 | 23 | 35µs |  |  | { $key= join '', map { ucfirst } split /_/, $key;
1484 |  |  |  |  | #$key= "Twig".$key unless( substr( $key, 0, 4) eq 'Twig');
1485 | 23 | 8µs |  |  | $normalized_args{$key}= shift ;
1486 |  |  |  |  | }
1487 | 7 | 14µs |  |  | return %normalized_args;
1488 |  |  |  |  | }
1489 |  |  |  |  |
1490 |  |  |  |  | sub _is_fh { return unless $_[0]; return $_[0] if( isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar')); }
1491 |  |  |  |  |
1492 |  |  |  |  | sub _set_handler
1493 | 21 | 7µs |  |  | # spent 8.48ms (382µs+8.10) within XML::Twig::_set_handler which was called 21 times, avg 404µs/call: # 11 times (212µs+5.88ms) by XML::Twig::_set_handlers at line 1863, avg 553µs/call # 10 times (170µs+2.22ms) by XML::Twig::setTwigRoots at line 1937, avg 239µs/call { my( $handlers, $whole_path, $handler)= @_;
1494 |  |  |  |  |
1495 | 21 | 106µs | 42 | 64µs | my $H_SPECIAL = qr{($ALL|$DEFAULT|$COMMENT|$TEXT)}; # spent 51µs making 21 calls to CORE::regcomp, avg 2µs/call # spent 13µs making 21 calls to CORE::qr, avg 638ns/call
1496 | 21 | 74µs | 42 | 44µs | my $H_PI = qr{(\?|$PI)\s*(([^\s]*)\s*)}; # spent 39µs making 21 calls to CORE::regcomp, avg 2µs/call # spent 4µs making 21 calls to CORE::qr, avg 214ns/call
1497 | 21 | 18µs | 21 | 5µs | my $H_LEVEL = qr{level \s* \( \s* ([0-9]+) \s* \)}x; # spent 5µs making 21 calls to CORE::qr, avg 229ns/call
1498 | 21 | 18µs | 21 | 4µs | my $H_REGEXP = qr{\(\?([\^xism]*)(-[\^xism]*)?:(.*)\)}x; # spent 4µs making 21 calls to CORE::qr, avg 214ns/call
1499 | 21 | 729µs | 42 | 697µs | my $H_XPATH = qr{(/?/?$REG_TAG_PART? \s* ($REG_PREDICATE\s*)?)+}x; # spent 692µs making 21 calls to CORE::regcomp, avg 33µs/call # spent 5µs making 21 calls to CORE::qr, avg 229ns/call
1500 |  |  |  |  |
1501 | 21 | 2µs |  |  | my $prev_handler;
1502 |  |  |  |  |
1503 | 21 | 4µs |  |  | my $cpath= $whole_path;
1504 |  |  |  |  | #warn "\$cpath: '$cpath\n";
1505 | 21 | 963µs | 42 | 914µs | while( $cpath && $cpath=~ s{^\s*($H_SPECIAL|$H_PI|$H_LEVEL|$H_REGEXP|$H_XPATH)\s*($|\|)}{}) # spent 792µs making 21 calls to CORE::regcomp, avg 38µs/call # spent 122µs making 21 calls to CORE::subst, avg 6µs/call
1506 | 21 | 15µs |  |  | { my $path= $1;
1507 |  |  |  |  | #warn "\$cpath: '$cpath' - $path: '$path'\n";
1508 | 21 | 13µs |  |  | $prev_handler ||= $handlers->{handlers}->{string}->{$path} || undef; # $prev_handler gets the first found handler
1509 |  |  |  |  |
1510 | 21 | 64µs | 105 | 6.37ms | _set_special_handler ( $handlers, $path, $handler, $prev_handler) # spent 6.12ms making 21 calls to XML::Twig::_set_xpath_handler, avg 292µs/call # spent 92µs making 21 calls to XML::Twig::_set_pi_handler, avg 4µs/call # spent 88µs making 21 calls to XML::Twig::_set_special_handler, avg 4µs/call # spent 36µs making 21 calls to XML::Twig::_set_level_handler, avg 2µs/call # spent 32µs making 21 calls to XML::Twig::_set_regexp_handler, avg 2µs/call
1511 |  |  |  |  | || _set_pi_handler ( $handlers, $path, $handler, $prev_handler)
1512 |  |  |  |  | || _set_level_handler ( $handlers, $path, $handler, $prev_handler)
1513 |  |  |  |  | || _set_regexp_handler ( $handlers, $path, $handler, $prev_handler)
1514 |  |  |  |  | || _set_xpath_handler ( $handlers, $path, $handler, $prev_handler)
1515 |  |  |  |  | || croak "unrecognized expression in handler: '$whole_path'";
1516 |  |  |  |  |
1517 |  |  |  |  | # this both takes care of the simple (gi) handlers and store
1518 |  |  |  |  | # the handler code reference for other handlers
1519 | 21 | 21µs |  |  | $handlers->{handlers}->{string}->{$path}= $handler;
1520 |  |  |  |  | }
1521 |  |  |  |  |
1522 | 21 | 2µs |  |  | if( $cpath) { croak "unrecognized expression in handler: '$whole_path'"; }
1523 |  |  |  |  |
1524 | 21 | 49µs |  |  | return $prev_handler;
1525 |  |  |  |  | }
1526 |  |  |  |  |
1527 |  |  |  |  |
1528 |  |  |  |  | sub _set_special_handler
1529 | 21 | 7µs |  |  | # spent 88µs (48+40) within XML::Twig::_set_special_handler which was called 21 times, avg 4µs/call: # 21 times (48µs+40µs) by XML::Twig::_set_handler at line 1510, avg 4µs/call { my( $handlers, $path, $handler, $prev_handler)= @_;
1530 | 21 | 64µs | 22 | 40µs | if( $path =~ m{^\s*($ALL|$DEFAULT|$COMMENT|$TEXT)\s*$}io ) # spent 24µs making 1 call to CORE::regcomp # spent 16µs making 21 calls to CORE::match, avg 786ns/call
1531 |  |  |  |  | { $handlers->{handlers}->{$1}= $handler;
1532 |  |  |  |  | return 1;
1533 |  |  |  |  | }
1534 |  |  |  |  | else
1535 | 21 | 24µs |  |  | { return 0; }
1536 |  |  |  |  | }
1537 |  |  |  |  |
1538 |  |  |  |  | sub _set_xpath_handler
1539 | 21 | 4µs |  |  | # spent 6.12ms (94µs+6.03) within XML::Twig::_set_xpath_handler which was called 21 times, avg 292µs/call: # 21 times (94µs+6.03ms) by XML::Twig::_set_handler at line 1510, avg 292µs/call { my( $handlers, $path, $handler, $prev_handler)= @_;
1540 | 21 | 14µs | 21 | 5.96ms | if( my $handler_data= _parse_xpath_handler( $path, $handler)) # spent 5.96ms making 21 calls to XML::Twig::_parse_xpath_handler, avg 284µs/call
1541 | 21 | 20µs | 21 | 72µs | { _add_handler( $handlers, $handler_data, $path, $prev_handler); # spent 72µs making 21 calls to XML::Twig::_add_handler, avg 3µs/call
1542 | 21 | 28µs |  |  | return 1;
1543 |  |  |  |  | }
1544 |  |  |  |  | else
1545 |  |  |  |  | { return 0; }
1546 |  |  |  |  | }
1547 |  |  |  |  |
1548 |  |  |  |  | sub _add_handler
1549 | 21 | 10µs |  |  | # spent 72µs within XML::Twig::_add_handler which was called 21 times, avg 3µs/call: # 21 times (72µs+0s) by XML::Twig::_set_xpath_handler at line 1541, avg 3µs/call { my( $handlers, $handler_data, $path, $prev_handler)= @_;
1550 |  |  |  |  |
1551 | 21 | 7µs |  |  | my $tag= $handler_data->{tag};
1552 | 21 | 11µs |  |  | my @handlers= $handlers->{xpath_handler}->{$tag} ? @{$handlers->{xpath_handler}->{$tag}} : ();
1553 |  |  |  |  |
1554 | 21 | 2µs |  |  | if( $prev_handler) { @handlers= grep { $_->{path} ne $path } @handlers; }
1555 |  |  |  |  |
1556 | 21 | 10µs |  |  | push @handlers, $handler_data if( $handler_data->{handler});
1557 |  |  |  |  |
1558 | 21 | 7µs |  |  | if( @handlers > 1)
1559 |  |  |  |  | { @handlers= sort { (($b->{score}->{type} || 0) <=> ($a->{score}->{type} || 0))
1560 |  |  |  |  | || (($b->{score}->{anchored} || 0) <=> ($a->{score}->{anchored} || 0))
1561 |  |  |  |  | || (($b->{score}->{steps} || 0) <=> ($a->{score}->{steps} || 0))
1562 |  |  |  |  | || (($b->{score}->{predicates} || 0) <=> ($a->{score}->{predicates} || 0))
1563 |  |  |  |  | || (($b->{score}->{tests} || 0) <=> ($a->{score}->{tests} || 0))
1564 |  |  |  |  | || ($a->{path} cmp $b->{path})
1565 |  |  |  |  | } @handlers;
1566 |  |  |  |  | }
1567 |  |  |  |  |
1568 | 21 | 31µs |  |  | $handlers->{xpath_handler}->{$tag}= \@handlers;
1569 |  |  |  |  | }
1570 |  |  |  |  |
1571 |  |  |  |  | sub _set_pi_handler
1572 | 21 | 4µs |  |  | # spent 92µs (48+44) within XML::Twig::_set_pi_handler which was called 21 times, avg 4µs/call: # 21 times (48µs+44µs) by XML::Twig::_set_handler at line 1510, avg 4µs/call { my( $handlers, $path, $handler, $prev_handler)= @_;
1573 |  |  |  |  | # PI conditions ( '?target' => \&handler or '?' => \&handler
1574 |  |  |  |  | # or '#PItarget' => \&handler or '#PI' => \&handler)
1575 | 21 | 74µs | 42 | 44µs | if( $path=~ /^\s*(?:\?|$PI)\s*(?:([^\s]*)\s*)$/) # spent 36µs making 21 calls to CORE::regcomp, avg 2µs/call # spent 8µs making 21 calls to CORE::match, avg 381ns/call
1576 |  |  |  |  | { my $target= $1 || '';
1577 |  |  |  |  | # update the path_handlers count, knowing that
1578 |  |  |  |  | # either the previous or the new handler can be undef
1579 |  |  |  |  | $handlers->{pi_handlers}->{$1}= $handler;
1580 |  |  |  |  | return 1;
1581 |  |  |  |  | }
1582 |  |  |  |  | else
1583 | 21 | 20µs |  |  | { return 0;
1584 |  |  |  |  | }
1585 |  |  |  |  | }
1586 |  |  |  |  |
1587 |  |  |  |  | sub _set_level_handler
1588 | 21 | 4µs |  |  | # spent 36µs (31+4) within XML::Twig::_set_level_handler which was called 21 times, avg 2µs/call: # 21 times (31µs+4µs) by XML::Twig::_set_handler at line 1510, avg 2µs/call { my( $handlers, $path, $handler, $prev_handler)= @_;
1589 | 21 | 20µs | 21 | 4µs | if( $path =~ m{^ \s* level \s* \( \s* ([0-9]+) \s* \) \s* $}ox ) # spent 4µs making 21 calls to CORE::match, avg 210ns/call
1590 |  |  |  |  | { my $level= $1;
1591 |  |  |  |  | my $sub= sub { my( $stack)= @_; return( ($stack->[-1]->{$ST_TAG} !~ m{^#}) && (scalar @$stack == $level + 1) ) };
1592 |  |  |  |  | my $handler_data= { tag=> '*', score => { type => $LEVEL_TRIGGER}, trigger => $sub,
1593 |  |  |  |  | path => $path, handler => $handler, test_on_text => 0
1594 |  |  |  |  | };
1595 |  |  |  |  | _add_handler( $handlers, $handler_data, $path, $prev_handler);
1596 |  |  |  |  | return 1;
1597 |  |  |  |  | }
1598 |  |  |  |  | else
1599 | 21 | 18µs |  |  | { return 0; }
1600 |  |  |  |  | }
1601 |  |  |  |  |
1602 |  |  |  |  | sub _set_regexp_handler
1603 | 21 | 4µs |  |  | # spent 32µs (29+3) within XML::Twig::_set_regexp_handler which was called 21 times, avg 2µs/call: # 21 times (29µs+3µs) by XML::Twig::_set_handler at line 1510, avg 2µs/call { my( $handlers, $path, $handler, $prev_handler)= @_;
1604 |  |  |  |  | # if the expression was a regexp it is now a string (it was stringified when it became a hash key)
1605 | 21 | 17µs | 21 | 3µs | if( $path=~ m{^\(\?([\^xism]*)(?:-[\^xism]*)?:(.*)\)$}) # spent 3µs making 21 calls to CORE::match, avg 133ns/call
1606 |  |  |  |  | { my $regexp= qr/(?$1:$2)/; # convert it back into a regexp
1607 |  |  |  |  | my $sub= sub { my( $stack)= @_; return( $stack->[-1]->{$ST_TAG} =~ $regexp ) };
1608 |  |  |  |  | my $handler_data= { tag=> '*', score => { type => $REGEXP_TRIGGER} , trigger => $sub,
1609 |  |  |  |  | path => $path, handler => $handler, test_on_text => 0
1610 |  |  |  |  | };
1611 |  |  |  |  | _add_handler( $handlers, $handler_data, $path, $prev_handler);
1612 |  |  |  |  | return 1;
1613 |  |  |  |  | }
1614 |  |  |  |  | else
1615 | 21 | 16µs |  |  | { return 0; }
1616 |  |  |  |  | }
1617 |  |  |  |  |
1618 | 1 | 100ns |  |  | my $DEBUG_HANDLER= 0; # 0 or 1 (output the handler checking code) or 2 (super verbose)
1619 | 1 | 100ns |  |  | my $handler_string; # store the handler itself
1620 |  |  |  |  | sub _set_debug_handler { $DEBUG_HANDLER= shift; }
1621 |  |  |  |  | sub _warn_debug_handler { if( $DEBUG_HANDLER < 3) { warn @_; } else { $handler_string .= join( '', @_); } }
1622 |  |  |  |  | sub _return_debug_handler { my $string= $handler_string; $handler_string=''; return $string; }
1623 |  |  |  |  |
1624 |  |  |  |  | sub _parse_xpath_handler
1625 | 21 | 5µs |  |  | # spent 5.96ms (3.22+2.74) within XML::Twig::_parse_xpath_handler which was called 21 times, avg 284µs/call: # 21 times (3.22ms+2.74ms) by XML::Twig::_set_xpath_handler at line 1540, avg 284µs/call { my( $xpath, $handler)= @_;
1626 | 21 | 4µs |  |  | my $xpath_original= $xpath;
1627 |  |  |  |  |
1628 |  |  |  |  |
1629 | 21 | 3µs |  |  | if( $DEBUG_HANDLER >=1) { _warn_debug_handler( "\n\nparsing path '$xpath'\n"); }
1630 |  |  |  |  |
1631 | 21 | 3µs |  |  | my $path_to_check= $xpath;
1632 | 21 | 814µs | 42 | 777µs | $path_to_check=~ s{/?/?$REG_TAG_PART?\s*(?:$REG_PREDICATE\s*)?}{}g; # spent 689µs making 21 calls to CORE::regcomp, avg 33µs/call # spent 87µs making 21 calls to CORE::subst, avg 4µs/call
1633 | 21 | 3µs |  |  | if( $DEBUG_HANDLER && $path_to_check=~ /\S/) { _warn_debug_handler( "left: $path_to_check\n"); }
1634 | 21 | 21µs | 21 | 2µs | return if( $path_to_check=~ /\S/); # spent 2µs making 21 calls to CORE::match, avg 105ns/call
1635 |  |  |  |  |
1636 | 21 | 25µs | 21 | 9µs | (my $xpath_to_display= $xpath)=~ s{(["{}'\[\]\@\$])}{\\$1}g; # spent 9µs making 21 calls to CORE::subst, avg 410ns/call
1637 |  |  |  |  |
1638 | 21 | 3µs |  |  | my @xpath_steps;
1639 |  |  |  |  | my $last_token_is_sep;
1640 |  |  |  |  |
1641 | 21 | 1.06ms | 42 | 1.02ms | while( $xpath=~ s{^\s* # spent 989µs making 21 calls to CORE::regcomp, avg 47µs/call # spent 32µs making 21 calls to CORE::subst, avg 2µs/call
1642 |  |  |  |  | {}x
1643 |  |  |  |  | | (?:$REG_TAG_PART\s*(?:$REG_PREDICATE\s*)?) # tag name and optional predicate
1644 |  |  |  |  | | (?:$REG_PREDICATE) # just a predicate
1645 |  |  |  |  | )
1646 |  |  |  |  | }
1647 |  |  |  |  |
1648 |  |  |  |  | )
1649 |  |  |  |  | { # check that we have alternating separators and steps
1650 | 33 | 11µs |  |  | if( $2) # found a separator
1651 | 6 | 700ns |  |  | { if( $last_token_is_sep) { return 0; } # 2 separators in a row
1652 | 6 | 700ns |  |  | $last_token_is_sep= 1;
1653 |  |  |  |  | }
1654 |  |  |  |  | else
1655 | 27 | 6µs |  |  | { if( defined( $last_token_is_sep) && !$last_token_is_sep) { return 0; } # 2 steps in a row
1656 | 27 | 4µs |  |  | $last_token_is_sep= 0;
1657 |  |  |  |  | }
1658 |  |  |  |  |
1659 | 33 | 119µs | 66 | 46µs | push @xpath_steps, $1; # spent 31µs making 33 calls to CORE::regcomp, avg 948ns/call # spent 14µs making 33 calls to CORE::subst, avg 439ns/call
1660 |  |  |  |  | }
1661 | 21 | 2µs |  |  | if( $last_token_is_sep) { return 0; } # expression cannot end with a separator
1662 |  |  |  |  |
1663 | 21 | 3µs |  |  | my $i=-1;
1664 |  |  |  |  |
1665 | 21 | 29µs | 21 | 29µs | my $perlfunc= _join_n( $NO_WARNINGS . ';', # spent 29µs making 21 calls to XML::Twig::_join_n, avg 1µs/call
1666 |  |  |  |  | q|my( $stack)= @_; |,
1667 |  |  |  |  | q|my @current_elts= (scalar @$stack); |,
1668 |  |  |  |  | q|my @new_current_elts; |,
1669 |  |  |  |  | q|my $elt; |,
1670 |  |  |  |  | ($DEBUG_HANDLER >= 1) && (qq#warn q{checking path '$xpath_to_display'\n};#),
1671 |  |  |  |  | );
1672 |  |  |  |  |
1673 |  |  |  |  |
1674 | 21 | 3µs |  |  | my $last_tag='';
1675 | 21 | 26µs | 21 | 8µs | my $anchored= $xpath_original=~ m{^\s*/(?!/)} ? 1 : 0; # spent 8µs making 21 calls to CORE::match, avg 400ns/call
1676 | 21 | 18µs |  |  | my $score={ type => $XPATH_TRIGGER, anchored => $anchored };
1677 | 21 | 9µs |  |  | my $flag= { test_on_text => 0 };
1678 | 21 | 3µs |  |  | my $sep='/'; # '/' or '//'
1679 | 21 | 21µs |  |  | while( my $xpath_step= pop @xpath_steps)
1680 | 27 | 381µs | 54 | 331µs | { my( $tag, $predicate)= $xpath_step =~ m{^($REG_TAG_PART)?(?:\[(.*)\])?\s*$}; # spent 292µs making 27 calls to CORE::regcomp, avg 11µs/call # spent 39µs making 27 calls to CORE::match, avg 1µs/call
1681 | 27 | 10µs |  |  | $score->{steps}++;
1682 | 27 | 3µs |  |  | $tag||='*';
1683 |  |  |  |  |
1684 | 27 | 6µs |  |  | my $warn_empty_stack= $DEBUG_HANDLER >= 2 ? qq{warn "return with empty stack\\n";} : '';
1685 |  |  |  |  |
1686 | 27 | 3µs |  |  | if( $predicate)
1687 |  |  |  |  | { if( $DEBUG_HANDLER >= 2) { _warn_debug_handler( "predicate is: '$predicate'\n"); }
1688 |  |  |  |  | # changes $predicate (from an XPath expression to a Perl one)
1689 |  |  |  |  | if( $predicate=~ m{^\s*$REG_NUMBER\s*$}) { croak "position selector [$predicate] not supported on twig_handlers"; }
1690 |  |  |  |  | _parse_predicate_in_handler( $predicate, $flag, $score);
1691 |  |  |  |  | if( $DEBUG_HANDLER >= 2) { _warn_debug_handler( "predicate becomes: '$predicate'\n"); }
1692 |  |  |  |  | }
1693 |  |  |  |  |
1694 | 27 | 17µs | 27 | 120µs | my $tag_cond= _tag_cond( $tag); # spent 120µs making 27 calls to XML::Twig::_tag_cond, avg 4µs/call
1695 | 27 | 13µs |  |  | my $cond= join( " && ", grep { $_ } $tag_cond, $predicate) || 1;
1696 |  |  |  |  |
1697 | 27 | 3µs |  |  | if( $css_sel && $tag=~ m{\.}) { $tag=~s{\.[^.]*$}{}; $tag ||='*'; }
1698 | 27 | 24µs | 27 | 5µs | $tag=~ s{(.)#.+$}{$1}; # spent 5µs making 27 calls to CORE::subst, avg 196ns/call
1699 |  |  |  |  |
1700 | 27 | 5µs |  |  | $last_tag ||= $tag;
1701 |  |  |  |  |
1702 | 27 | 46µs | 27 | 18µs | if( $sep eq '/') # spent 18µs making 27 calls to XML::Twig::_join_n, avg 667ns/call
1703 |  |  |  |  | {
1704 |  |  |  |  | $perlfunc .= sprintf( _join_n( q#foreach my $current_elt (@current_elts) #,
1705 |  |  |  |  | q# { next if( !$current_elt); #,
1706 |  |  |  |  | q# $current_elt--; #,
1707 |  |  |  |  | q# $elt= $stack->[$current_elt]; #,
1708 |  |  |  |  | q# if( %s) { push @new_current_elts, $current_elt;} #,
1709 |  |  |  |  | q# } #,
1710 |  |  |  |  | ),
1711 |  |  |  |  | $cond
1712 |  |  |  |  | );
1713 |  |  |  |  | }
1714 |  |  |  |  | elsif( $sep eq '//')
1715 |  |  |  |  | {
1716 |  |  |  |  | $perlfunc .= sprintf( _join_n( q#foreach my $current_elt (@current_elts) #,
1717 |  |  |  |  | q# { next if( !$current_elt); #,
1718 |  |  |  |  | q# $current_elt--; #,
1719 |  |  |  |  | q# my $candidate= $current_elt; #,
1720 |  |  |  |  | q# while( $candidate >=0) #,
1721 |  |  |  |  | q# { $elt= $stack->[$candidate]; #,
1722 |  |  |  |  | q# if( %s) { push @new_current_elts, $candidate;} #,
1723 |  |  |  |  | q# $candidate--; #,
1724 |  |  |  |  | q# } #,
1725 |  |  |  |  | q# } #,
1726 |  |  |  |  | ),
1727 |  |  |  |  | $cond
1728 |  |  |  |  | );
1729 |  |  |  |  | }
1730 | 27 | 5µs |  |  | my $warn= $DEBUG_HANDLER >= 2 ? _join_n( qq#warn qq%fail at cond '$cond'%;#) : '';
1731 | 27 | 22µs | 27 | 13µs | $perlfunc .= sprintf( _join_n( q#unless( @new_current_elts) { %s return 0; } #, # spent 13µs making 27 calls to XML::Twig::_join_n, avg 474ns/call
1732 |  |  |  |  | q#@current_elts= @new_current_elts; #,
1733 |  |  |  |  | q#@new_current_elts=(); #,
1734 |  |  |  |  | ),
1735 |  |  |  |  | $warn
1736 |  |  |  |  | );
1737 |  |  |  |  |
1738 | 27 | 18µs |  |  | $sep= pop @xpath_steps;
1739 |  |  |  |  | }
1740 |  |  |  |  |
1741 | 21 | 2µs |  |  | if( $anchored) # there should be a better way, but this works
1742 |  |  |  |  | {
1743 |  |  |  |  | my $warn= $DEBUG_HANDLER >= 2 ? _join_n( qq#warn qq{fail, stack not empty};#) : '';
1744 |  |  |  |  | $perlfunc .= sprintf( _join_n( q#if( ! grep { $_ == 0 } @current_elts) { %s return 0;}#), $warn);
1745 |  |  |  |  | }
1746 |  |  |  |  |
1747 | 21 | 3µs |  |  | $perlfunc.= qq{warn "handler for '$xpath_to_display' triggered\\n";\n} if( $DEBUG_HANDLER >=2);
1748 | 21 | 5µs |  |  | $perlfunc.= qq{return q{$xpath_original};\n};
1749 | 21 | 2µs |  |  | _warn_debug_handler( "\nperlfunc:\n$perlfunc\n") if( $DEBUG_HANDLER>=1);
1750 | 21 | 654µs |  |  | my $s= eval "sub { $perlfunc }"; # spent 269ms executing statements in 2 string evals (merged) # includes 149ms spent executing 31218 calls to 3 subs defined therein. # spent 246ms executing statements in 2 string evals (merged) # includes 136ms spent executing 36362 calls to 3 subs defined therein. # spent 374µs executing statements in 4 string evals (merged) # includes 46µs spent executing 8 calls to 5 subs defined therein. # spent 221µs executing statements in 2 string evals (merged) # includes 11µs spent executing 2 calls to 3 subs defined therein. # spent 189µs executing statements in 2 string evals (merged) # includes 24µs spent executing 4 calls to 3 subs defined therein. # spent 186µs executing statements in 2 string evals (merged) # includes 24µs spent executing 4 calls to 3 subs defined therein. # spent 169µs executing statements in 2 string evals (merged) # includes 12µs spent executing 2 calls to 3 subs defined therein. # spent 169µs executing statements in 2 string evals (merged) # includes 13µs spent executing 2 calls to 3 subs defined therein. # spent 166µs executing statements in 2 string evals (merged) # includes 12µs spent executing 2 calls to 3 subs defined therein. # spent 146µs executing statements in string eval # includes 47µs spent executing 16 calls to 2 subs defined therein.
1751 | 21 | 3µs |  |  | if( $@)
1752 |  |  |  |  | { croak "wrong handler condition '$xpath' ($@);" }
1753 |  |  |  |  |
1754 | 21 | 4µs |  |  | _warn_debug_handler( "last tag: '$last_tag', test_on_text: '$flag->{test_on_text}'\n") if( $DEBUG_HANDLER >=1);
1755 | 21 | 2µs |  |  | _warn_debug_handler( "score: ", join( ' ', map { "$_: $score->{$_}" } sort keys %$score), "\n") if( $DEBUG_HANDLER >=1);
1756 | 21 | 111µs |  |  | return { tag=> $last_tag, score => $score, trigger => $s, path => $xpath_original, handler => $handler, test_on_text => $flag->{test_on_text} };
1757 |  |  |  |  | }
1758 |  |  |  |  |
1759 | 75 | 86µs |  |  | # spent 60µs within XML::Twig::_join_n which was called 75 times, avg 796ns/call: # 27 times (18µs+0s) by XML::Twig::_parse_xpath_handler at line 1702, avg 667ns/call # 27 times (13µs+0s) by XML::Twig::_parse_xpath_handler at line 1731, avg 474ns/call # 21 times (29µs+0s) by XML::Twig::_parse_xpath_handler at line 1665, avg 1µs/call sub _join_n { return join( "\n", @_, ''); }
1760 |  |  |  |  |
1761 |  |  |  |  | # the "tag" part can be <tag>, <tag>.<class> or <tag>#<id> (where tag can be *, or start with # for hidden tags)
1762 |  |  |  |  | sub _tag_cond
1763 | 27 | 5µs |  |  | # spent 120µs (117+3) within XML::Twig::_tag_cond which was called 27 times, avg 4µs/call: # 27 times (117µs+3µs) by XML::Twig::_parse_xpath_handler at line 1694, avg 4µs/call { my( $full_tag)= @_;
1764 |  |  |  |  |
1765 | 27 | 3µs |  |  | my( $tag, $class, $id);
1766 | 27 | 27µs | 27 | 3µs | if( $full_tag=~ m{^(.+)#(.+)$}) # spent 3µs making 27 calls to CORE::match, avg 115ns/call
1767 |  |  |  |  | { ($tag, $id)= ($1, $2); } # <tag>#<id>
1768 |  |  |  |  | else
1769 | 27 | 8µs |  |  | { ( $tag, $class)= $css_sel ? $full_tag=~ m{^(.*?)(?:\.([^.]*))?$} : ($full_tag, undef); }
1770 |  |  |  |  |
1771 | 27 | 15µs |  |  | my $tag_cond = $tag && $tag ne '*' ? qq#(\$elt->{'$ST_TAG'} eq "$tag")# : '';
1772 | 27 | 5µs |  |  | my $id_cond = defined $id ? qq#(\$elt->{id} eq "$id")# : '';
1773 | 27 | 4µs |  |  | my $class_cond = defined $class ? qq#(\$elt->{class}=~ m{(^| )$class( |\$)})# : '';
1774 |  |  |  |  |
1775 | 27 | 34µs |  |  | my $full_cond= join( ' && ', grep { $_ } ( $tag_cond, $class_cond, $id_cond));
1776 |  |  |  |  |
1777 | 27 | 29µs |  |  | return $full_cond;
1778 |  |  |  |  | }
1779 |  |  |  |  |
1780 |  |  |  |  | # input: the predicate ($_[0]) which will be changed in place
1781 |  |  |  |  | # flags, a hashref with various flags (like test_on_text)
1782 |  |  |  |  | # the score
1783 |  |  |  |  | sub _parse_predicate_in_handler
1784 |  |  |  |  | { my( $flag, $score)= @_[1..2];
1785 |  |  |  |  | $_[0]=~ s{( ($REG_STRING) # strings
1786 |  |  |  |  | { my( $token, $str, $att_re_name, $att_re_regexp, $att, $bare_att, $num_test, $alpha_test, $func, $str_regexp, $str_test_alpha, $str_test_num, $and_or, $tag)
1787 |  |  |  |  | = ( $1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13, $14);
1788 |  |  |  |  |
1789 |  |  |  |  | $score->{predicates}++;
1790 |  |  |  |  |
1791 |  |  |  |  | # store tests on text (they are not always allowed)
1792 |  |  |  |  | if( $func || $str_regexp || $str_test_num || $str_test_alpha ) { $flag->{test_on_text}= 1; }
1793 |  |  |  |  |
1794 |  |  |  |  | if( defined $str) { $token }
1795 |  |  |  |  | elsif( $tag) { qq{(\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->has_child( '$tag'))} }
1796 |  |  |  |  | elsif( $att) { $att=~ m{^#} ? qq{ (\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->{att}->{'$att'})}
1797 |  |  |  |  | : qq{\$elt->{'$att'}}
1798 |  |  |  |  | }
1799 |  |  |  |  | elsif( $att_re_name) { $att_re_name=~ m{^#} ? qq{ (\$elt->{'$ST_ELT'} && \$elt->{'$ST_ELT'}->{att}->{'$att_re_name'}$att_re_regexp)}
1800 |  |  |  |  | : qq{\$elt->{'$att_re_name'}$att_re_regexp}
1801 |  |  |  |  | }
1802 |  |  |  |  | # for some reason Devel::Cover flags the following lines as not tested. They are though.
1803 |  |  |  |  | elsif( $bare_att) { $bare_att=~ m{^#} ? qq{(\$elt->{'$ST_ELT'} && defined(\$elt->{'$ST_ELT'}->{att}->{'$bare_att'}))}
1804 |  |  |  |  | : qq{defined( \$elt->{'$bare_att'})}
1805 |  |  |  |  | }
1806 |  |  |  |  | elsif( $num_test && ($num_test eq '=') ) { "==" } # others tests are unchanged
1807 |  |  |  |  | elsif( $alpha_test) { $PERL_ALPHA_TEST{$alpha_test} }
1808 |  |  |  |  | elsif( $func && $func=~ m{^string})
1809 |  |  |  |  | { "\$elt->{'$ST_ELT'}->text"; }
1810 |  |  |  |  | elsif( $str_regexp && $str_regexp =~ m{string\(\s*($REG_TAG_NAME)\s*\)\s*($REG_MATCH)\s*($REG_REGEXP)})
1811 |  |  |  |  | { "defined( _first_n { \$_->text $2 $3 } 1, \$elt->{'$ST_ELT'}->_children( '$1'))"; }
1812 |  |  |  |  | elsif( $str_test_alpha && $str_test_alpha =~ m{string\(\s*($REG_TAG_NAME)\s*\)\s*($REG_COMP)\s*($REG_STRING)})
1813 |  |  |  |  | { my( $tag, $op, $str)= ($1, $2, $3);
1814 |  |  |  |  | $str=~ s{(?<=.)'(?=.)}{\\'}g; # escape a quote within the string
1815 |  |  |  |  | $str=~ s{^"}{'};
1816 |  |  |  |  | $str=~ s{"$}{'};
1817 |  |  |  |  | "defined( _first_n { \$_->text $PERL_ALPHA_TEST{$op} $str } 1, \$elt->{'$ST_ELT'}->children( '$tag'))"; }
1818 |  |  |  |  | elsif( $str_test_num && $str_test_num =~ m{string\(\s*($REG_TAG_NAME)\s*\)\s*($REG_COMP)\s*($REG_NUMBER)})
1819 |  |  |  |  | { my $test= ($2 eq '=') ? '==' : $2;
1820 |  |  |  |  | "defined( _first_n { \$_->text $test $3 } 1, \$elt->{'$ST_ELT'}->children( '$1'))";
1821 |  |  |  |  | }
1822 |  |  |  |  | elsif( $and_or) { $score->{tests}++; $and_or eq 'and' ? '&&' : '||' ; }
1823 |  |  |  |  | else { $token; }
1824 |  |  |  |  | }gexs;
1825 |  |  |  |  |
- - |  |  |  |  |
1841 |  |  |  |  | }
1842 |  |  |  |  |
1843 |  |  |  |  |
1844 |  |  |  |  | sub setCharHandler
1845 |  |  |  |  | { my( $t, $handler)= @_;
1846 |  |  |  |  | $t->{twig_char_handler}= $handler;
1847 |  |  |  |  | }
1848 |  |  |  |  |
1849 |  |  |  |  |
1850 |  |  |  |  | sub _reset_handlers
1851 | 2 | 2µs |  |  | # spent 6µs within XML::Twig::_reset_handlers which was called 2 times, avg 3µs/call: # once (4µs+0s) by XML::Twig::setTwigHandlers at line 1878 # once (2µs+0s) by XML::Twig::setTwigRoots at line 1929 { my $handlers= shift;
1852 | 2 | 700ns |  |  | delete $handlers->{handlers};
1853 | 2 | 300ns |  |  | delete $handlers->{path_handlers};
1854 | 2 | 500ns |  |  | delete $handlers->{subpath_handlers};
1855 | 2 | 500ns |  |  | $handlers->{attcond_handlers_exp}=[] if( $handlers->{attcond_handlers});
1856 | 2 | 4µs |  |  | delete $handlers->{attcond_handlers};
1857 |  |  |  |  | }
1858 |  |  |  |  |
1859 |  |  |  |  | sub _set_handlers
1860 | 2 | 600ns |  |  | # spent 6.11ms (22µs+6.09) within XML::Twig::_set_handlers which was called 2 times, avg 3.05ms/call: # once (6µs+3.79ms) by XML::Twig::setTwigHandlers at line 1879 # once (16µs+2.29ms) by XML::Twig::setTwigRoots at line 1930 { my $handlers= shift || return;
1861 | 2 | 300ns |  |  | my $set_handlers= {};
1862 | 2 | 2µs |  |  | foreach my $path (keys %{$handlers})
1863 | 11 | 11µs | 11 | 6.09ms | { _set_handler( $set_handlers, $path, $handlers->{$path}); } # spent 6.09ms making 11 calls to XML::Twig::_set_handler, avg 553µs/call
1864 |  |  |  |  |
1865 | 2 | 3µs |  |  | return $set_handlers;
1866 |  |  |  |  | }
1867 |  |  |  |  |
1868 |  |  |  |  |
1869 |  |  |  |  | sub setTwigHandler
1870 |  |  |  |  | { my( $t, $path, $handler)= @_;
1871 |  |  |  |  | $t->{twig_handlers} ||={};
1872 |  |  |  |  | return _set_handler( $t->{twig_handlers}, $path, $handler);
1873 |  |  |  |  | }
1874 |  |  |  |  |
1875 |  |  |  |  | sub setTwigHandlers
1876 | 1 | 300ns |  |  | # spent 3.81ms (8µs+3.80) within XML::Twig::setTwigHandlers which was called: # once (8µs+3.80ms) by XML::Twig::new at line 477 { my( $t, $handlers)= @_;
1877 | 1 | 600ns |  |  | my $previous_handlers= $t->{twig_handlers} || undef;
1878 | 1 | 2µs | 1 | 4µs | _reset_handlers( $t->{twig_handlers}); # spent 4µs making 1 call to XML::Twig::_reset_handlers
1879 | 1 | 4µs | 1 | 3.80ms | $t->{twig_handlers}= _set_handlers( $handlers); # spent 3.80ms making 1 call to XML::Twig::_set_handlers
1880 | 1 | 2µs |  |  | return $previous_handlers;
1881 |  |  |  |  | }
1882 |  |  |  |  |
1883 |  |  |  |  | sub setStartTagHandler
1884 |  |  |  |  | { my( $t, $path, $handler)= @_;
1885 |  |  |  |  | $t->{twig_starttag_handlers}||={};
1886 |  |  |  |  | return _set_handler( $t->{twig_starttag_handlers}, $path, $handler);
1887 |  |  |  |  | }
1888 |  |  |  |  |
1889 |  |  |  |  | sub setStartTagHandlers
1890 |  |  |  |  | { my( $t, $handlers)= @_;
1891 |  |  |  |  | my $previous_handlers= $t->{twig_starttag_handlers} || undef;
1892 |  |  |  |  | _reset_handlers( $t->{twig_starttag_handlers});
1893 |  |  |  |  | $t->{twig_starttag_handlers}= _set_handlers( $handlers);
1894 |  |  |  |  | return $previous_handlers;
1895 |  |  |  |  | }
1896 |  |  |  |  |
1897 |  |  |  |  | sub setIgnoreEltsHandler
1898 |  |  |  |  | { my( $t, $path, $action)= @_;
1899 |  |  |  |  | $t->{twig_ignore_elts_handlers}||={};
1900 |  |  |  |  | return _set_handler( $t->{twig_ignore_elts_handlers}, $path, $action );
1901 |  |  |  |  | }
1902 |  |  |  |  |
1903 |  |  |  |  | sub setIgnoreEltsHandlers
1904 |  |  |  |  | { my( $t, $handlers)= @_;
1905 |  |  |  |  | my $previous_handlers= $t->{twig_ignore_elts_handlers};
1906 |  |  |  |  | _reset_handlers( $t->{twig_ignore_elts_handlers});
1907 |  |  |  |  | $t->{twig_ignore_elts_handlers}= _set_handlers( $handlers);
1908 |  |  |  |  | return $previous_handlers;
1909 |  |  |  |  | }
1910 |  |  |  |  |
1911 |  |  |  |  | sub setEndTagHandler
1912 |  |  |  |  | { my( $t, $path, $handler)= @_;
1913 |  |  |  |  | $t->{twig_endtag_handlers}||={};
1914 |  |  |  |  | return _set_handler( $t->{twig_endtag_handlers}, $path,$handler);
1915 |  |  |  |  | }
1916 |  |  |  |  |
1917 |  |  |  |  | sub setEndTagHandlers
1918 |  |  |  |  | { my( $t, $handlers)= @_;
1919 |  |  |  |  | my $previous_handlers= $t->{twig_endtag_handlers};
1920 |  |  |  |  | _reset_handlers( $t->{twig_endtag_handlers});
1921 |  |  |  |  | $t->{twig_endtag_handlers}= _set_handlers( $handlers);
1922 |  |  |  |  | return $previous_handlers;
1923 |  |  |  |  | }
1924 |  |  |  |  |
1925 |  |  |  |  | # a little more complex: set the twig_handlers only if a code ref is given
1926 |  |  |  |  | sub setTwigRoots
1927 | 1 | 300ns |  |  | # spent 4.78ms (61µs+4.72) within XML::Twig::setTwigRoots which was called: # once (61µs+4.72ms) by XML::Twig::new at line 562 { my( $t, $handlers)= @_;
1928 | 1 | 400ns |  |  | my $previous_roots= $t->{twig_roots};
1929 | 1 | 2µs | 1 | 2µs | _reset_handlers($t->{twig_roots}); # spent 2µs making 1 call to XML::Twig::_reset_handlers
1930 | 1 | 4µs | 1 | 2.31ms | $t->{twig_roots}= _set_handlers( $handlers); # spent 2.31ms making 1 call to XML::Twig::_set_handlers
1931 |  |  |  |  |
1932 | 1 | 2µs | 1 | 9µs | _check_illegal_twig_roots_handlers( $t->{twig_roots}); # spent 9µs making 1 call to XML::Twig::_check_illegal_twig_roots_handlers
1933 |  |  |  |  |
1934 | 1 | 1µs |  |  | foreach my $path (keys %{$handlers})
1935 | 10 | 18µs |  |  | { $t->{twig_handlers}||= {};
1936 |  |  |  |  | _set_handler( $t->{twig_handlers}, $path, $handlers->{$path})
1937 | 10 | 31µs | 20 | 2.40ms | if( ref($handlers->{$path}) && isa( $handlers->{$path}, 'CODE')); # spent 2.39ms making 10 calls to XML::Twig::_set_handler, avg 239µs/call # spent 6µs making 10 calls to UNIVERSAL::isa, avg 600ns/call
1938 |  |  |  |  | }
1939 | 1 | 2µs |  |  | return $previous_roots;
1940 |  |  |  |  | }
1941 |  |  |  |  |
1942 |  |  |  |  | sub _check_illegal_twig_roots_handlers
1943 | 1 | 300ns |  |  | # spent 9µs within XML::Twig::_check_illegal_twig_roots_handlers which was called: # once (9µs+0s) by XML::Twig::setTwigRoots at line 1932 { my( $handlers)= @_;
1944 | 1 | 2µs |  |  | foreach my $tag_handlers (values %{$handlers->{xpath_handler}})
1945 | 10 | 2µs |  |  | { foreach my $handler_data (@$tag_handlers)
1946 | 10 | 3µs |  |  | { if( my $type= $handler_data->{test_on_text})
1947 |  |  |  |  | { croak "string() condition not supported on twig_roots option"; }
1948 |  |  |  |  | }
1949 |  |  |  |  | }
1950 | 1 | 2µs |  |  | return;
1951 |  |  |  |  | }
1952 |  |  |  |  |
1953 |  |  |  |  |
1954 |  |  |  |  | # just store the reference to the expat object in the twig
1955 |  |  |  |  | sub _twig_init
1956 |  |  |  |  | # spent 44µs (33+10) within XML::Twig::_twig_init which was called 7 times, avg 6µs/call: # 7 times (33µs+10µs) by XML::Parser::parse at line 182 of XML/Parser.pm, avg 6µs/call { # warn " in _twig_init...\n"; # DEBUG handler
1957 |  |  |  |  |
1958 | 7 | 1µs |  |  | my $p= shift;
1959 | 7 | 2µs |  |  | my $t=$p->{twig};
1960 |  |  |  |  |
1961 | 7 | 2µs |  |  | if( $t->{twig_parsing} ) { croak "cannot reuse a twig that is already parsing"; }
1962 | 7 | 2µs |  |  | $t->{twig_parsing}=1;
1963 |  |  |  |  |
1964 | 7 | 2µs |  |  | $t->{twig_parser}= $p;
1965 | 7 | 12µs | 7 | 4µs | if( $weakrefs) { weaken( $t->{twig_parser}); } # spent 4µs making 7 calls to Scalar::Util::weaken, avg 557ns/call
1966 |  |  |  |  |
1967 |  |  |  |  | # in case they had been created by a previous parse
1968 | 7 | 1µs |  |  | delete $t->{twig_dtd};
1969 | 7 | 1µs |  |  | delete $t->{twig_doctype};
1970 | 7 | 900ns |  |  | delete $t->{twig_xmldecl};
1971 | 7 | 600ns |  |  | delete $t->{twig_root};
1972 |  |  |  |  |
1973 |  |  |  |  | # if needed set the output filehandle
1974 | 7 | 6µs | 7 | 6µs | $t->_set_fh_to_twig_output_fh(); # spent 6µs making 7 calls to XML::Twig::_set_fh_to_twig_output_fh, avg 929ns/call
1975 | 7 | 9µs |  |  | return;
1976 |  |  |  |  | }
1977 |  |  |  |  |
1978 |  |  |  |  | # uses eval to catch the parser's death
1979 |  |  |  |  | sub safe_parse
1980 |  |  |  |  | { my $t= shift;
1981 |  |  |  |  | eval { $t->parse( @_); } ;
1982 |  |  |  |  | return $@ ? $t->_reset_twig_after_error : $t;
1983 |  |  |  |  | }
1984 |  |  |  |  |
1985 |  |  |  |  | sub safe_parsefile
1986 |  |  |  |  | { my $t= shift;
1987 |  |  |  |  | eval { $t->parsefile( @_); } ;
1988 |  |  |  |  | return $@ ? $t->_reset_twig_after_error : $t;
1989 |  |  |  |  | }
1990 |  |  |  |  |
1991 |  |  |  |  | # restore a twig in a proper state so it can be reused for a new parse
1992 |  |  |  |  | sub _reset_twig
1993 |  |  |  |  | { my $t= shift;
1994 |  |  |  |  | $t->{twig_parsing}= 0;
1995 |  |  |  |  | delete $t->{twig_current};
1996 |  |  |  |  | delete $t->{extra_data};
1997 |  |  |  |  | delete $t->{twig_dtd};
1998 |  |  |  |  | delete $t->{twig_in_pcdata};
1999 |  |  |  |  | delete $t->{twig_in_cdata};
2000 |  |  |  |  | delete $t->{twig_stored_space};
2001 |  |  |  |  | delete $t->{twig_entity_list};
2002 |  |  |  |  | $t->root->delete if( $t->root);
2003 |  |  |  |  | delete $t->{twig_root};
2004 |  |  |  |  | return $t;
2005 |  |  |  |  | }
2006 |  |  |  |  |
2007 |  |  |  |  | sub _reset_twig_after_error
2008 |  |  |  |  | { my $t= shift;
2009 |  |  |  |  | $t->_reset_twig;
2010 |  |  |  |  | return undef;
2011 |  |  |  |  | }
2012 |  |  |  |  |
2013 |  |  |  |  |
2014 |  |  |  |  | sub _add_or_discard_stored_spaces
2015 | 728738 | 86.7ms |  |  | # spent 599ms within XML::Twig::_add_or_discard_stored_spaces which was called 728738 times, avg 822ns/call: # 364369 times (309ms+0s) by XML::Twig::_twig_end at line 2307, avg 849ns/call # 364369 times (290ms+0s) by XML::Twig::_twig_start at line 2047, avg 795ns/call { my $t= shift;
2016 |  |  |  |  |
2017 | 728738 | 119ms |  |  | $t->{twig_right_after_root}=0; #XX
2018 |  |  |  |  |
2019 | 728738 | 118ms |  |  | my $current= $t->{twig_current} or return; # ugly hack, with ignore on, twig_current can disappear
2020 | 728731 | 1.71s |  |  | return unless length $t->{twig_stored_spaces};
2021 |  |  |  |  | my $current_gi= $XML::Twig::index2gi[$current->{'gi'}];
2022 |  |  |  |  |
2023 |  |  |  |  | if( ! $t->{twig_discard_all_spaces})
2024 |  |  |  |  | { if( ! defined( $t->{twig_space_policy}->{$current_gi}))
2025 |  |  |  |  | { $t->{twig_space_policy}->{$current_gi}= _space_policy( $t, $current_gi); }
2026 |  |  |  |  | if( $t->{twig_space_policy}->{$current_gi} || ($t->{twig_stored_spaces}!~ m{\n}) || $t->{twig_preserve_space})
2027 |  |  |  |  | { _insert_pcdata( $t, $t->{twig_stored_spaces} ); }
2028 |  |  |  |  | }
2029 |  |  |  |  |
2030 |  |  |  |  | $t->{twig_stored_spaces}='';
2031 |  |  |  |  |
2032 |  |  |  |  | return;
2033 |  |  |  |  | }
2034 |  |  |  |  |
2035 |  |  |  |  | # the default twig handlers, which build the tree
2036 |  |  |  |  | sub _twig_start
2037 |  |  |  |  | # spent 35.2s (9.97+25.2) within XML::Twig::_twig_start which was called 364369 times, avg 97µs/call: # 330576 times (9.05s+23.3s) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 98µs/call # 33792 times (916ms+1.90s) by XML::Twig::_twig_start_check_roots at line 4147, avg 83µs/call # once (33µs+203µs) by XML::Twig::_twig_start_check_roots at line 4162 { # warn " in _twig_start...\n"; # DEBUG handler
2038 |  |  |  |  |
2039 |  |  |  |  | #foreach my $s (@_) { next if ref $s; warn "$s: ", is_utf8( $s) ? "has flag" : "FLAG NOT SET"; } # YYY
2040 |  |  |  |  |
2041 | 364369 | 193ms |  |  | my ($p, $gi, @att)= @_;
2042 | 364369 | 63.7ms |  |  | my $t=$p->{twig};
2043 |  |  |  |  |
2044 |  |  |  |  | # empty the stored pcdata (space stored in case they are really part of
2045 |  |  |  |  | # a pcdata element) or stored it if the space policy dictates so
2046 |  |  |  |  | # create a pcdata element with the spaces if need be
2047 | 364369 | 159ms | 364369 | 290ms | _add_or_discard_stored_spaces( $t); # spent 290ms making 364369 calls to XML::Twig::_add_or_discard_stored_spaces, avg 795ns/call
2048 | 364369 | 40.8ms |  |  | my $parent= $t->{twig_current};
2049 |  |  |  |  |
2050 |  |  |  |  | # if we were parsing PCDATA then we exit the pcdata
2051 | 364369 | 54.3ms |  |  | if( $t->{twig_in_pcdata})
2052 |  |  |  |  | { $t->{twig_in_pcdata}= 0;
2053 |  |  |  |  | delete $parent->{'twig_current'};
2054 |  |  |  |  | $parent= $parent->{parent};
2055 |  |  |  |  | }
2056 |  |  |  |  |
2057 |  |  |  |  | # if we choose to keep the encoding then we need to parse the tag
2058 | 364369 | 97.0ms |  |  | if( my $func = $t->{parse_start_tag})
2059 |  |  |  |  | { ($gi, @att)= &$func($p->original_string); }
2060 |  |  |  |  | elsif( $t->{twig_entities_in_attribute})
2061 |  |  |  |  | {
2062 |  |  |  |  | ($gi,@att)= _parse_start_tag( $p->recognized_string);
2063 |  |  |  |  | $t->{twig_entities_in_attribute}=0;
2064 |  |  |  |  | }
2065 |  |  |  |  |
2066 |  |  |  |  | # if we are using an external DTD, we need to fill the default attributes
2067 | 364369 | 48.0ms |  |  | if( $t->{twig_read_external_dtd}) { _fill_default_atts( $t, $gi, \@att); }
2068 |  |  |  |  |
2069 |  |  |  |  | # filter the input data if need be
2070 | 364369 | 72.0ms |  |  | if( my $filter= $t->{twig_input_filter})
2071 |  |  |  |  | { $gi= $filter->( $gi);
2072 |  |  |  |  | foreach my $att (@att) { $att= $filter->($att); }
2073 |  |  |  |  | }
2074 |  |  |  |  |
2075 | 364369 | 28.0ms |  |  | my $ns_decl;
2076 | 364369 | 272ms | 364369 | 19.6s | if( $t->{twig_map_xmlns}) # spent 19.6s making 364369 calls to XML::Twig::_replace_ns, avg 54µs/call
2077 |  |  |  |  | { $ns_decl= _replace_ns( $t, \$gi, \@att); }
2078 |  |  |  |  |
2079 | 364369 | 340ms | 364369 | 1.82s | my $elt= $t->{twig_elt_class}->new( $gi); # spent 1.82s making 364369 calls to XML::Twig::Elt::new, avg 5µs/call
2080 | 364369 | 229ms | 364369 | 1.69s | $elt->set_atts( @att); # spent 1.69s making 364369 calls to XML::Twig::Elt::set_atts, avg 5µs/call
2081 |  |  |  |  |
2082 |  |  |  |  | # now we can store the tag and atts
2083 | 364369 | 360ms |  |  | my $context= { $ST_TAG => $gi, $ST_ELT => $elt, @att};
2084 | 364369 | 35.4ms |  |  | $context->{$ST_NS}= $ns_decl if $ns_decl;
2085 | 364369 | 813ms | 364369 | 122ms | if( $weakrefs) { weaken( $context->{$ST_ELT}); } # spent 122ms making 364369 calls to Scalar::Util::weaken, avg 334ns/call
2086 | 364369 | 108ms |  |  | push @{$t->{_twig_context_stack}}, $context;
2087 |  |  |  |  |
2088 | 364369 | 92.5ms |  |  | delete $parent->{'twig_current'} if( $parent);
2089 | 364369 | 65.4ms |  |  | $t->{twig_current}= $elt;
2090 | 364369 | 78.5ms |  |  | $elt->{'twig_current'}=1;
2091 |  |  |  |  |
2092 | 364369 | 71.1ms |  |  | if( $parent)
2093 | 364362 | 61.4ms |  |  | { my $prev_sibling= $parent->{last_child};
2094 | 364362 | 45.9ms |  |  | if( $prev_sibling)
2095 | 187529 | 40.1ms |  |  | { $prev_sibling->{next_sibling}= $elt;
2096 | 375058 | 355ms | 187529 | 23.1ms | $elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ; # spent 23.1ms making 187529 calls to Scalar::Util::weaken, avg 123ns/call
2097 |  |  |  |  | }
2098 |  |  |  |  |
2099 | 728724 | 868ms | 364362 | 63.4ms | $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ; # spent 63.4ms making 364362 calls to Scalar::Util::weaken, avg 174ns/call
2100 | 364362 | 89.6ms |  |  | unless( $parent->{first_child}) { $parent->{first_child}= $elt; }
2101 | 1093086 | 820ms | 364362 | 76.1ms | delete $parent->{empty}; $parent->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; # spent 76.1ms making 364362 calls to Scalar::Util::weaken, avg 209ns/call
2102 |  |  |  |  | }
2103 |  |  |  |  | else
2104 |  |  |  |  | { # processing root
2105 | 7 | 7µs | 7 | 24µs | $t->set_root( $elt); # spent 24µs making 7 calls to XML::Twig::set_root, avg 3µs/call
2106 |  |  |  |  | # call dtd handler if need be
2107 |  |  |  |  | $t->{twig_dtd_handler}->($t, $t->{twig_dtd})
2108 | 7 | 2µs |  |  | if( defined $t->{twig_dtd_handler});
2109 |  |  |  |  |
2110 |  |  |  |  | # set this so we can catch external entities
2111 |  |  |  |  | # (the handler was modified during DTD processing)
2112 | 7 | 6µs | 1 | 9µs | if( $t->{twig_default_print}) # spent 9µs making 1 call to XML::Parser::Expat::setHandlers
2113 |  |  |  |  | { $p->setHandlers( Default => \&_twig_print); }
2114 |  |  |  |  | elsif( $t->{twig_roots})
2115 |  |  |  |  | { $p->setHandlers( Default => sub { return }); }
2116 |  |  |  |  | else
2117 | 6 | 5µs | 6 | 30µs | { $p->setHandlers( Default => \&_twig_default); } # spent 30µs making 6 calls to XML::Parser::Expat::setHandlers, avg 5µs/call
2118 |  |  |  |  | }
2119 |  |  |  |  |
2120 | 364369 | 1.08s | 728738 | 1.53s | $elt->{empty}= $p->recognized_string=~ m{/\s*>$}s ? 1 : 0; # spent 1.31s making 364369 calls to XML::Parser::Expat::recognized_string, avg 4µs/call # spent 216ms making 364369 calls to CORE::match, avg 593ns/call
2121 |  |  |  |  |
2122 | 364369 | 59.7ms |  |  | $elt->{extra_data}= $t->{extra_data} if( $t->{extra_data});
2123 | 364369 | 77.8ms |  |  | $t->{extra_data}='';
2124 |  |  |  |  |
2125 |  |  |  |  | # if the element is ID-ed then store that info
2126 | 364369 | 66.5ms |  |  | my $id= $elt->{'att'}->{$ID};
2127 | 364369 | 50.2ms |  |  | if( defined $id)
2128 |  |  |  |  | { $t->{twig_id_list}->{$id}= $elt;
2129 |  |  |  |  | if( $weakrefs) { weaken( $t->{twig_id_list}->{$id}); }
2130 |  |  |  |  | }
2131 |  |  |  |  |
2132 |  |  |  |  | # call user handler if need be
2133 | 364369 | 54.6ms |  |  | if( $t->{twig_starttag_handlers})
2134 |  |  |  |  | { # call all appropriate handlers
2135 |  |  |  |  | my @handlers= _handler( $t, $t->{twig_starttag_handlers}, $gi);
2136 |  |  |  |  |
2137 |  |  |  |  | local $_= $elt;
2138 |  |  |  |  |
2139 |  |  |  |  | foreach my $handler ( @handlers)
2140 |  |  |  |  | { $handler->($t, $elt) || last; }
2141 |  |  |  |  | # call _all_ handler if needed
2142 |  |  |  |  | if( my $all= $t->{twig_starttag_handlers}->{handlers}->{$ALL})
2143 |  |  |  |  | { $all->($t, $elt); }
2144 |  |  |  |  | }
2145 |  |  |  |  |
2146 |  |  |  |  | # check if the tag is in the list of tags to be ignored
2147 | 364369 | 51.6ms |  |  | if( $t->{twig_ignore_elts_handlers})
2148 |  |  |  |  | { my @handlers= _handler( $t, $t->{twig_ignore_elts_handlers}, $gi);
2149 |  |  |  |  | # only the first handler counts, it contains the action (discard/print/string)
2150 |  |  |  |  | if( @handlers) { my $action= shift @handlers; $t->ignore( $elt, $action); }
2151 |  |  |  |  | }
2152 |  |  |  |  |
2153 | 364369 | 52.7ms |  |  | if( $elt->{'att'}->{'xml:space'} && ( $elt->{'att'}->{'xml:space'} eq 'preserve')) { $t->{twig_preserve_space}++; }
2154 |  |  |  |  |
2155 |  |  |  |  |
2156 | 364369 | 847ms |  |  | return;
2157 |  |  |  |  | }
2158 |  |  |  |  |
2159 |  |  |  |  | sub _replace_ns
2160 | 398167 | 71.4ms |  |  | # spent 22.1s (5.90+16.2) within XML::Twig::_replace_ns which was called 398167 times, avg 55µs/call: # 364369 times (5.31s+14.3s) by XML::Twig::_twig_start at line 2076, avg 54µs/call # 33798 times (587ms+1.91s) by XML::Twig::_twig_start_check_roots at line 4134, avg 74µs/call { my( $t, $gi, $atts)= @_;
2161 | 398167 | 28.6ms |  |  | my $decls;
2162 | 398167 | 474ms | 796334 | 396ms | foreach my $new_prefix ( $t->parser->new_ns_prefixes) # spent 243ms making 398167 calls to XML::Parser::Expat::new_ns_prefixes, avg 611ns/call # spent 153ms making 398167 calls to XML::Twig::parser, avg 383ns/call
2163 | 28 | 24µs | 56 | 40µs | { my $uri= $t->parser->expand_ns_prefix( $new_prefix); # spent 33µs making 28 calls to XML::Parser::Expat::expand_ns_prefix, avg 1µs/call # spent 7µs making 28 calls to XML::Twig::parser, avg 243ns/call
2164 |  |  |  |  | # replace the prefix if it is mapped
2165 | 28 | 11µs |  |  | $decls->{$new_prefix}= $uri;
2166 | 28 | 5µs |  |  | if( !$t->{twig_keep_original_prefix} && (my $mapped_prefix= $t->{twig_map_xmlns}->{$uri}))
2167 |  |  |  |  | { $new_prefix= $mapped_prefix; }
2168 |  |  |  |  | # now put the namespace declaration back in the element
2169 | 28 | 16µs |  |  | if( $new_prefix eq '#default')
2170 |  |  |  |  | { push @$atts, "xmlns" => $uri; }
2171 |  |  |  |  | else
2172 | 22 | 11µs |  |  | { push @$atts, "xmlns:$new_prefix" => $uri; }
2173 |  |  |  |  | }
2174 |  |  |  |  |
2175 | 398167 | 92.8ms |  |  | if( $t->{twig_keep_original_prefix})
2176 |  |  |  |  | { # things become more complex: we need to find the original prefix
2177 |  |  |  |  | # and store both prefixes
2178 | 398167 | 251ms | 398167 | 11.3s | my $ns_info= $t->_ns_info( $$gi); # spent 11.3s making 398167 calls to XML::Twig::_ns_info, avg 28µs/call
2179 | 398167 | 28.1ms |  |  | my $map_att;
2180 | 398167 | 104ms |  |  | if( $ns_info->{mapped_prefix})
2181 | 364375 | 151ms |  |  | { $$gi= "$ns_info->{mapped_prefix}:$$gi";
2182 | 364375 | 170ms |  |  | $map_att->{$ns_info->{mapped_prefix}}= $ns_info->{prefix};
2183 |  |  |  |  | }
2184 | 398167 | 46.5ms |  |  | my $att_name=1;
2185 | 398167 | 148ms |  |  | foreach( @$atts)
2186 | 1395024 | 399ms |  |  | { if( $att_name)
2187 |  |  |  |  | {
2188 | 697512 | 272ms | 697512 | 4.50s | my $ns_info= $t->_ns_info( $_); # spent 4.50s making 697512 calls to XML::Twig::_ns_info, avg 6µs/call
2189 | 697512 | 76.6ms |  |  | if( $ns_info->{mapped_prefix})
2190 | 15620 | 8.03ms |  |  | { $_= "$ns_info->{mapped_prefix}:$_";
2191 | 15620 | 9.58ms |  |  | $map_att->{$ns_info->{mapped_prefix}}= $ns_info->{prefix};
2192 |  |  |  |  | }
2193 | 697512 | 168ms |  |  | $att_name=0;
2194 |  |  |  |  | }
2195 |  |  |  |  | else
2196 | 697512 | 50.5ms |  |  | { $att_name=1; }
2197 |  |  |  |  | }
2198 | 398167 | 227ms |  |  | push @$atts, '#original_gi', $map_att if( $map_att);
2199 |  |  |  |  | }
2200 |  |  |  |  | else
2201 |  |  |  |  | { $$gi= $t->_replace_prefix( $$gi);
2202 |  |  |  |  | my $att_name=1;
2203 |  |  |  |  | foreach( @$atts)
2204 |  |  |  |  | { if( $att_name) { $_= $t->_replace_prefix( $_); $att_name=0; }
2205 |  |  |  |  | else { $att_name=1; }
2206 |  |  |  |  | }
2207 |  |  |  |  | }
2208 | 398167 | 785ms |  |  | return $decls;
2209 |  |  |  |  | }
2210 |  |  |  |  |
2211 |  |  |  |  |
2212 |  |  |  |  | # extract prefix, local_name, uri, mapped_prefix from a name
2213 |  |  |  |  | # will only work if called from a start or end tag handler
2214 |  |  |  |  | sub _ns_info
2215 | 1095679 | 164ms |  |  | # spent 15.8s (6.34+9.44) within XML::Twig::_ns_info which was called 1095679 times, avg 14µs/call: # 697512 times (3.26s+1.24s) by XML::Twig::_replace_ns at line 2188, avg 6µs/call # 398167 times (3.09s+8.20s) by XML::Twig::_replace_ns at line 2178, avg 28µs/call { my( $t, $name)= @_;
2216 | 1095679 | 87.4ms |  |  | my $ns_info={};
2217 | 1095679 | 414ms | 1095679 | 254ms | my $p= $t->parser; # spent 254ms making 1095679 calls to XML::Twig::parser, avg 231ns/call
2218 | 1095679 | 631ms | 1095679 | 1.29s | $ns_info->{uri}= $p->namespace( $name); # spent 1.29s making 1095679 calls to XML::Parser::Expat::namespace, avg 1µs/call
2219 | 1095679 | 1.40s |  |  | return $ns_info unless( $ns_info->{uri});
2220 |  |  |  |  |
2221 | 379995 | 331ms | 379995 | 7.90s | $ns_info->{prefix}= _a_proper_ns_prefix( $p, $ns_info->{uri}); # spent 7.90s making 379995 calls to XML::Twig::_a_proper_ns_prefix, avg 21µs/call
2222 | 379995 | 234ms |  |  | $ns_info->{mapped_prefix}= $t->{twig_map_xmlns}->{$ns_info->{uri}} || $ns_info->{prefix};
2223 |  |  |  |  |
2224 | 379995 | 688ms |  |  | return $ns_info;
2225 |  |  |  |  | }
2226 |  |  |  |  |
2227 |  |  |  |  | sub _a_proper_ns_prefix
2228 | 380001 | 67.4ms |  |  | # spent 7.90s (5.08+2.82) within XML::Twig::_a_proper_ns_prefix which was called 380001 times, avg 21µs/call: # 379995 times (5.08s+2.82s) by XML::Twig::_ns_info at line 2221, avg 21µs/call # 6 times (37µs+48µs) by XML::Twig::_replace_prefix at line 2434, avg 14µs/call { my( $p, $uri)= @_;
2229 | 380001 | 226ms | 380001 | 1.51s | foreach my $prefix ($p->current_ns_prefixes) # spent 1.51s making 380001 calls to XML::Parser::Expat::current_ns_prefixes, avg 4µs/call
2230 | 1520661 | 1.66s | 1520661 | 1.31s | { if( $p->expand_ns_prefix( $prefix) eq $uri) # spent 1.31s making 1520661 calls to XML::Parser::Expat::expand_ns_prefix, avg 864ns/call
2231 |  |  |  |  | { return $prefix; }
2232 |  |  |  |  | }
2233 |  |  |  |  | return;
2234 |  |  |  |  | }
2235 |  |  |  |  |
2236 |  |  |  |  | # returns the uri bound to a prefix in the original document
2237 |  |  |  |  | # only works in a handler
2238 |  |  |  |  | # can be used to deal with xsi:type attributes
2239 |  |  |  |  | sub original_uri
2240 |  |  |  |  | { my( $t, $prefix)= @_;
2241 |  |  |  |  | my $ST_NS = '##ns' ;
2242 |  |  |  |  | foreach my $ns (map { $_->{$ST_NS} if $_->{$ST_NS} } reverse @{$t->{_twig_context_stack}})
2243 |  |  |  |  | { return $ns->{$prefix} || next; }
2244 |  |  |  |  | return;
2245 |  |  |  |  | }
2246 |  |  |  |  |
2247 |  |  |  |  |
2248 |  |  |  |  | sub _fill_default_atts
2249 |  |  |  |  | { my( $t, $gi, $atts)= @_;
2250 |  |  |  |  | my $dtd= $t->{twig_dtd};
2251 |  |  |  |  | my $attlist= $dtd->{att}->{$gi};
2252 |  |  |  |  | my %value= @$atts;
2253 |  |  |  |  | foreach my $att (keys %$attlist)
2254 |  |  |  |  | { if( !exists( $value{$att})
2255 |  |  |  |  | && exists( $attlist->{$att}->{default})
2256 |  |  |  |  | && ( $attlist->{$att}->{default} ne '#IMPLIED')
2257 |  |  |  |  | )
2258 |  |  |  |  | { # the quotes are included in the default, so we need to remove them
2259 |  |  |  |  | my $default_value= substr( $attlist->{$att}->{default}, 1, -1);
2260 |  |  |  |  | push @$atts, $att, $default_value;
2261 |  |  |  |  | }
2262 |  |  |  |  | }
2263 |  |  |  |  | return;
2264 |  |  |  |  | }
2265 |  |  |  |  |
2266 |  |  |  |  |
2267 |  |  |  |  | # the default function to parse a start tag (in keep_encoding mode)
2268 |  |  |  |  | # can be overridden with the parse_start_tag method
2269 |  |  |  |  | # only works for 1-byte character sets
2270 |  |  |  |  | sub _parse_start_tag
2271 |  |  |  |  | { my $string= shift;
2272 |  |  |  |  | my( $gi, @atts);
2273 |  |  |  |  |
2274 |  |  |  |  | # get the gi (between < and the first space, / or > character)
2275 |  |  |  |  | #if( $string=~ s{^<\s*([^\s>/]*)[\s>/]*}{}s)
2276 |  |  |  |  | if( $string=~ s{^<\s*($REG_TAG_NAME)\s*[\s>/]}{}s)
2277 |  |  |  |  | { $gi= $1; }
2278 |  |  |  |  | else
2279 |  |  |  |  | { croak "error parsing tag '$string'"; }
2280 |  |  |  |  | while( $string=~ s{^([^\s=]*)\s*=\s*(["'])(.*?)\2\s*}{}s)
2281 |  |  |  |  | { push @atts, $1, $3; }
2282 |  |  |  |  | return $gi, @atts;
2283 |  |  |  |  | }
2284 |  |  |  |  |
2285 |  |  |  |  | sub set_root
2286 | 7 | 2µs |  |  | # spent 24µs (22+2) within XML::Twig::set_root which was called 7 times, avg 3µs/call: # 7 times (22µs+2µs) by XML::Twig::_twig_start at line 2105, avg 3µs/call { my( $t, $elt)= @_;
2287 | 7 | 3µs |  |  | $t->{twig_root}= $elt;
2288 | 7 | 2µs |  |  | if( $elt)
2289 | 7 | 3µs |  |  | { $elt->{twig}= $t;
2290 | 7 | 11µs | 7 | 2µs | if( $weakrefs) { weaken( $elt->{twig}); } # spent 2µs making 7 calls to Scalar::Util::weaken, avg 329ns/call
2291 |  |  |  |  | }
2292 | 7 | 9µs |  |  | return $t;
2293 |  |  |  |  | }
2294 |  |  |  |  |
2295 |  |  |  |  | sub _twig_end
2296 |  |  |  |  | # spent 25.4s (5.66+19.7) within XML::Twig::_twig_end which was called 364369 times, avg 70µs/call: # 364368 times (5.66s+19.7s) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 70µs/call # once (11µs+10µs) by XML::Twig::_twig_end_check_roots at line 4216 { # warn " in _twig_end...\n"; # DEBUG handler
2297 | 364369 | 59.5ms |  |  | my ($p, $gi) = @_;
2298 |  |  |  |  |
2299 | 364369 | 62.8ms |  |  | my $t=$p->{twig};
2300 |  |  |  |  |
2301 | 364369 | 90.0ms |  |  | if( $t->{twig_in_pcdata} && (my $text_handler= $t->{TwigHandlers}->{$TEXT}) )
2302 |  |  |  |  | { local $_= $t->{twig_current}; $text_handler->( $t, $_) if $_;
2303 |  |  |  |  | }
2304 |  |  |  |  |
2305 | 364369 | 233ms | 364369 | 2.69s | if( $t->{twig_map_xmlns}) { $gi= $t->_replace_prefix( $gi); } # spent 2.69s making 364369 calls to XML::Twig::_replace_prefix, avg 7µs/call
2306 |  |  |  |  |
2307 | 364369 | 156ms | 364369 | 309ms | _add_or_discard_stored_spaces( $t); # spent 309ms making 364369 calls to XML::Twig::_add_or_discard_stored_spaces, avg 849ns/call
2308 |  |  |  |  |
2309 |  |  |  |  | # the new twig_current is the parent
2310 | 364369 | 45.4ms |  |  | my $elt= $t->{twig_current};
2311 | 364369 | 52.8ms |  |  | delete $elt->{'twig_current'};
2312 |  |  |  |  |
2313 |  |  |  |  | # if we were parsing PCDATA then we exit the pcdata too
2314 | 364369 | 71.4ms |  |  | if( $t->{twig_in_pcdata})
2315 |  |  |  |  | {
2316 | 127292 | 19.8ms |  |  | $t->{twig_in_pcdata}= 0;
2317 | 127292 | 31.3ms |  |  | $elt= $elt->{parent} if($elt->{parent});
2318 | 127292 | 18.4ms |  |  | delete $elt->{'twig_current'};
2319 |  |  |  |  | }
2320 |  |  |  |  |
2321 |  |  |  |  | # parent is the new current element
2322 | 364369 | 48.0ms |  |  | my $parent= $elt->{parent};
2323 | 364369 | 45.0ms |  |  | $t->{twig_current}= $parent;
2324 |  |  |  |  |
2325 | 364369 | 62.2ms |  |  | if( $parent)
2326 | 364362 | 72.2ms |  |  | { $parent->{'twig_current'}=1;
2327 |  |  |  |  | # twig_to_be_normalized
2328 | 364362 | 59.3ms |  |  | if( $parent->{twig_to_be_normalized}) { $parent->normalize; $parent->{twig_to_be_normalized}=0; }
2329 |  |  |  |  | }
2330 |  |  |  |  |
2331 | 364369 | 47.4ms |  |  | if( $t->{extra_data})
2332 |  |  |  |  | { $elt->_set_extra_data_before_end_tag( $t->{extra_data});
2333 |  |  |  |  | $t->{extra_data}='';
2334 |  |  |  |  | }
2335 |  |  |  |  |
2336 | 364369 | 82.5ms |  |  | if( $t->{twig_handlers})
2337 |  |  |  |  | { # look for handlers
2338 | 364007 | 205ms | 364007 | 1.05s | my @handlers= _handler( $t, $t->{twig_handlers}, $gi); # spent 1.05s making 364007 calls to XML::Twig::_handler, avg 3µs/call
2339 |  |  |  |  |
2340 | 364007 | 117ms |  |  | if( $t->{twig_tdh})
2341 |  |  |  |  | { if( @handlers) { push @{$t->{twig_handlers_to_trigger}}, [ $elt, \@handlers ]; }
2342 |  |  |  |  | if( my $all= $t->{twig_handlers}->{handlers}->{$ALL})
2343 |  |  |  |  | { push @{$t->{twig_handlers_to_trigger}}, [ $elt, [$all] ]; }
2344 |  |  |  |  | }
2345 |  |  |  |  | else
2346 |  |  |  |  | {
2347 | 364007 | 46.9ms |  |  | local $_= $elt; # so we can use $_ in the handlers
2348 |  |  |  |  |
2349 | 364007 | 94.6ms |  |  | foreach my $handler ( @handlers)
2350 | 33807 | 31.1ms | 33807 | 13.8s | { $handler->($t, $elt) || last; } # spent 12.9s making 15608 calls to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443], avg 825µs/call # spent 960ms making 18180 calls to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:302], avg 53µs/call # spent 715µs making 15 calls to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:655], avg 48µs/call # spent 72µs making 1 call to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:246] # spent 50µs making 1 call to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:268] # spent 49µs making 1 call to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:338] # spent 27µs making 1 call to Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:313]
2351 |  |  |  |  | # call _all_ handler if needed
2352 | 364007 | 88.1ms |  |  | my $all= $t->{twig_handlers}->{handlers}->{$ALL};
2353 | 364007 | 32.0ms |  |  | if( $all)
2354 |  |  |  |  | { $all->($t, $elt); }
2355 | 364007 | 75.5ms |  |  | if( @handlers || $all) { $t->{twig_right_after_root}=0; }
2356 |  |  |  |  | }
2357 |  |  |  |  | }
2358 |  |  |  |  |
2359 |  |  |  |  | # if twig_roots is set for the element then set appropriate handler
2360 | 364369 | 269ms | 363976 | 180ms | if( $t->{twig_root_depth} and ($p->depth == $t->{twig_root_depth}) ) # spent 180ms making 363976 calls to XML::Parser::Expat::depth, avg 494ns/call
2361 | 33792 | 8.14ms |  |  | { if( $t->{twig_default_print})
2362 |  |  |  |  | { # select the proper fh (and store the currently selected one)
2363 |  |  |  |  | $t->_set_fh_to_twig_output_fh();
2364 |  |  |  |  | if( !$p->depth==1) { $t->{twig_right_after_root}=1; } #XX
2365 |  |  |  |  | if( $t->{twig_keep_encoding})
2366 |  |  |  |  | { $p->setHandlers( %twig_handlers_roots_print_original); }
2367 |  |  |  |  | else
2368 |  |  |  |  | { $p->setHandlers( %twig_handlers_roots_print); }
2369 |  |  |  |  | }
2370 |  |  |  |  | else
2371 | 33792 | 50.0ms | 33792 | 1.66s | { $p->setHandlers( %twig_handlers_roots); } # spent 1.66s making 33792 calls to XML::Parser::Expat::setHandlers, avg 49µs/call
2372 |  |  |  |  | }
2373 |  |  |  |  |
2374 | 364369 | 62.4ms |  |  | if( $elt->{'att'}->{'xml:space'} && ( $elt->{'att'}->{'xml:space'} eq 'preserve')) { $t->{twig_preserve_space}--; }
2375 |  |  |  |  |
2376 | 364369 | 271ms |  |  | pop @{$t->{_twig_context_stack}};
2377 | 364369 | 995ms |  |  | return;
2378 |  |  |  |  | }
2379 |  |  |  |  |
2380 |  |  |  |  | sub _trigger_tdh
2381 |  |  |  |  | { my( $t)= @_;
2382 |  |  |  |  |
2383 |  |  |  |  | if( @{$t->{twig_handlers_to_trigger}})
2384 |  |  |  |  | { my @handlers_to_trigger_now= sort { $a->[0]->cmp( $b->[0]) } @{$t->{twig_handlers_to_trigger}};
2385 |  |  |  |  | foreach my $elt_handlers (@handlers_to_trigger_now)
2386 |  |  |  |  | { my( $handled_elt, $handlers_to_trigger)= @$elt_handlers;
2387 |  |  |  |  | foreach my $handler ( @$handlers_to_trigger)
2388 |  |  |  |  | { local $_= $handled_elt; $handler->($t, $handled_elt) || last; }
2389 |  |  |  |  | }
2390 |  |  |  |  | }
2391 |  |  |  |  | return;
2392 |  |  |  |  | }
2393 |  |  |  |  |
2394 |  |  |  |  | # return the list of handler that can be activated for an element
2395 |  |  |  |  | # (either of CODE ref's or 1's for twig_roots)
2396 |  |  |  |  |
2397 |  |  |  |  | sub _handler
2398 | 397806 | 78.9ms |  |  | # spent 1.46s (1.18+285ms) within XML::Twig::_handler which was called 397806 times, avg 4µs/call: # 364007 times (908ms+145ms) by XML::Twig::_twig_end at line 2338, avg 3µs/call # 33799 times (269ms+139ms) by XML::Twig::_twig_start_check_roots at line 4143, avg 12µs/call { my( $t, $handlers, $gi)= @_;
2399 |  |  |  |  |
2400 | 397806 | 63.4ms |  |  | my @found_handlers=();
2401 | 397806 | 27.9ms |  |  | my $found_handler;
2402 |  |  |  |  |
2403 | 397806 | 353ms |  |  | foreach my $handler ( map { @$_ } grep { $_ } $handlers->{xpath_handler}->{$gi}, $handlers->{xpath_handler}->{'*'})
2404 | 67599 | 15.3ms |  |  | { my $trigger= $handler->{trigger};
2405 | 67599 | 75.2ms | 67599 | 285ms | if( my $found_path= $trigger->( $t->{_twig_context_stack})) # spent 149ms making 31216 calls to XML::Twig::__ANON__[(eval 114)[XML/Twig.pm:1750]:26], avg 5µs/call # spent 136ms making 36360 calls to XML::Twig::__ANON__[(eval 109)[XML/Twig.pm:1750]:26], avg 4µs/call # spent 41µs making 15 calls to XML::Twig::__ANON__[(eval 102)[XML/Twig.pm:1750]:17], avg 3µs/call # spent 22µs making 4 calls to XML::Twig::__ANON__[(eval 106)[XML/Twig.pm:1750]:17], avg 6µs/call # spent 12µs making 2 calls to XML::Twig::__ANON__[(eval 111)[XML/Twig.pm:1750]:17], avg 6µs/call # spent 12µs making 2 calls to XML::Twig::__ANON__[(eval 110)[XML/Twig.pm:1750]:17], avg 6µs/call
2406 | 67599 | 10.7ms |  |  | { my $found_handler= $handler->{handler};
2407 | 67599 | 12.7ms |  |  | push @found_handlers, $found_handler;
2408 |  |  |  |  | }
2409 |  |  |  |  | }
2410 |  |  |  |  |
2411 |  |  |  |  | # if no handler found call default handler if defined
2412 | 397806 | 115ms |  |  | if( !@found_handlers && defined $handlers->{handlers}->{$DEFAULT})
2413 |  |  |  |  | { push @found_handlers, $handlers->{handlers}->{$DEFAULT}; }
2414 |  |  |  |  |
2415 | 397806 | 42.0ms |  |  | if( @found_handlers and $t->{twig_do_not_chain_handlers})
2416 |  |  |  |  | { @found_handlers= ($found_handlers[0]); }
2417 |  |  |  |  |
2418 | 397806 | 706ms |  |  | return @found_handlers; # empty if no handler found
2419 |  |  |  |  |
2420 |  |  |  |  | }
2421 |  |  |  |  |
2422 |  |  |  |  |
2423 |  |  |  |  | sub _replace_prefix
2424 | 364369 | 54.4ms |  |  | # spent 2.69s (2.12+567ms) within XML::Twig::_replace_prefix which was called 364369 times, avg 7µs/call: # 364369 times (2.12s+567ms) by XML::Twig::_twig_end at line 2305, avg 7µs/call { my( $t, $name)= @_;
2425 | 364369 | 196ms | 364369 | 118ms | my $p= $t->parser; # spent 118ms making 364369 calls to XML::Twig::parser, avg 325ns/call
2426 | 364369 | 185ms | 364369 | 448ms | my $uri= $p->namespace( $name); # spent 448ms making 364369 calls to XML::Parser::Expat::namespace, avg 1µs/call
2427 |  |  |  |  | # try to get the namespace from default if none is found (for attributes)
2428 |  |  |  |  | # this should probably be an option
2429 | 364369 | 47.1ms |  |  | if( !$uri and( $name!~/^xml/)) { $uri= $p->expand_ns_prefix( '#default'); }
2430 | 364369 | 43.6ms |  |  | if( $uri)
2431 | 364369 | 1.02s |  |  | { if (my $mapped_prefix= $t->{twig_map_xmlns}->{$uri} || $DEFAULT_URI2NS{$uri})
2432 |  |  |  |  | { return "$mapped_prefix:$name"; }
2433 |  |  |  |  | else
2434 | 6 | 5µs | 6 | 84µs | { my $prefix= _a_proper_ns_prefix( $p, $uri); # spent 84µs making 6 calls to XML::Twig::_a_proper_ns_prefix, avg 14µs/call
2435 | 6 | 1µs |  |  | if( $prefix eq '#default') { $prefix=''; }
2436 | 6 | 10µs |  |  | return $prefix ? "$prefix:$name" : $name;
2437 |  |  |  |  | }
2438 |  |  |  |  | }
2439 |  |  |  |  | else
2440 |  |  |  |  | { return $name; }
2441 |  |  |  |  | }
2442 |  |  |  |  |
2443 |  |  |  |  |
2444 |  |  |  |  | sub _twig_char
2445 |  |  |  |  | # spent 1.91s (829ms+1.09) within XML::Twig::_twig_char which was called 127292 times, avg 15µs/call: # 127292 times (829ms+1.09s) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 15µs/call { # warn " in _twig_char...\n"; # DEBUG handler
2446 |  |  |  |  |
2447 | 127292 | 21.3ms |  |  | my ($p, $string)= @_;
2448 | 127292 | 23.7ms |  |  | my $t=$p->{twig};
2449 |  |  |  |  |
2450 | 127292 | 23.8ms |  |  | if( $t->{twig_keep_encoding})
2451 |  |  |  |  | { if( !$t->{twig_in_cdata})
2452 |  |  |  |  | { $string= $p->original_string(); }
2453 |  |  |  |  | else
2454 |  |  |  |  | {
2455 | 2 | 3.66ms | 2 | 12µs | # spent 10µs (8+2) within XML::Twig::BEGIN@2455 which was called: # once (8µs+2µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 2455 use bytes; # > perl 5.5 # spent 10µs making 1 call to XML::Twig::BEGIN@2455 # spent 2µs making 1 call to bytes::import
2456 |  |  |  |  | if( length( $string) < 1024)
2457 |  |  |  |  | { $string= $p->original_string(); }
2458 |  |  |  |  | else
2459 |  |  |  |  | { #warn "dodgy case";
2460 |  |  |  |  | # TODO original_string does not hold the entire string, but $string is wrong
2461 |  |  |  |  | # I believe due to a bug in XML::Parser
2462 |  |  |  |  | # for now, we use the original string, even if it means that it's been converted to utf8
2463 |  |  |  |  | }
2464 |  |  |  |  | }
2465 |  |  |  |  | }
2466 |  |  |  |  |
2467 | 127292 | 22.3ms |  |  | if( $t->{twig_input_filter}) { $string= $t->{twig_input_filter}->( $string); }
2468 | 127292 | 19.5ms |  |  | if( $t->{twig_char_handler}) { $string= $t->{twig_char_handler}->( $string); }
2469 |  |  |  |  |
2470 | 127292 | 17.9ms |  |  | my $elt= $t->{twig_current};
2471 |  |  |  |  |
2472 | 127292 | 39.7ms |  |  | if( $t->{twig_in_cdata})
2473 |  |  |  |  | { # text is the continuation of a previously created cdata
2474 |  |  |  |  | $elt->{cdata}.= $t->{twig_stored_spaces} . $string;
2475 |  |  |  |  | }
2476 |  |  |  |  | elsif( $t->{twig_in_pcdata})
2477 |  |  |  |  | { # text is the continuation of a previously created pcdata
2478 |  |  |  |  | if( $t->{extra_data})
2479 |  |  |  |  | { $elt->_push_extra_data_in_pcdata( $t->{extra_data}, length( $elt->{pcdata}));
2480 |  |  |  |  | $t->{extra_data}='';
2481 |  |  |  |  | }
2482 |  |  |  |  | $elt->{pcdata}.= $string;
2483 |  |  |  |  | }
2484 |  |  |  |  | else
2485 |  |  |  |  | {
2486 |  |  |  |  | # text is just space, which might be discarded later
2487 | 127292 | 298ms | 127292 | 80.4ms | if( $string=~/\A\s*\Z/s) # spent 80.4ms making 127292 calls to CORE::match, avg 632ns/call
2488 |  |  |  |  | {
2489 |  |  |  |  | if( $t->{extra_data})
2490 |  |  |  |  | { # we got extra data (comment, pi), lets add the spaces to it
2491 |  |  |  |  | $t->{extra_data} .= $string;
2492 |  |  |  |  | }
2493 |  |  |  |  | else
2494 |  |  |  |  | { # no extra data, just store the spaces
2495 |  |  |  |  | $t->{twig_stored_spaces}.= $string;
2496 |  |  |  |  | }
2497 |  |  |  |  | }
2498 |  |  |  |  | else
2499 | 127292 | 123ms | 127292 | 1.00s | { my $new_elt= _insert_pcdata( $t, $t->{twig_stored_spaces}.$string); # spent 1.00s making 127292 calls to XML::Twig::_insert_pcdata, avg 8µs/call
2500 | 127292 | 16.4ms |  |  | delete $elt->{'twig_current'};
2501 | 127292 | 22.4ms |  |  | $new_elt->{'twig_current'}=1;
2502 | 127292 | 18.4ms |  |  | $t->{twig_current}= $new_elt;
2503 | 127292 | 20.3ms |  |  | $t->{twig_in_pcdata}=1;
2504 | 127292 | 28.9ms |  |  | if( $t->{extra_data})
2505 |  |  |  |  | { $new_elt->_push_extra_data_in_pcdata( $t->{extra_data}, 0);
2506 |  |  |  |  | $t->{extra_data}='';
2507 |  |  |  |  | }
2508 |  |  |  |  | }
2509 |  |  |  |  | }
2510 | 127292 | 243ms |  |  | return;
2511 |  |  |  |  | }
2512 |  |  |  |  |
2513 |  |  |  |  | sub _twig_cdatastart
2514 |  |  |  |  | { # warn " in _twig_cdatastart...\n"; # DEBUG handler
2515 |  |  |  |  |
2516 |  |  |  |  | my $p= shift;
2517 |  |  |  |  | my $t=$p->{twig};
2518 |  |  |  |  |
2519 |  |  |  |  | $t->{twig_in_cdata}=1;
2520 |  |  |  |  | my $cdata= $t->{twig_elt_class}->new( $CDATA);
2521 |  |  |  |  | my $twig_current= $t->{twig_current};
2522 |  |  |  |  |
2523 |  |  |  |  | if( $t->{twig_in_pcdata})
2524 |  |  |  |  | { # create the node as a sibling of the PCDATA
2525 |  |  |  |  | $cdata->{prev_sibling}=$twig_current; if( $XML::Twig::weakrefs) { weaken( $cdata->{prev_sibling});} ;
2526 |  |  |  |  | $twig_current->{next_sibling}= $cdata;
2527 |  |  |  |  | my $parent= $twig_current->{parent};
2528 |  |  |  |  | $cdata->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $cdata->{parent});} ;
2529 |  |  |  |  | delete $parent->{empty}; $parent->{last_child}=$cdata; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ;
2530 |  |  |  |  | $t->{twig_in_pcdata}=0;
2531 |  |  |  |  | }
2532 |  |  |  |  | else
2533 |  |  |  |  | { # we have to create a PCDATA element if we need to store spaces
2534 |  |  |  |  | if( $t->_space_policy($XML::Twig::index2gi[$twig_current->{'gi'}]) && $t->{twig_stored_spaces})
2535 |  |  |  |  | { _insert_pcdata( $t, $t->{twig_stored_spaces}); }
2536 |  |  |  |  | $t->{twig_stored_spaces}='';
2537 |  |  |  |  |
2538 |  |  |  |  | # create the node as a child of the current element
2539 |  |  |  |  | $cdata->{parent}=$twig_current; if( $XML::Twig::weakrefs) { weaken( $cdata->{parent});} ;
2540 |  |  |  |  | if( my $prev_sibling= $twig_current->{last_child})
2541 |  |  |  |  | { $cdata->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $cdata->{prev_sibling});} ;
2542 |  |  |  |  | $prev_sibling->{next_sibling}= $cdata;
2543 |  |  |  |  | }
2544 |  |  |  |  | else
2545 |  |  |  |  | { $twig_current->{first_child}= $cdata; }
2546 |  |  |  |  | delete $twig_current->{empty}; $twig_current->{last_child}=$cdata; if( $XML::Twig::weakrefs) { weaken( $twig_current->{last_child});} ;
2547 |  |  |  |  |
2548 |  |  |  |  | }
2549 |  |  |  |  |
2550 |  |  |  |  | delete $twig_current->{'twig_current'};
2551 |  |  |  |  | $t->{twig_current}= $cdata;
2552 |  |  |  |  | $cdata->{'twig_current'}=1;
2553 |  |  |  |  | if( $t->{extra_data}) { $cdata->set_extra_data( $t->{extra_data}); $t->{extra_data}='' };
2554 |  |  |  |  | return;
2555 |  |  |  |  | }
2556 |  |  |  |  |
2557 |  |  |  |  | sub _twig_cdataend
2558 |  |  |  |  | { # warn " in _twig_cdataend...\n"; # DEBUG handler
2559 |  |  |  |  |
2560 |  |  |  |  | my $p= shift;
2561 |  |  |  |  | my $t=$p->{twig};
2562 |  |  |  |  |
2563 |  |  |  |  | $t->{twig_in_cdata}=0;
2564 |  |  |  |  |
2565 |  |  |  |  | my $elt= $t->{twig_current};
2566 |  |  |  |  | delete $elt->{'twig_current'};
2567 |  |  |  |  | my $cdata= $elt->{cdata};
2568 |  |  |  |  | $elt->{cdata}= $cdata;
2569 |  |  |  |  |
2570 |  |  |  |  | push @{$t->{_twig_context_stack}}, { $ST_TAG => $CDATA };
2571 |  |  |  |  |
2572 |  |  |  |  | if( $t->{twig_handlers})
2573 |  |  |  |  | { # look for handlers
2574 |  |  |  |  | my @handlers= _handler( $t, $t->{twig_handlers}, $CDATA);
2575 |  |  |  |  | local $_= $elt; # so we can use $_ in the handlers
2576 |  |  |  |  | foreach my $handler ( @handlers) { $handler->($t, $elt) || last; }
2577 |  |  |  |  | }
2578 |  |  |  |  |
2579 |  |  |  |  | pop @{$t->{_twig_context_stack}};
2580 |  |  |  |  |
2581 |  |  |  |  | $elt= $elt->{parent};
2582 |  |  |  |  | $t->{twig_current}= $elt;
2583 |  |  |  |  | $elt->{'twig_current'}=1;
2584 |  |  |  |  |
2585 |  |  |  |  | $t->{twig_long_cdata}=0;
2586 |  |  |  |  | return;
2587 |  |  |  |  | }
2588 |  |  |  |  |
2589 |  |  |  |  | sub _pi_elt_handlers
2590 |  |  |  |  | { my( $t, $pi)= @_;
2591 |  |  |  |  | my $pi_handlers= $t->{twig_handlers}->{pi_handlers} || return;
2592 |  |  |  |  | foreach my $handler ( $pi_handlers->{$pi->{target}}, $pi_handlers->{''})
2593 |  |  |  |  | { if( $handler) { local $_= $pi; $handler->( $t, $pi) || last; } }
2594 |  |  |  |  | }
2595 |  |  |  |  |
2596 |  |  |  |  | sub _pi_text_handler
2597 |  |  |  |  | { my( $t, $target, $data)= @_;
2598 |  |  |  |  | if( my $handler= $t->{twig_handlers}->{pi_handlers}->{$target})
2599 |  |  |  |  | { return $handler->( $t, $target, $data); }
2600 |  |  |  |  | if( my $handler= $t->{twig_handlers}->{pi_handlers}->{''})
2601 |  |  |  |  | { return $handler->( $t, $target, $data); }
2602 |  |  |  |  | return defined( $data) && $data ne '' ? "<?$target $data?>" : "<?$target?>" ;
2603 |  |  |  |  | }
2604 |  |  |  |  |
2605 |  |  |  |  | sub _comment_elt_handler
2606 |  |  |  |  | { my( $t, $comment)= @_;
2607 |  |  |  |  | if( my $handler= $t->{twig_handlers}->{handlers}->{$COMMENT})
2608 |  |  |  |  | { local $_= $comment; $handler->($t, $comment); }
2609 |  |  |  |  | }
2610 |  |  |  |  |
2611 |  |  |  |  | sub _comment_text_handler
2612 |  |  |  |  | { my( $t, $comment)= @_;
2613 |  |  |  |  | if( my $handler= $t->{twig_handlers}->{handlers}->{$COMMENT})
2614 |  |  |  |  | { $comment= $handler->($t, $comment);
2615 |  |  |  |  | if( !defined $comment || $comment eq '') { return ''; }
2616 |  |  |  |  | }
2617 |  |  |  |  | return "<!--$comment-->";
2618 |  |  |  |  | }
2619 |  |  |  |  |
- - |  |  |  |  |
2622 |  |  |  |  | sub _twig_comment
2623 |  |  |  |  | { # warn " in _twig_comment...\n"; # DEBUG handler
2624 |  |  |  |  |
2625 |  |  |  |  | my( $p, $comment_text)= @_;
2626 |  |  |  |  | my $t=$p->{twig};
2627 |  |  |  |  |
2628 |  |  |  |  | if( $t->{twig_keep_encoding}) { $comment_text= substr( $p->original_string(), 4, -3); }
2629 |  |  |  |  |
2630 |  |  |  |  | $t->_twig_pi_comment( $p, $COMMENT, $t->{twig_keep_comments}, $t->{twig_process_comments},
2631 |  |  |  |  | '_set_comment', '_comment_elt_handler', '_comment_text_handler', $comment_text
2632 |  |  |  |  | );
2633 |  |  |  |  | return;
2634 |  |  |  |  | }
2635 |  |  |  |  |
2636 |  |  |  |  | sub _twig_pi
2637 |  |  |  |  | { # warn " in _twig_pi...\n"; # DEBUG handler
2638 |  |  |  |  |
2639 |  |  |  |  | my( $p, $target, $data)= @_;
2640 |  |  |  |  | my $t=$p->{twig};
2641 |  |  |  |  |
2642 |  |  |  |  | if( $t->{twig_keep_encoding})
2643 |  |  |  |  | { my $pi_text= substr( $p->original_string(), 2, -2);
2644 |  |  |  |  | ($target, $data)= split( /\s+/, $pi_text, 2);
2645 |  |  |  |  | }
2646 |  |  |  |  |
2647 |  |  |  |  | $t->_twig_pi_comment( $p, $PI, $t->{twig_keep_pi}, $t->{twig_process_pi},
2648 |  |  |  |  | '_set_pi', '_pi_elt_handlers', '_pi_text_handler', $target, $data
2649 |  |  |  |  | );
2650 |  |  |  |  | return;
2651 |  |  |  |  | }
2652 |  |  |  |  |
2653 |  |  |  |  | sub _twig_pi_comment
2654 |  |  |  |  | { my( $t, $p, $type, $keep, $process, $set, $elt_handler, $text_handler, @parser_args)= @_;
2655 |  |  |  |  |
2656 |  |  |  |  | if( $t->{twig_input_filter})
2657 |  |  |  |  | { foreach my $arg (@parser_args) { $arg= $t->{twig_input_filter}->( $arg); } }
2658 |  |  |  |  |
2659 |  |  |  |  | # if pi/comments are to be kept then we piggyback them to the current element
2660 |  |  |  |  | if( $keep)
2661 |  |  |  |  | { # first add spaces
2662 |  |  |  |  | if( $t->{twig_stored_spaces})
2663 |  |  |  |  | { $t->{extra_data}.= $t->{twig_stored_spaces};
2664 |  |  |  |  | $t->{twig_stored_spaces}= '';
2665 |  |  |  |  | }
2666 |  |  |  |  |
2667 |  |  |  |  | my $extra_data= $t->$text_handler( @parser_args);
2668 |  |  |  |  | $t->{extra_data}.= $extra_data;
2669 |  |  |  |  |
2670 |  |  |  |  | }
2671 |  |  |  |  | elsif( $process)
2672 |  |  |  |  | {
2673 |  |  |  |  | my $twig_current= $t->{twig_current}; # defined unless we are outside of the root
2674 |  |  |  |  |
2675 |  |  |  |  | my $elt= $t->{twig_elt_class}->new( $type);
2676 |  |  |  |  | $elt->$set( @parser_args);
2677 |  |  |  |  | if( $t->{extra_data})
2678 |  |  |  |  | { $elt->set_extra_data( $t->{extra_data});
2679 |  |  |  |  | $t->{extra_data}='';
2680 |  |  |  |  | }
2681 |  |  |  |  |
2682 |  |  |  |  | unless( $t->root)
2683 |  |  |  |  | { $t->_add_cpi_outside_of_root( leading_cpi => $elt);
2684 |  |  |  |  | }
2685 |  |  |  |  | elsif( $t->{twig_in_pcdata})
2686 |  |  |  |  | { # create the node as a sibling of the PCDATA
2687 |  |  |  |  | $elt->paste_after( $twig_current);
2688 |  |  |  |  | $t->{twig_in_pcdata}=0;
2689 |  |  |  |  | }
2690 |  |  |  |  | elsif( $twig_current)
2691 |  |  |  |  | { # we have to create a PCDATA element if we need to store spaces
2692 |  |  |  |  | if( $t->_space_policy($XML::Twig::index2gi[$twig_current->{'gi'}]) && $t->{twig_stored_spaces})
2693 |  |  |  |  | { _insert_pcdata( $t, $t->{twig_stored_spaces}); }
2694 |  |  |  |  | $t->{twig_stored_spaces}='';
2695 |  |  |  |  | # create the node as a child of the current element
2696 |  |  |  |  | $elt->paste_last_child( $twig_current);
2697 |  |  |  |  | }
2698 |  |  |  |  | else
2699 |  |  |  |  | { $t->_add_cpi_outside_of_root( trailing_cpi => $elt); }
2700 |  |  |  |  |
2701 |  |  |  |  | if( $twig_current)
2702 |  |  |  |  | { delete $twig_current->{'twig_current'};
2703 |  |  |  |  | my $parent= $elt->{parent};
2704 |  |  |  |  | $t->{twig_current}= $parent;
2705 |  |  |  |  | $parent->{'twig_current'}=1;
2706 |  |  |  |  | }
2707 |  |  |  |  |
2708 |  |  |  |  | $t->$elt_handler( $elt);
2709 |  |  |  |  | }
2710 |  |  |  |  |
2711 |  |  |  |  | }
2712 |  |  |  |  |
2713 |  |  |  |  |
2714 |  |  |  |  | # add a comment or pi before the first element
2715 |  |  |  |  | sub _add_cpi_outside_of_root
2716 |  |  |  |  | { my($t, $type, $elt)= @_; # $type is 'leading_cpi' or 'trailing_cpi'
2717 |  |  |  |  | $t->{$type} ||= $t->{twig_elt_class}->new( '#CPI');
2718 |  |  |  |  | # create the node as a child of the current element
2719 |  |  |  |  | $elt->paste_last_child( $t->{$type});
2720 |  |  |  |  | return $t;
2721 |  |  |  |  | }
2722 |  |  |  |  |
2723 |  |  |  |  | sub _twig_final
2724 |  |  |  |  | # spent 88µs (65+23) within XML::Twig::_twig_final which was called 7 times, avg 13µs/call: # 7 times (65µs+23µs) by XML::Parser::parse at line 199 of XML/Parser.pm, avg 13µs/call { # warn " in _twig_final...\n"; # DEBUG handler
2725 |  |  |  |  |
2726 | 7 | 1µs |  |  | my $p= shift;
2727 | 7 | 25µs | 7 | 12µs | my $t= $p->isa( 'XML::Twig') ? $p : $p->{twig}; # spent 12µs making 7 calls to UNIVERSAL::isa, avg 2µs/call
2728 |  |  |  |  |
2729 |  |  |  |  | # store trailing data
2730 | 7 | 2µs |  |  | if( $t->{extra_data}) { $t->{trailing_cpi_text} = $t->{extra_data}; $t->{extra_data}=''; }
2731 | 7 | 5µs |  |  | $t->{trailing_spaces}= $t->{twig_stored_spaces} || '';
2732 | 14 | 13µs | 7 | 3µs | my $s= $t->{twig_stored_spaces}; $s=~s{\n}{\\n}g; # spent 3µs making 7 calls to CORE::subst, avg 386ns/call
2733 | 7 | 2µs |  |  | if( $t->{twig_stored_spaces}) { my $s= $t->{twig_stored_spaces}; }
2734 |  |  |  |  |
2735 |  |  |  |  | # restore the selected filehandle if needed
2736 | 7 | 7µs | 7 | 8µs | $t->_set_fh_to_selected_fh(); # spent 8µs making 7 calls to XML::Twig::_set_fh_to_selected_fh, avg 1µs/call
2737 |  |  |  |  |
2738 | 7 | 1µs |  |  | $t->_trigger_tdh if( $t->{twig_tdh});
2739 |  |  |  |  |
2740 | 7 | 1µs |  |  | select $t->{twig_original_selected_fh} if($t->{twig_original_selected_fh}); # probably dodgy
2741 |  |  |  |  |
2742 | 7 | 2µs |  |  | if( exists $t->{twig_autoflush_data})
2743 |  |  |  |  | { my @args;
2744 |  |  |  |  | push @args, $t->{twig_autoflush_data}->{fh} if( $t->{twig_autoflush_data}->{fh});
2745 |  |  |  |  | push @args, @{$t->{twig_autoflush_data}->{args}} if( $t->{twig_autoflush_data}->{args});
2746 |  |  |  |  | $t->flush( @args);
2747 |  |  |  |  | delete $t->{twig_autoflush_data};
2748 |  |  |  |  | $t->root->delete if $t->root;
2749 |  |  |  |  | }
2750 |  |  |  |  |
2751 |  |  |  |  | # tries to clean-up (probably not very well at the moment)
2752 |  |  |  |  | #undef $p->{twig};
2753 | 7 | 3µs |  |  | undef $t->{twig_parser};
2754 | 7 | 2µs |  |  | delete $t->{twig_parsing};
2755 | 7 | 7µs |  |  | @{$t}{ qw( twig_parser twig_parsing _twig_context_stack twig_current) }=();
2756 |  |  |  |  |
2757 | 7 | 12µs |  |  | return $t;
2758 |  |  |  |  | }
2759 |  |  |  |  |
2760 |  |  |  |  | sub _insert_pcdata
2761 | 127292 | 22.5ms |  |  | # spent 1.00s (968ms+36.8ms) within XML::Twig::_insert_pcdata which was called 127292 times, avg 8µs/call: # 127292 times (968ms+36.8ms) by XML::Twig::_twig_char at line 2499, avg 8µs/call { my( $t, $string)= @_;
2762 |  |  |  |  | # create a new PCDATA element
2763 | 127292 | 18.8ms |  |  | my $parent= $t->{twig_current}; # always defined
2764 | 127292 | 9.94ms |  |  | my $elt;
2765 | 127292 | 32.0ms |  |  | if( exists $t->{twig_alt_elt_class})
2766 |  |  |  |  | { $elt= $t->{twig_elt_class}->new( $PCDATA);
2767 |  |  |  |  | $elt->{pcdata}= $string;
2768 |  |  |  |  | }
2769 |  |  |  |  | else
2770 | 127292 | 126ms |  |  | { $elt= bless( { gi => $XML::Twig::gi2index{$PCDATA}, pcdata => $string }, 'XML::Twig::Elt'); }
2771 |  |  |  |  |
2772 | 127292 | 16.3ms |  |  | my $prev_sibling= $parent->{last_child};
2773 | 127292 | 32.0ms |  |  | if( $prev_sibling)
2774 |  |  |  |  | { $prev_sibling->{next_sibling}= $elt;
2775 |  |  |  |  | $elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
2776 |  |  |  |  | }
2777 |  |  |  |  | else
2778 | 127292 | 26.4ms |  |  | { $parent->{first_child}= $elt; }
2779 |  |  |  |  |
2780 | 254584 | 306ms | 127292 | 22.7ms | $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ; # spent 22.7ms making 127292 calls to Scalar::Util::weaken, avg 178ns/call
2781 | 381876 | 311ms | 127292 | 14.1ms | delete $parent->{empty}; $parent->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; # spent 14.1ms making 127292 calls to Scalar::Util::weaken, avg 111ns/call
2782 | 127292 | 22.3ms |  |  | $t->{twig_stored_spaces}='';
2783 | 127292 | 234ms |  |  | return $elt;
2784 |  |  |  |  | }
2785 |  |  |  |  |
2786 |  |  |  |  | sub _space_policy
2787 |  |  |  |  | { my( $t, $gi)= @_;
2788 |  |  |  |  | my $policy;
2789 |  |  |  |  | $policy=0 if( $t->{twig_discard_spaces});
2790 |  |  |  |  | $policy=1 if( $t->{twig_keep_spaces});
2791 |  |  |  |  | $policy=1 if( $t->{twig_keep_spaces_in}
2792 |  |  |  |  | && $t->{twig_keep_spaces_in}->{$gi});
2793 |  |  |  |  | $policy=0 if( $t->{twig_discard_spaces_in}
2794 |  |  |  |  | && $t->{twig_discard_spaces_in}->{$gi});
2795 |  |  |  |  | return $policy;
2796 |  |  |  |  | }
2797 |  |  |  |  |
2798 |  |  |  |  |
2799 |  |  |  |  | sub _twig_entity
2800 |  |  |  |  | { # warn " in _twig_entity...\n"; # DEBUG handler
2801 |  |  |  |  | my( $p, $name, $val, $sysid, $pubid, $ndata, $param)= @_;
2802 |  |  |  |  | my $t=$p->{twig};
2803 |  |  |  |  |
2804 |  |  |  |  | #{ no warnings; my $base= $p->base; warn "_twig_entity called: expand: '$t->{twig_expand_external_ents}', base: '$base', name: '$name', val: '$val', sysid: '$sysid', pubid: '$pubid', ndata: '$ndata', param: '$param'\n";}
2805 |  |  |  |  |
2806 |  |  |  |  | my $missing_entity=0;
2807 |  |  |  |  |
2808 |  |  |  |  | if( $sysid)
2809 |  |  |  |  | { if($ndata)
2810 |  |  |  |  | { if( ! -f _based_filename( $sysid, $p->base)) { $missing_entity= 1; }
2811 |  |  |  |  | }
2812 |  |  |  |  | else
2813 |  |  |  |  | { if( $t->{twig_expand_external_ents})
2814 |  |  |  |  | { $val= eval { _slurp_uri( $sysid, $p->base) };
2815 |  |  |  |  | if( ! defined $val)
2816 |  |  |  |  | { if( $t->{twig_extern_ent_nofail})
2817 |  |  |  |  | { $missing_entity= 1; }
2818 |  |  |  |  | else
2819 |  |  |  |  | { _croak( "cannot load SYSTEM entity '$name' from '$sysid': $@", 3); }
2820 |  |  |  |  | }
2821 |  |  |  |  | }
2822 |  |  |  |  | }
2823 |  |  |  |  | }
2824 |  |  |  |  |
2825 |  |  |  |  | my $ent=XML::Twig::Entity->new( $name, $val, $sysid, $pubid, $ndata, $param);
2826 |  |  |  |  | if( $missing_entity) { $t->{twig_missing_system_entities}->{$name}= $ent; }
2827 |  |  |  |  |
2828 |  |  |  |  | my $entity_list= $t->entity_list;
2829 |  |  |  |  | if( $entity_list) { $entity_list->add( $ent); }
2830 |  |  |  |  |
2831 |  |  |  |  | if( $parser_version > 2.27)
2832 |  |  |  |  | { # this is really ugly, but with some versions of XML::Parser the value
2833 |  |  |  |  | # of the entity is not properly returned by the default handler
2834 |  |  |  |  | my $ent_decl= $ent->text;
2835 |  |  |  |  | if( $t->{twig_keep_encoding})
2836 |  |  |  |  | { if( defined $ent->{val} && ($ent_decl !~ /["']/))
2837 |  |  |  |  | { my $val= $ent->{val};
2838 |  |  |  |  | $ent_decl .= $val =~ /"/ ? qq{'$val' } : qq{"$val" };
2839 |  |  |  |  | }
2840 |  |  |  |  | # for my solaris box (perl 5.6.1, XML::Parser 2.31, expat?)
2841 |  |  |  |  | $t->{twig_doctype}->{internal}=~ s{<!ENTITY\s+$name\s+$}{substr( $ent_decl, 0, -1)}e;
2842 |  |  |  |  | }
2843 |  |  |  |  | $t->{twig_doctype}->{internal} .= $ent_decl
2844 |  |  |  |  | unless( $t->{twig_doctype}->{internal}=~ m{<!ENTITY\s+$name\s+});
2845 |  |  |  |  | }
2846 |  |  |  |  |
2847 |  |  |  |  | return;
2848 |  |  |  |  | }
2849 |  |  |  |  |
2850 |  |  |  |  | sub _twig_notation
2851 |  |  |  |  | { my( $p, $name, $base, $sysid, $pubid ) = @_;
2852 |  |  |  |  | my $t = $p->{twig};
2853 |  |  |  |  |
2854 |  |  |  |  | my $notation = XML::Twig::Notation->new( $name, $base, $sysid, $pubid );
2855 |  |  |  |  | my $notation_list = $t->notation_list();
2856 |  |  |  |  | if( $notation_list ) { $notation_list->add( $notation ); }
2857 |  |  |  |  |
2858 |  |  |  |  | # internal should get the recognized_string, but XML::Parser does not provide it
2859 |  |  |  |  | # so we need to re-create it ( $notation->text) and stick it there.
2860 |  |  |  |  | $t->{twig_doctype}->{internal} .= $notation->text;
2861 |  |  |  |  |
2862 |  |  |  |  | return;
2863 |  |  |  |  | }
2864 |  |  |  |  |
2865 |  |  |  |  |
2866 |  |  |  |  | sub _twig_extern_ent
2867 |  |  |  |  | { # warn " in _twig_extern_ent...I (", $_[0]->original_string, ")\n"; # DEBUG handler
2868 |  |  |  |  | my( $p, $base, $sysid, $pubid)= @_;
2869 |  |  |  |  | my $t= $p->{twig};
2870 |  |  |  |  | if( $t->{twig_no_expand})
2871 |  |  |  |  | { my $ent_name= $t->{twig_keep_encoding} ? $p->original_string : $p->recognized_string;
2872 |  |  |  |  | _twig_insert_ent( $t, $ent_name);
2873 |  |  |  |  | return '';
2874 |  |  |  |  | }
2875 |  |  |  |  | my $ent_content= eval { $t->{twig_ext_ent_handler}->( $p, $base, $sysid) };
2876 |  |  |  |  | if( ! defined $ent_content)
2877 |  |  |  |  | {
2878 |  |  |  |  | my $ent_name = $p->recognized_string;
2879 |  |  |  |  | my $file = _based_filename( $sysid, $base);
2880 |  |  |  |  | my $error_message= "cannot expand $ent_name - cannot load '$file'";
2881 |  |  |  |  | if( $t->{twig_extern_ent_nofail}) { return "<!-- $error_message -->"; }
2882 |  |  |  |  | else { _croak( $error_message); }
2883 |  |  |  |  | }
2884 |  |  |  |  | return $ent_content;
2885 |  |  |  |  | }
2886 |  |  |  |  |
2887 |  |  |  |  | # I use this so I can change the $Carp::CarpLevel (which determines how many call frames to skip when reporting an error)
2888 |  |  |  |  | sub _croak
2889 |  |  |  |  | { my( $message, $level)= @_;
2890 |  |  |  |  | $Carp::CarpLevel= $level || 0;
2891 |  |  |  |  | croak $message;
2892 |  |  |  |  | }
2893 |  |  |  |  |
2894 |  |  |  |  | sub _twig_xmldecl
2895 |  |  |  |  | # spent 32µs within XML::Twig::_twig_xmldecl which was called 7 times, avg 5µs/call: # 7 times (32µs+0s) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 5µs/call { # warn " in _twig_xmldecl...\n"; # DEBUG handler
2896 |  |  |  |  |
2897 | 7 | 2µs |  |  | my $p= shift;
2898 | 7 | 3µs |  |  | my $t=$p->{twig};
2899 | 7 | 4µs |  |  | $t->{twig_xmldecl}||={}; # could have been set by set_output_encoding
2900 | 7 | 6µs |  |  | $t->{twig_xmldecl}->{version}= shift;
2901 | 7 | 4µs |  |  | $t->{twig_xmldecl}->{encoding}= shift;
2902 | 7 | 3µs |  |  | $t->{twig_xmldecl}->{standalone}= shift;
2903 | 7 | 14µs |  |  | return;
2904 |  |  |  |  | }
2905 |  |  |  |  |
2906 |  |  |  |  | sub _twig_doctype
2907 |  |  |  |  | { # warn " in _twig_doctype...\n"; # DEBUG handler
2908 |  |  |  |  | my( $p, $name, $sysid, $pub, $internal)= @_;
2909 |  |  |  |  | my $t=$p->{twig};
2910 |  |  |  |  | $t->{twig_doctype}||= {}; # create
2911 |  |  |  |  | $t->{twig_doctype}->{name}= $name; # always there
2912 |  |  |  |  | $t->{twig_doctype}->{sysid}= $sysid; #
2913 |  |  |  |  | $t->{twig_doctype}->{pub}= $pub; #
2914 |  |  |  |  |
2915 |  |  |  |  | # now let's try to cope with XML::Parser 2.28 and above
2916 |  |  |  |  | if( $parser_version > 2.27)
2917 |  |  |  |  | { @saved_default_handler= $p->setHandlers( Default => \&_twig_store_internal_dtd,
2918 |  |  |  |  | Entity => \&_twig_entity,
2919 |  |  |  |  | );
2920 |  |  |  |  | $p->setHandlers( DoctypeFin => \&_twig_stop_storing_internal_dtd);
2921 |  |  |  |  | $t->{twig_doctype}->{internal}='';
2922 |  |  |  |  | }
2923 |  |  |  |  | else
2924 |  |  |  |  | { $internal||='';
2925 |  |  |  |  |
2926 |  |  |  |  | $internal=~ s{^\s*\[}{};
2927 |  |  |  |  | $internal=~ s{]\s*$}{};
2928 |  |  |  |  | $t->{twig_doctype}->{internal}=$internal;
2929 |  |  |  |  | }
2930 |  |  |  |  |
2931 |  |  |  |  | # now check if we want to get the DTD info
2932 |  |  |  |  | if( $t->{twig_read_external_dtd} && $sysid)
2933 |  |  |  |  | { # let's build a fake document with an internal DTD
2934 |  |  |  |  | if( $t->{DTDBase})
2935 |  |  |  |  | { _use( 'File::Spec');
2936 |  |  |  |  | $sysid=File::Spec->catfile($t->{DTDBase}, $sysid);
2937 |  |  |  |  | }
2938 |  |  |  |  | my $dtd= _slurp_uri( $sysid);
2939 |  |  |  |  | # if the DTD includes an XML declaration, it needs to be moved before the DOCTYPE bit
2940 |  |  |  |  | if( $dtd=~ s{^(\s*<\?xml(\s+\w+\s*=\s*("[^"]*"|'[^']*'))*\s*\?>)}{})
2941 |  |  |  |  | { $dtd= "$1<!DOCTYPE $name [$dtd]><$name/>"; }
2942 |  |  |  |  | else
2943 |  |  |  |  | { $dtd= "<!DOCTYPE $name [$dtd]><$name/>"; }
2944 |  |  |  |  |
2945 |  |  |  |  | $t->save_global_state(); # save the globals (they will be reset by the following new)
2946 |  |  |  |  | my $t_dtd= XML::Twig->new( load_DTD => 1, ParseParamEnt => 1, error_context => $t->{ErrorContext} || 0); # create a temp twig
2947 |  |  |  |  | $t_dtd->parse( $dtd); # parse it
2948 |  |  |  |  | $t->{twig_dtd}= $t_dtd->{twig_dtd}; # grab the dtd info
2949 |  |  |  |  | #$t->{twig_dtd_is_external}=1;
2950 |  |  |  |  | $t->entity_list->_add_list( $t_dtd->entity_list) if( $t_dtd->entity_list); # grab the entity info
2951 |  |  |  |  | $t->notation_list->_add_list( $t_dtd->notation_list) if( $t_dtd->notation_list); # grab the notation info
2952 |  |  |  |  | $t->restore_global_state();
2953 |  |  |  |  | }
2954 |  |  |  |  | return;
2955 |  |  |  |  | }
2956 |  |  |  |  |
2957 |  |  |  |  | sub _twig_element
2958 |  |  |  |  | { # warn " in _twig_element...\n"; # DEBUG handler
2959 |  |  |  |  |
2960 |  |  |  |  | my( $p, $name, $model)= @_;
2961 |  |  |  |  | my $t=$p->{twig};
2962 |  |  |  |  | $t->{twig_dtd}||= {}; # may create the dtd
2963 |  |  |  |  | $t->{twig_dtd}->{model}||= {}; # may create the model hash
2964 |  |  |  |  | $t->{twig_dtd}->{elt_list}||= []; # ordered list of elements
2965 |  |  |  |  | push @{$t->{twig_dtd}->{elt_list}}, $name; # store the elt
2966 |  |  |  |  | $t->{twig_dtd}->{model}->{$name}= $model; # store the model
2967 |  |  |  |  | if( ($parser_version > 2.27) && ($t->{twig_doctype}->{internal}=~ m{(^|>)\s*$}) )
2968 |  |  |  |  | { my $text= $XML::Twig::Elt::keep_encoding ? $p->original_string : $p->recognized_string;
2969 |  |  |  |  | unless( $text)
2970 |  |  |  |  | { # this version of XML::Parser does not return the text in the *_string method
2971 |  |  |  |  | # we need to rebuild it
2972 |  |  |  |  | $text= "<!ELEMENT $name $model>";
2973 |  |  |  |  | }
2974 |  |  |  |  | $t->{twig_doctype}->{internal} .= $text;
2975 |  |  |  |  | }
2976 |  |  |  |  | return;
2977 |  |  |  |  | }
2978 |  |  |  |  |
2979 |  |  |  |  | sub _twig_attlist
2980 |  |  |  |  | { # warn " in _twig_attlist...\n"; # DEBUG handler
2981 |  |  |  |  |
2982 |  |  |  |  | my( $p, $gi, $att, $type, $default, $fixed)= @_;
2983 |  |  |  |  | #warn "in attlist: gi: '$gi', att: '$att', type: '$type', default: '$default', fixed: '$fixed'\n";
2984 |  |  |  |  | my $t=$p->{twig};
2985 |  |  |  |  | $t->{twig_dtd}||= {}; # create dtd if need be
2986 |  |  |  |  | $t->{twig_dtd}->{$gi}||= {}; # create elt if need be
2987 |  |  |  |  | #$t->{twig_dtd}->{$gi}->{att}||= {}; # create att if need be
2988 |  |  |  |  | if( ($parser_version > 2.27) && ($t->{twig_doctype}->{internal}=~ m{(^|>)\s*$}) )
2989 |  |  |  |  | { my $text= $XML::Twig::Elt::keep_encoding ? $p->original_string : $p->recognized_string;
2990 |  |  |  |  | unless( $text)
2991 |  |  |  |  | { # this version of XML::Parser does not return the text in the *_string method
2992 |  |  |  |  | # we need to rebuild it
2993 |  |  |  |  | my $att_decl="$att $type";
2994 |  |  |  |  | $att_decl .= " #FIXED" if( $fixed);
2995 |  |  |  |  | $att_decl .= " $default" if( defined $default);
2996 |  |  |  |  | # 2 cases: there is already an attlist on that element or not
2997 |  |  |  |  | if( $t->{twig_dtd}->{att}->{$gi})
2998 |  |  |  |  | { # there is already an attlist, add to it
2999 |  |  |  |  | $t->{twig_doctype}->{internal}=~ s{(<!ATTLIST\s*$gi )(.*?)\n?>}
3000 |  |  |  |  | { "$1$2\n" . ' ' x length( $1) . "$att_decl\n>"}es;
3001 |  |  |  |  | }
3002 |  |  |  |  | else
3003 |  |  |  |  | { # create the attlist
3004 |  |  |  |  | $t->{twig_doctype}->{internal}.= "<!ATTLIST $gi $att_decl>"
3005 |  |  |  |  | }
3006 |  |  |  |  | }
3007 |  |  |  |  | }
3008 |  |  |  |  | $t->{twig_dtd}->{att}->{$gi}->{$att}= {} ;
3009 |  |  |  |  | $t->{twig_dtd}->{att}->{$gi}->{$att}->{type}= $type;
3010 |  |  |  |  | $t->{twig_dtd}->{att}->{$gi}->{$att}->{default}= $default if( defined $default);
3011 |  |  |  |  | $t->{twig_dtd}->{att}->{$gi}->{$att}->{fixed}= $fixed;
3012 |  |  |  |  | return;
3013 |  |  |  |  | }
3014 |  |  |  |  |
3015 |  |  |  |  | sub _twig_default
3016 |  |  |  |  | # spent 23µs (18+5) within XML::Twig::_twig_default which was called 6 times, avg 4µs/call: # 6 times (18µs+5µs) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 4µs/call { # warn " in _twig_default...\n"; # DEBUG handler
3017 |  |  |  |  |
3018 | 6 | 2µs |  |  | my( $p, $string)= @_;
3019 |  |  |  |  |
3020 | 6 | 1µs |  |  | my $t= $p->{twig};
3021 |  |  |  |  |
3022 |  |  |  |  | # we need to process the data in 2 cases: entity, or spaces after the closing tag
3023 |  |  |  |  |
3024 |  |  |  |  | # after the closing tag (no twig_current and root has been created)
3025 | 6 | 3µs |  |  | if( ! $t->{twig_current} && $t->{twig_root} && $string=~ m{^\s+$}m) { $t->{twig_stored_spaces} .= $string; }
3026 |  |  |  |  |
3027 |  |  |  |  | # process only if we have an entity
3028 | 6 | 19µs | 6 | 5µs | if( $string=~ m{^&([^;]*);$}) # spent 5µs making 6 calls to CORE::match, avg 867ns/call
3029 |  |  |  |  | { # the entity has to be pure pcdata, or we have a problem
3030 |  |  |  |  | if( ($p->original_string=~ m{^<}) && ($p->original_string=~ m{>$}) )
3031 |  |  |  |  | { # string is a tag, entity is in an attribute
3032 |  |  |  |  | $t->{twig_entities_in_attribute}=1 if( $t->{twig_do_not_escape_amp_in_atts});
3033 |  |  |  |  | }
3034 |  |  |  |  | else
3035 |  |  |  |  | { my $ent;
3036 |  |  |  |  | if( $t->{twig_keep_encoding})
3037 |  |  |  |  | { _twig_char( $p, $string);
3038 |  |  |  |  | $ent= substr( $string, 1, -1);
3039 |  |  |  |  | }
3040 |  |  |  |  | else
3041 |  |  |  |  | { $ent= _twig_insert_ent( $t, $string);
3042 |  |  |  |  | }
3043 |  |  |  |  |
3044 |  |  |  |  | return $ent;
3045 |  |  |  |  | }
3046 |  |  |  |  | }
3047 |  |  |  |  | }
3048 |  |  |  |  |
3049 |  |  |  |  | sub _twig_insert_ent
3050 |  |  |  |  | {
3051 |  |  |  |  | my( $t, $string)=@_;
3052 |  |  |  |  |
3053 |  |  |  |  | my $twig_current= $t->{twig_current};
3054 |  |  |  |  |
3055 |  |  |  |  | my $ent= $t->{twig_elt_class}->new( $ENT);
3056 |  |  |  |  | $ent->{ent}= $string;
3057 |  |  |  |  |
3058 |  |  |  |  | _add_or_discard_stored_spaces( $t);
3059 |  |  |  |  |
3060 |  |  |  |  | if( $t->{twig_in_pcdata})
3061 |  |  |  |  | { # create the node as a sibling of the #PCDATA
3062 |  |  |  |  |
3063 |  |  |  |  | $ent->{prev_sibling}=$twig_current; if( $XML::Twig::weakrefs) { weaken( $ent->{prev_sibling});} ;
3064 |  |  |  |  | $twig_current->{next_sibling}= $ent;
3065 |  |  |  |  | my $parent= $twig_current->{parent};
3066 |  |  |  |  | $ent->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $ent->{parent});} ;
3067 |  |  |  |  | delete $parent->{empty}; $parent->{last_child}=$ent; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ;
3068 |  |  |  |  | # the twig_current is now the parent
3069 |  |  |  |  | delete $twig_current->{'twig_current'};
3070 |  |  |  |  | $t->{twig_current}= $parent;
3071 |  |  |  |  | # we left pcdata
3072 |  |  |  |  | $t->{twig_in_pcdata}=0;
3073 |  |  |  |  | }
3074 |  |  |  |  | else
3075 |  |  |  |  | { # create the node as a child of the current element
3076 |  |  |  |  | $ent->{parent}=$twig_current; if( $XML::Twig::weakrefs) { weaken( $ent->{parent});} ;
3077 |  |  |  |  | if( my $prev_sibling= $twig_current->{last_child})
3078 |  |  |  |  | { $ent->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $ent->{prev_sibling});} ;
3079 |  |  |  |  | $prev_sibling->{next_sibling}= $ent;
3080 |  |  |  |  | }
3081 |  |  |  |  | else
3082 |  |  |  |  | { if( $twig_current) { $twig_current->{first_child}= $ent; } }
3083 |  |  |  |  | if( $twig_current) { delete $twig_current->{empty}; $twig_current->{last_child}=$ent; if( $XML::Twig::weakrefs) { weaken( $twig_current->{last_child});} ; }
3084 |  |  |  |  | }
3085 |  |  |  |  |
3086 |  |  |  |  | # meant to trigger entity handler, does not seem to be activated at this time
3087 |  |  |  |  | #if( my $handler= $t->{twig_handlers}->{gi}->{$ENT})
3088 |  |  |  |  | # { local $_= $ent; $handler->( $t, $ent); }
3089 |  |  |  |  |
3090 |  |  |  |  | return $ent;
3091 |  |  |  |  | }
3092 |  |  |  |  |
3093 |  |  |  |  | sub parser
3094 | 1858243 | 3.08s |  |  | # spent 524ms within XML::Twig::parser which was called 1858243 times, avg 282ns/call: # 1095679 times (254ms+0s) by XML::Twig::_ns_info at line 2217, avg 231ns/call # 398167 times (153ms+0s) by XML::Twig::_replace_ns at line 2162, avg 383ns/call # 364369 times (118ms+0s) by XML::Twig::_replace_prefix at line 2425, avg 325ns/call # 28 times (7µs+0s) by XML::Twig::_replace_ns at line 2163, avg 243ns/call { return $_[0]->{twig_parser}; }
3095 |  |  |  |  |
3096 |  |  |  |  | # returns the declaration text (or a default one)
3097 |  |  |  |  | sub xmldecl
3098 |  |  |  |  | { my $t= shift;
3099 |  |  |  |  | return '' unless( $t->{twig_xmldecl} || $t->{output_encoding});
3100 |  |  |  |  | my $decl_string;
3101 |  |  |  |  | my $decl= $t->{twig_xmldecl};
3102 |  |  |  |  | if( $decl)
3103 |  |  |  |  | { my $version= $decl->{version};
3104 |  |  |  |  | $decl_string= q{<?xml};
3105 |  |  |  |  | $decl_string .= qq{ version="$version"};
3106 |  |  |  |  |
3107 |  |  |  |  | # encoding can either have been set (in $decl->{output_encoding})
3108 |  |  |  |  | # or come from the document (in $decl->{encoding})
3109 |  |  |  |  | if( $t->{output_encoding})
3110 |  |  |  |  | { my $encoding= $t->{output_encoding};
3111 |  |  |  |  | $decl_string .= qq{ encoding="$encoding"};
3112 |  |  |  |  | }
3113 |  |  |  |  | elsif( $decl->{encoding})
3114 |  |  |  |  | { my $encoding= $decl->{encoding};
3115 |  |  |  |  | $decl_string .= qq{ encoding="$encoding"};
3116 |  |  |  |  | }
3117 |  |  |  |  |
3118 |  |  |  |  | if( defined( $decl->{standalone}))
3119 |  |  |  |  | { $decl_string .= q{ standalone="};
3120 |  |  |  |  | $decl_string .= $decl->{standalone} ? "yes" : "no";
3121 |  |  |  |  | $decl_string .= q{"};
3122 |  |  |  |  | }
3123 |  |  |  |  |
3124 |  |  |  |  | $decl_string .= "?>\n";
3125 |  |  |  |  | }
3126 |  |  |  |  | else
3127 |  |  |  |  | { my $encoding= $t->{output_encoding};
3128 |  |  |  |  | $decl_string= qq{<?xml version="1.0" encoding="$encoding"?>};
3129 |  |  |  |  | }
3130 |  |  |  |  |
3131 |  |  |  |  | my $output_filter= XML::Twig::Elt::output_filter();
3132 |  |  |  |  | return $output_filter ? $output_filter->( $decl_string) : $decl_string;
3133 |  |  |  |  | }
3134 |  |  |  |  |
3135 |  |  |  |  | sub set_doctype
3136 |  |  |  |  | { my( $t, $name, $system, $public, $internal)= @_;
3137 |  |  |  |  | $t->{twig_doctype}= {} unless defined $t->{twig_doctype};
3138 |  |  |  |  | my $doctype= $t->{twig_doctype};
3139 |  |  |  |  | $doctype->{name} = $name if( defined $name);
3140 |  |  |  |  | $doctype->{sysid} = $system if( defined $system);
3141 |  |  |  |  | $doctype->{pub} = $public if( defined $public);
3142 |  |  |  |  | $doctype->{internal} = $internal if( defined $internal);
3143 |  |  |  |  | }
3144 |  |  |  |  |
3145 |  |  |  |  | sub doctype_name
3146 |  |  |  |  | { my $t= shift;
3147 |  |  |  |  | my $doctype= $t->{twig_doctype} or return '';
3148 |  |  |  |  | return $doctype->{name} || '';
3149 |  |  |  |  | }
3150 |  |  |  |  |
3151 |  |  |  |  | sub system_id
3152 |  |  |  |  | { my $t= shift;
3153 |  |  |  |  | my $doctype= $t->{twig_doctype} or return '';
3154 |  |  |  |  | return $doctype->{sysid} || '';
3155 |  |  |  |  | }
3156 |  |  |  |  |
3157 |  |  |  |  | sub public_id
3158 |  |  |  |  | { my $t= shift;
3159 |  |  |  |  | my $doctype= $t->{twig_doctype} or return '';
3160 |  |  |  |  | return $doctype->{pub} || '';
3161 |  |  |  |  | }
3162 |  |  |  |  |
3163 |  |  |  |  | sub internal_subset
3164 |  |  |  |  | { my $t= shift;
3165 |  |  |  |  | my $doctype= $t->{twig_doctype} or return '';
3166 |  |  |  |  | return $doctype->{internal} || '';
3167 |  |  |  |  | }
3168 |  |  |  |  |
3169 |  |  |  |  | # return the dtd object
3170 |  |  |  |  | sub dtd
3171 |  |  |  |  | { my $t= shift;
3172 |  |  |  |  | return $t->{twig_dtd};
3173 |  |  |  |  | }
3174 |  |  |  |  |
3175 |  |  |  |  | # return an element model, or the list of element models
3176 |  |  |  |  | sub model
3177 |  |  |  |  | { my $t= shift;
3178 |  |  |  |  | my $elt= shift;
3179 |  |  |  |  | return $t->dtd->{model}->{$elt} if( $elt);
3180 |  |  |  |  | return (sort keys %{$t->dtd->{model}});
3181 |  |  |  |  | }
3182 |  |  |  |  |
3183 |  |  |  |  |
3184 |  |  |  |  | # return the entity_list object
3185 |  |  |  |  | sub entity_list
3186 |  |  |  |  | { my $t= shift;
3187 |  |  |  |  | return $t->{twig_entity_list};
3188 |  |  |  |  | }
3189 |  |  |  |  |
3190 |  |  |  |  | # return the list of entity names
3191 |  |  |  |  | sub entity_names
3192 |  |  |  |  | { my $t= shift;
3193 |  |  |  |  | return $t->entity_list->entity_names;
3194 |  |  |  |  | }
3195 |  |  |  |  |
3196 |  |  |  |  | # return the entity object
3197 |  |  |  |  | sub entity
3198 |  |  |  |  | { my $t= shift;
3199 |  |  |  |  | my $entity_name= shift;
3200 |  |  |  |  | return $t->entity_list->ent( $entity_name);
3201 |  |  |  |  | }
3202 |  |  |  |  |
3203 |  |  |  |  | # return the notation_list object
3204 |  |  |  |  | sub notation_list
3205 |  |  |  |  | { my $t= shift;
3206 |  |  |  |  | return $t->{twig_notation_list};
3207 |  |  |  |  | }
3208 |  |  |  |  |
3209 |  |  |  |  | # return the list of notation names
3210 |  |  |  |  | sub notation_names
3211 |  |  |  |  | { my $t= shift;
3212 |  |  |  |  | return $t->notation_list->notation_names;
3213 |  |  |  |  | }
3214 |  |  |  |  |
3215 |  |  |  |  | # return the notation object
3216 |  |  |  |  | sub notation
3217 |  |  |  |  | { my $t= shift;
3218 |  |  |  |  | my $notation_name= shift;
3219 |  |  |  |  | return $t->notation_list->notation( $notation_name);
3220 |  |  |  |  | }
3221 |  |  |  |  |
- - |  |  |  |  |
3225 |  |  |  |  | sub print_prolog
3226 |  |  |  |  | { my $t= shift;
3227 |  |  |  |  | my $fh= isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar') ? shift : $t->{twig_output_fh} || select() || \*STDOUT;
3228 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
3229 | 2 | 1.38ms | 2 | 16µs | # spent 12µs (8+4) within XML::Twig::BEGIN@3229 which was called: # once (8µs+4µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 3229 no strict 'refs'; # spent 12µs making 1 call to XML::Twig::BEGIN@3229 # spent 4µs making 1 call to strict::unimport
3230 |  |  |  |  | print {$fh} $t->prolog( @_);
3231 |  |  |  |  | }
3232 |  |  |  |  |
3233 |  |  |  |  | sub prolog
3234 |  |  |  |  | { my $t= shift;
3235 |  |  |  |  | if( $t->{no_prolog}){ return ''; }
3236 |  |  |  |  |
3237 |  |  |  |  | return $t->{no_prolog} ? ''
3238 |  |  |  |  | : defined $t->{no_dtd_output} ? $t->xmldecl
3239 |  |  |  |  | : $t->xmldecl . $t->doctype( @_);
3240 |  |  |  |  | }
3241 |  |  |  |  |
3242 |  |  |  |  | sub doctype
3243 |  |  |  |  | { my $t= shift;
3244 |  |  |  |  | my %args= _normalize_args( @_);
3245 |  |  |  |  | my $update_dtd = $args{UpdateDTD} || '';
3246 |  |  |  |  | my $doctype_text='';
3247 |  |  |  |  |
3248 |  |  |  |  | my $doctype= $t->{twig_doctype};
3249 |  |  |  |  |
3250 |  |  |  |  | if( $doctype)
3251 |  |  |  |  | { $doctype_text .= qq{<!DOCTYPE $doctype->{name}} if( $doctype->{name});
3252 |  |  |  |  | $doctype_text .= qq{ PUBLIC "$doctype->{pub}"} if( $doctype->{pub});
3253 |  |  |  |  | $doctype_text .= qq{ SYSTEM} if( $doctype->{sysid} && !$doctype->{pub});
3254 |  |  |  |  | $doctype_text .= qq{ "$doctype->{sysid}"} if( $doctype->{sysid});
3255 |  |  |  |  | }
3256 |  |  |  |  |
3257 |  |  |  |  | if( $update_dtd)
3258 |  |  |  |  | { if( $doctype)
3259 |  |  |  |  | { my $internal=$doctype->{internal};
3260 |  |  |  |  | # awful hack, but at least it works a little better that what was there before
3261 |  |  |  |  | if( $internal)
3262 |  |  |  |  | { # remove entity and notation declarations (they will be re-generated from the updated entity list)
3263 |  |  |  |  | $internal=~ s{<! \s* ENTITY \s+ $REG_TAG_NAME \s+ ( ("[^"]*"|'[^']*') \s* | SYSTEM [^>]*) >\s*}{}xg;
3264 |  |  |  |  | $internal=~ s{<! \s* NOTATION .*? >\s*}{}sxg;
3265 |  |  |  |  | $internal=~ s{^\n}{};
3266 |  |  |  |  | }
3267 |  |  |  |  | $internal .= $t->entity_list->text ||'' if( $t->entity_list);
3268 |  |  |  |  | $internal .= $t->notation_list->text ||'' if( $t->notation_list);
3269 |  |  |  |  | if( $internal) { $doctype_text .= "[\n$internal]>\n"; }
3270 |  |  |  |  | }
3271 |  |  |  |  | elsif( !$t->{'twig_dtd'} && ( keys %{$t->entity_list} || keys %{$t->notation_list} ) )
3272 |  |  |  |  | { $doctype_text .= "<!DOCTYPE " . $t->root->gi . " [\n" . $t->entity_list->text . $t->notation_list->text . "\n]>";}
3273 |  |  |  |  | else
3274 |  |  |  |  | { $doctype_text= $t->{twig_dtd};
3275 |  |  |  |  | $doctype_text .= $t->dtd_text;
3276 |  |  |  |  | }
3277 |  |  |  |  | }
3278 |  |  |  |  | elsif( $doctype)
3279 |  |  |  |  | { if( my $internal= $doctype->{internal})
3280 |  |  |  |  | { # add opening and closing brackets if not already there
3281 |  |  |  |  | # plus some spaces and newlines for a nice formating
3282 |  |  |  |  | # I test it here because I can't remember which version of
3283 |  |  |  |  | # XML::Parser need it or not, nor guess which one will in the
3284 |  |  |  |  | # future, so this about the best I can do
3285 |  |  |  |  | $internal=~ s{^\s*(\[\s*)?}{ [\n};
3286 |  |  |  |  | $internal=~ s{\s*(\]\s*(>\s*)?)?\s*$}{\n]>\n};
3287 |  |  |  |  |
3288 |  |  |  |  | # XML::Parser does not include the NOTATION declarations in the DTD
3289 |  |  |  |  | # at least in the current version. So put them back
3290 |  |  |  |  | #if( $t->notation_list && $internal !~ m{<!\s*NOTATION})
3291 |  |  |  |  | # { $internal=~ s{(\n]>\n)$}{ "\n" . $t->notation_list->text . $1}es; }
3292 |  |  |  |  |
3293 |  |  |  |  | $doctype_text .= $internal;
3294 |  |  |  |  | }
3295 |  |  |  |  | }
3296 |  |  |  |  |
3297 |  |  |  |  | if( $doctype_text)
3298 |  |  |  |  | {
3299 |  |  |  |  | # terrible hack, as I can't figure out in which case the darn prolog
3300 |  |  |  |  | # should get an extra > (depends on XML::Parser and expat versions)
3301 |  |  |  |  | $doctype_text=~ s/(>\s*)*$/>\n/; # if($doctype_text);
3302 |  |  |  |  |
3303 |  |  |  |  | my $output_filter= XML::Twig::Elt::output_filter();
3304 |  |  |  |  | return $output_filter ? $output_filter->( $doctype_text) : $doctype_text;
3305 |  |  |  |  | }
3306 |  |  |  |  | else
3307 |  |  |  |  | { return $doctype_text; }
3308 |  |  |  |  | }
3309 |  |  |  |  |
3310 |  |  |  |  | sub _leading_cpi
3311 |  |  |  |  | { my $t= shift;
3312 |  |  |  |  | my $leading_cpi= $t->{leading_cpi} || return '';
3313 |  |  |  |  | return $leading_cpi->sprint( 1);
3314 |  |  |  |  | }
3315 |  |  |  |  |
3316 |  |  |  |  | sub _trailing_cpi
3317 |  |  |  |  | { my $t= shift;
3318 |  |  |  |  | my $trailing_cpi= $t->{trailing_cpi} || return '';
3319 |  |  |  |  | return $trailing_cpi->sprint( 1);
3320 |  |  |  |  | }
3321 |  |  |  |  |
3322 |  |  |  |  | sub _trailing_cpi_text
3323 |  |  |  |  | { my $t= shift;
3324 |  |  |  |  | return $t->{trailing_cpi_text} || '';
3325 |  |  |  |  | }
3326 |  |  |  |  |
3327 |  |  |  |  | sub print_to_file
3328 |  |  |  |  | { my( $t, $filename)= (shift, shift);
3329 |  |  |  |  | my $out_fh;
3330 |  |  |  |  | # open( $out_fh, ">$filename") or _croak( "cannot create file $filename: $!"); # < perl 5.8
3331 |  |  |  |  | my $mode= $t->{twig_keep_encoding} && ! _use_perlio() ? '>' : '>:utf8'; # >= perl 5.8
3332 |  |  |  |  | open( $out_fh, $mode, $filename) or _croak( "cannot create file $filename: $!"); # >= perl 5.8
3333 |  |  |  |  | $t->print( $out_fh, @_);
3334 |  |  |  |  | close $out_fh;
3335 |  |  |  |  | return $t;
3336 |  |  |  |  | }
3337 |  |  |  |  |
3338 |  |  |  |  | # probably only works on *nix (at least the chmod bit)
3339 |  |  |  |  | # first print to a temporary file, then rename that file to the desired file name, then change permissions
3340 |  |  |  |  | # to the original file permissions (or to the current umask)
3341 |  |  |  |  | sub safe_print_to_file
3342 |  |  |  |  | { my( $t, $filename)= (shift, shift);
3343 |  |  |  |  | my $perm= -f $filename ? (stat $filename)[2] & 07777 : ~umask() ;
3344 |  |  |  |  | XML::Twig::_use( 'File::Temp') || croak "need File::Temp to use safe_print_to_file\n";
3345 |  |  |  |  | my $tmpdir= dirname( $filename);
3346 |  |  |  |  | my( $fh, $tmpfilename) = File::Temp::tempfile( DIR => $tmpdir);
3347 |  |  |  |  | $t->print_to_file( $tmpfilename, @_);
3348 |  |  |  |  | rename( $tmpfilename, $filename) or unlink $tmpfilename && _croak( "cannot move temporary file to $filename: $!");
3349 |  |  |  |  | chmod $perm, $filename;
3350 |  |  |  |  | return $t;
3351 |  |  |  |  | }
3352 |  |  |  |  |
3353 |  |  |  |  |
3354 |  |  |  |  | sub print
3355 |  |  |  |  | { my $t= shift;
3356 |  |  |  |  | my $fh= isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar') ? shift : undef;
3357 |  |  |  |  | my %args= _normalize_args( @_);
3358 |  |  |  |  |
3359 |  |  |  |  | my $old_select = defined $fh ? select $fh : undef;
3360 |  |  |  |  | my $old_pretty = defined ($args{PrettyPrint}) ? $t->set_pretty_print( $args{PrettyPrint}) : undef;
3361 |  |  |  |  | my $old_empty_tag = defined ($args{EmptyTags}) ? $t->set_empty_tag_style( $args{EmptyTags}) : undef;
3362 |  |  |  |  |
3363 |  |  |  |  | #if( !$t->{encoding} || lc( $t->{encoding}) eq 'utf-8') { my $out= $fh || \*STDOUT; binmode $out, ':utf8'; }
3364 |  |  |  |  |
3365 |  |  |  |  | if( $perl_version > 5.006 && ! $t->{twig_keep_encoding} && _use_perlio() ) { binmode( $fh || \*STDOUT, ":utf8" ); }
3366 |  |  |  |  |
3367 |  |  |  |  | print $t->prolog( %args) . $t->_leading_cpi( %args);
3368 |  |  |  |  | $t->{twig_root}->print;
3369 |  |  |  |  | print $t->_trailing_cpi # trailing comments and pi's (elements, in 'process' mode)
3370 |  |  |  |  | . $t->_trailing_cpi_text # trailing comments and pi's (in 'keep' mode)
3371 |  |  |  |  | . ( ($t->{twig_keep_spaces}||'') && ($t->{trailing_spaces} || ''))
3372 |  |  |  |  | ;
3373 |  |  |  |  |
3374 |  |  |  |  |
3375 |  |  |  |  | $t->set_pretty_print( $old_pretty) if( defined $old_pretty);
3376 |  |  |  |  | $t->set_empty_tag_style( $old_empty_tag) if( defined $old_empty_tag);
3377 |  |  |  |  | if( $fh) { select $old_select; }
3378 |  |  |  |  |
3379 |  |  |  |  | return $t;
3380 |  |  |  |  | }
3381 |  |  |  |  |
3382 |  |  |  |  |
3383 |  |  |  |  | sub flush
3384 |  |  |  |  | { my $t= shift;
3385 |  |  |  |  |
3386 |  |  |  |  | $t->_trigger_tdh if $t->{twig_tdh};
3387 |  |  |  |  |
3388 |  |  |  |  | return if( $t->{twig_completely_flushed});
3389 |  |  |  |  |
3390 |  |  |  |  | my $fh= isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar') ? shift : undef;
3391 |  |  |  |  | my $old_select= defined $fh ? select $fh : undef;
3392 |  |  |  |  | my $up_to= ref $_[0] ? shift : undef;
3393 |  |  |  |  | my %args= _normalize_args( @_);
3394 |  |  |  |  |
3395 |  |  |  |  | my $old_pretty;
3396 |  |  |  |  | if( defined $args{PrettyPrint})
3397 |  |  |  |  | { $old_pretty= $t->set_pretty_print( $args{PrettyPrint});
3398 |  |  |  |  | delete $args{PrettyPrint};
3399 |  |  |  |  | }
3400 |  |  |  |  |
3401 |  |  |  |  | my $old_empty_tag_style;
3402 |  |  |  |  | if( $args{EmptyTags})
3403 |  |  |  |  | { $old_empty_tag_style= $t->set_empty_tag_style( $args{EmptyTags});
3404 |  |  |  |  | delete $args{EmptyTags};
3405 |  |  |  |  | }
3406 |  |  |  |  |
3407 |  |  |  |  |
3408 |  |  |  |  | # the "real" last element processed, as _twig_end has closed it
3409 |  |  |  |  | my $last_elt;
3410 |  |  |  |  | my $flush_trailing_data=0;
3411 |  |  |  |  | if( $up_to)
3412 |  |  |  |  | { $last_elt= $up_to; }
3413 |  |  |  |  | elsif( $t->{twig_current})
3414 |  |  |  |  | { $last_elt= $t->{twig_current}->{last_child}; }
3415 |  |  |  |  | else
3416 |  |  |  |  | { $last_elt= $t->{twig_root};
3417 |  |  |  |  | $flush_trailing_data=1;
3418 |  |  |  |  | $t->{twig_completely_flushed}=1;
3419 |  |  |  |  | }
3420 |  |  |  |  |
3421 |  |  |  |  | # flush the DTD unless it has ready flushed (ie root has been flushed)
3422 |  |  |  |  | my $elt= $t->{twig_root};
3423 |  |  |  |  | unless( $elt->{'flushed'})
3424 |  |  |  |  | { # store flush info so we can auto-flush later
3425 |  |  |  |  | if( $t->{twig_autoflush})
3426 |  |  |  |  | { $t->{twig_autoflush_data}={};
3427 |  |  |  |  | $t->{twig_autoflush_data}->{fh} = $fh if( $fh);
3428 |  |  |  |  | $t->{twig_autoflush_data}->{args} = \@_ if( @_);
3429 |  |  |  |  | }
3430 |  |  |  |  | $t->print_prolog( %args);
3431 |  |  |  |  | print $t->_leading_cpi;
3432 |  |  |  |  | }
3433 |  |  |  |  |
3434 |  |  |  |  | while( $elt)
3435 |  |  |  |  | { my $next_elt;
3436 |  |  |  |  | if( $last_elt && $last_elt->in( $elt))
3437 |  |  |  |  | {
3438 |  |  |  |  | unless( $elt->{'flushed'})
3439 |  |  |  |  | { # just output the front tag
3440 |  |  |  |  | print $elt->start_tag();
3441 |  |  |  |  | $elt->{'flushed'}=1;
3442 |  |  |  |  | }
3443 |  |  |  |  | $next_elt= $elt->{first_child};
3444 |  |  |  |  | }
3445 |  |  |  |  | else
3446 |  |  |  |  | { # an element before the last one or the last one,
3447 |  |  |  |  | $next_elt= $elt->{next_sibling};
3448 |  |  |  |  | $elt->_flush();
3449 |  |  |  |  | $elt->delete;
3450 |  |  |  |  | last if( $last_elt && ($elt == $last_elt));
3451 |  |  |  |  | }
3452 |  |  |  |  | $elt= $next_elt;
3453 |  |  |  |  | }
3454 |  |  |  |  |
3455 |  |  |  |  | if( $flush_trailing_data)
3456 |  |  |  |  | { print $t->_trailing_cpi # trailing comments and pi's (elements, in 'process' mode)
3457 |  |  |  |  | , $t->_trailing_cpi_text # trailing comments and pi's (in 'keep' mode)
3458 |  |  |  |  | }
3459 |  |  |  |  |
3460 |  |  |  |  | select $old_select if( defined $old_select);
3461 |  |  |  |  | $t->set_pretty_print( $old_pretty) if( defined $old_pretty);
3462 |  |  |  |  | $t->set_empty_tag_style( $old_empty_tag_style) if( defined $old_empty_tag_style);
3463 |  |  |  |  |
3464 |  |  |  |  | if( my $ids= $t->{twig_id_list})
3465 |  |  |  |  | { while( my ($id, $elt)= each %$ids)
3466 |  |  |  |  | { if( ! defined $elt)
3467 |  |  |  |  | { delete $t->{twig_id_list}->{$id} }
3468 |  |  |  |  | }
3469 |  |  |  |  | }
3470 |  |  |  |  |
3471 |  |  |  |  | return $t;
3472 |  |  |  |  | }
3473 |  |  |  |  |
3474 |  |  |  |  |
3475 |  |  |  |  | # flushes up to an element
3476 |  |  |  |  | # this method just reorders the arguments and calls flush
3477 |  |  |  |  | sub flush_up_to
3478 |  |  |  |  | { my $t= shift;
3479 |  |  |  |  | my $up_to= shift;
3480 |  |  |  |  | if( isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar'))
3481 |  |  |  |  | { my $fh= shift;
3482 |  |  |  |  | $t->flush( $fh, $up_to, @_);
3483 |  |  |  |  | }
3484 |  |  |  |  | else
3485 |  |  |  |  | { $t->flush( $up_to, @_); }
3486 |  |  |  |  |
3487 |  |  |  |  | return $t;
3488 |  |  |  |  | }
3489 |  |  |  |  |
3490 |  |  |  |  |
3491 |  |  |  |  | # same as print except the entire document text is returned as a string
3492 |  |  |  |  | sub sprint
3493 |  |  |  |  | { my $t= shift;
3494 |  |  |  |  | my %args= _normalize_args( @_);
3495 |  |  |  |  |
3496 |  |  |  |  | my $old_pretty;
3497 |  |  |  |  | if( defined $args{PrettyPrint})
3498 |  |  |  |  | { $old_pretty= $t->set_pretty_print( $args{PrettyPrint});
3499 |  |  |  |  | delete $args{PrettyPrint};
3500 |  |  |  |  | }
3501 |  |  |  |  |
3502 |  |  |  |  | my $old_empty_tag_style;
3503 |  |  |  |  | if( defined $args{EmptyTags})
3504 |  |  |  |  | { $old_empty_tag_style= $t->set_empty_tag_style( $args{EmptyTags});
3505 |  |  |  |  | delete $args{EmptyTags};
3506 |  |  |  |  | }
3507 |  |  |  |  |
3508 |  |  |  |  | my $string= $t->prolog( %args) # xml declaration and doctype
3509 |  |  |  |  | . $t->_leading_cpi( %args) # leading comments and pi's in 'process' mode
3510 |  |  |  |  | . ( ($t->{twig_root} && $t->{twig_root}->sprint) || '')
3511 |  |  |  |  | . $t->_trailing_cpi # trailing comments and pi's (elements, in 'process' mode)
3512 |  |  |  |  | . $t->_trailing_cpi_text # trailing comments and pi's (in 'keep' mode)
3513 |  |  |  |  | ;
3514 |  |  |  |  | if( $t->{twig_keep_spaces} && $t->{trailing_spaces}) { $string .= $t->{trailing_spaces}; }
3515 |  |  |  |  |
3516 |  |  |  |  | $t->set_pretty_print( $old_pretty) if( defined $old_pretty);
3517 |  |  |  |  | $t->set_empty_tag_style( $old_empty_tag_style) if( defined $old_empty_tag_style);
3518 |  |  |  |  |
3519 |  |  |  |  | return $string;
3520 |  |  |  |  | }
3521 |  |  |  |  |
3522 |  |  |  |  |
3523 |  |  |  |  | # this method discards useless elements in a tree
3524 |  |  |  |  | # it does the same thing as a flush except it does not print it
3525 |  |  |  |  | # the second argument is an element, the last purged element
3526 |  |  |  |  | # (this argument is usually set through the purge_up_to method)
3527 |  |  |  |  | sub purge
3528 | 33807 | 5.05ms |  |  | # spent 1.17s (317ms+856ms) within XML::Twig::purge which was called 33807 times, avg 35µs/call: # 18180 times (155ms+413ms) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:302] at line 301 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 31µs/call # 15608 times (162ms+442ms) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 441 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 39µs/call # 15 times (98µs+269µs) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:655] at line 654 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 24µs/call # once (11µs+24µs) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:246] at line 245 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (7µs+18µs) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:338] at line 337 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (6µs+17µs) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:268] at line 267 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (6µs+16µs) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:313] at line 312 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm { my $t= shift;
3529 | 33807 | 4.81ms |  |  | my $up_to= shift;
3530 |  |  |  |  |
3531 | 33807 | 5.61ms |  |  | $t->_trigger_tdh if $t->{twig_tdh};
3532 |  |  |  |  |
3533 |  |  |  |  | # the "real" last element processed, as _twig_end has closed it
3534 | 33807 | 2.60ms |  |  | my $last_elt;
3535 | 33807 | 12.8ms |  |  | if( $up_to)
3536 |  |  |  |  | { $last_elt= $up_to; }
3537 |  |  |  |  | elsif( $t->{twig_current})
3538 |  |  |  |  | { $last_elt= $t->{twig_current}->{last_child}; }
3539 |  |  |  |  | else
3540 |  |  |  |  | { $last_elt= $t->{twig_root}; }
3541 |  |  |  |  |
3542 | 33807 | 7.10ms |  |  | my $elt= $t->{twig_root};
3543 |  |  |  |  |
3544 | 33807 | 4.96ms |  |  | while( $elt)
3545 | 67614 | 4.31ms |  |  | { my $next_elt;
3546 | 67614 | 40.3ms | 67614 | 203ms | if( $last_elt && $last_elt->in( $elt)) # spent 203ms making 67614 calls to XML::Twig::Elt::in, avg 3µs/call
3547 | 33807 | 6.99ms |  |  | { $elt->{'flushed'}=1;
3548 | 33807 | 5.93ms |  |  | $next_elt= $elt->{first_child};
3549 |  |  |  |  | }
3550 |  |  |  |  | else
3551 |  |  |  |  | { # an element before the last one or the last one,
3552 | 33807 | 5.80ms |  |  | $next_elt= $elt->{next_sibling};
3553 | 33807 | 19.3ms | 33807 | 653ms | $elt->delete; # spent 653ms making 33807 calls to XML::Twig::Elt::delete, avg 19µs/call
3554 | 33807 | 21.4ms |  |  | last if( $last_elt && ($elt == $last_elt) );
3555 |  |  |  |  | }
3556 | 33807 | 9.37ms |  |  | $elt= $next_elt;
3557 |  |  |  |  | }
3558 |  |  |  |  |
3559 | 33807 | 7.80ms |  |  | if( my $ids= $t->{twig_id_list})
3560 |  |  |  |  | { while( my ($id, $elt)= each %$ids) { if( ! defined $elt) { delete $t->{twig_id_list}->{$id} } } }
3561 |  |  |  |  |
3562 | 33807 | 67.6ms |  |  | return $t;
3563 |  |  |  |  | }
3564 |  |  |  |  |
3565 |  |  |  |  | # flushes up to an element. This method just calls purge
3566 |  |  |  |  | sub purge_up_to
3567 |  |  |  |  | { my $t= shift;
3568 |  |  |  |  | return $t->purge( @_);
3569 |  |  |  |  | }
3570 |  |  |  |  |
3571 |  |  |  |  | sub root
3572 | 34 | 39µs |  |  | # spent 20µs within XML::Twig::root which was called 34 times, avg 582ns/call: # 16 times (10µs+0s) by XML::Twig::get_xpath at line 3691, avg 625ns/call # 16 times (8µs+0s) by XML::Twig::descendants at line 3758, avg 494ns/call # once (1µs+0s) by XML::Twig::_twig_end_check_roots at line 4217 # once (700ns+0s) by XML::Twig::_twig_start_check_roots at line 4163 { return $_[0]->{twig_root}; }
3573 |  |  |  |  |
3574 |  |  |  |  | sub normalize
3575 |  |  |  |  | { return $_[0]->root->normalize; }
3576 |  |  |  |  |
3577 |  |  |  |  |
3578 |  |  |  |  | # create accessor methods on attribute names
3579 | 1 | 0s |  |  | { my %accessor; # memorize accessor names so re-creating them won't trigger an error
3580 |  |  |  |  | sub att_accessors
3581 |  |  |  |  | {
3582 |  |  |  |  | my $twig_or_class= shift;
3583 |  |  |  |  | my $elt_class= ref $twig_or_class ? $twig_or_class->{twig_elt_class}
3584 |  |  |  |  | : 'XML::Twig::Elt'
3585 |  |  |  |  | ;
3586 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
3587 | 2 | 169µs | 2 | 15µs | # spent 11µs (7+4) within XML::Twig::BEGIN@3587 which was called: # once (7µs+4µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 3587 no strict 'refs'; # spent 11µs making 1 call to XML::Twig::BEGIN@3587 # spent 4µs making 1 call to strict::unimport
3588 |  |  |  |  | foreach my $att (@_)
3589 |  |  |  |  | { _croak( "attempt to redefine existing method $att using att_accessors")
3590 |  |  |  |  | if( $elt_class->can( $att) && !$accessor{$att});
3591 |  |  |  |  |
3592 |  |  |  |  | if( !$accessor{$att})
3593 |  |  |  |  | { *{"$elt_class\::$att"}=
3594 |  |  |  |  | sub
3595 |  |  |  |  | :lvalue # > perl 5.5
3596 |  |  |  |  | { my $elt= shift;
3597 |  |  |  |  | if( @_) { $elt->{att}->{$att}= $_[0]; }
3598 |  |  |  |  | $elt->{att}->{$att};
3599 |  |  |  |  | };
3600 |  |  |  |  | $accessor{$att}=1;
3601 |  |  |  |  | }
3602 |  |  |  |  | }
3603 |  |  |  |  | return $twig_or_class;
3604 |  |  |  |  | }
3605 |  |  |  |  | }
3606 |  |  |  |  |
3607 | 2 | 300ns |  |  | { my %accessor; # memorize accessor names so re-creating them won't trigger an error
3608 |  |  |  |  | sub elt_accessors
3609 |  |  |  |  | {
3610 |  |  |  |  | my $twig_or_class= shift;
3611 |  |  |  |  | my $elt_class= ref $twig_or_class ? $twig_or_class->{twig_elt_class}
3612 |  |  |  |  | : 'XML::Twig::Elt'
3613 |  |  |  |  | ;
3614 |  |  |  |  |
3615 |  |  |  |  | # if arg is a hash ref, it's exp => name, otherwise it's a list of tags
3616 |  |  |  |  | my %exp_to_alias= ref( $_[0]) && isa( $_[0], 'HASH') ? %{$_[0]}
3617 |  |  |  |  | : map { $_ => $_ } @_;
3618 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
3619 | 2 | 159µs | 2 | 12µs | # spent 9µs (6+4) within XML::Twig::BEGIN@3619 which was called: # once (6µs+4µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 3619 no strict 'refs'; # spent 9µs making 1 call to XML::Twig::BEGIN@3619 # spent 4µs making 1 call to strict::unimport
3620 |  |  |  |  | while( my( $alias, $exp)= each %exp_to_alias )
3621 |  |  |  |  | { if( $elt_class->can( $alias) && !$accessor{$alias})
3622 |  |  |  |  | { _croak( "attempt to redefine existing method $alias using elt_accessors"); }
3623 |  |  |  |  |
3624 |  |  |  |  | if( !$accessor{$alias})
3625 |  |  |  |  | { *{"$elt_class\::$alias"}=
3626 |  |  |  |  | sub
3627 |  |  |  |  | { my $elt= shift;
3628 |  |  |  |  | return wantarray ? $elt->children( $exp) : $elt->first_child( $exp);
3629 |  |  |  |  | };
3630 |  |  |  |  | $accessor{$alias}=1;
3631 |  |  |  |  | }
3632 |  |  |  |  | }
3633 |  |  |  |  | return $twig_or_class;
3634 |  |  |  |  | }
3635 |  |  |  |  | }
3636 |  |  |  |  |
3637 | 2 | 300ns |  |  | { my %accessor; # memorize accessor names so re-creating them won't trigger an error
3638 |  |  |  |  | sub field_accessors
3639 |  |  |  |  | {
3640 |  |  |  |  | my $twig_or_class= shift;
3641 |  |  |  |  | my $elt_class= ref $twig_or_class ? $twig_or_class->{twig_elt_class}
3642 |  |  |  |  | : 'XML::Twig::Elt'
3643 |  |  |  |  | ;
3644 |  |  |  |  | my %exp_to_alias= ref( $_[0]) && isa( $_[0], 'HASH') ? %{$_[0]}
3645 |  |  |  |  | : map { $_ => $_ } @_;
3646 |  |  |  |  |
3647 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
3648 | 2 | 944µs | 2 | 12µs | # spent 9µs (6+3) within XML::Twig::BEGIN@3648 which was called: # once (6µs+3µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 3648 no strict 'refs'; # spent 9µs making 1 call to XML::Twig::BEGIN@3648 # spent 3µs making 1 call to strict::unimport
3649 |  |  |  |  | while( my( $alias, $exp)= each %exp_to_alias )
3650 |  |  |  |  | { if( $elt_class->can( $alias) && !$accessor{$alias})
3651 |  |  |  |  | { _croak( "attempt to redefine existing method $exp using field_accessors"); }
3652 |  |  |  |  | if( !$accessor{$alias})
3653 |  |  |  |  | { *{"$elt_class\::$alias"}=
3654 |  |  |  |  | sub
3655 |  |  |  |  | { my $elt= shift;
3656 |  |  |  |  | $elt->field( $exp)
3657 |  |  |  |  | };
3658 |  |  |  |  | $accessor{$alias}=1;
3659 |  |  |  |  | }
3660 |  |  |  |  | }
3661 |  |  |  |  | return $twig_or_class;
3662 |  |  |  |  | }
3663 |  |  |  |  | }
3664 |  |  |  |  |
3665 |  |  |  |  | sub first_elt
3666 | 1 | 100ns |  |  | { my( $t, $cond)= @_;
3667 |  |  |  |  | my $root= $t->root || return undef;
3668 |  |  |  |  | return $root if( $root->passes( $cond));
3669 |  |  |  |  | return $root->next_elt( $cond);
3670 |  |  |  |  | }
3671 |  |  |  |  |
3672 |  |  |  |  | sub last_elt
3673 |  |  |  |  | { my( $t, $cond)= @_;
3674 |  |  |  |  | my $root= $t->root || return undef;
3675 |  |  |  |  | return $root->last_descendant( $cond);
3676 |  |  |  |  | }
3677 |  |  |  |  |
3678 |  |  |  |  | sub next_n_elt
3679 |  |  |  |  | { my( $t, $offset, $cond)= @_;
3680 |  |  |  |  | $offset -- if( $t->root->matches( $cond) );
3681 |  |  |  |  | return $t->root->next_n_elt( $offset, $cond);
3682 |  |  |  |  | }
3683 |  |  |  |  |
3684 |  |  |  |  | sub get_xpath
3685 | 16 | 2µs |  |  | # spent 12.4ms (82µs+12.3) within XML::Twig::get_xpath which was called 16 times, avg 775µs/call: # once (4µs+4.71ms) by Spreadsheet::ParseXLSX::_parse_styles at line 821 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (8µs+1.71ms) by Spreadsheet::ParseXLSX::_extract_files at line 963 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+1.06ms) by Spreadsheet::ParseXLSX::_parse_themes at line 672 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+1.01ms) by Spreadsheet::ParseXLSX::_parse_styles at line 910 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+531µs) by Spreadsheet::ParseXLSX::_parse_styles at line 853 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+510µs) by Spreadsheet::ParseXLSX::_parse_styles at line 856 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (12µs+451µs) by Spreadsheet::ParseXLSX::_parse_workbook at line 204 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+450µs) by Spreadsheet::ParseXLSX::_parse_styles at line 826 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+372µs) by Spreadsheet::ParseXLSX::_parse_workbook at line 199 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+287µs) by Spreadsheet::ParseXLSX::_parse_workbook at line 136 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+256µs) by Spreadsheet::ParseXLSX::_extract_files at line 985 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+249µs) by Spreadsheet::ParseXLSX::_extract_files at line 1010 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+241µs) by Spreadsheet::ParseXLSX::_parse_workbook at line 137 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (5µs+228µs) by Spreadsheet::ParseXLSX::_extract_files at line 981 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (4µs+213µs) by Spreadsheet::ParseXLSX::_extract_files at line 983 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (7µs+44µs) by Spreadsheet::ParseXLSX::_extract_files at line 991 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm { my $twig= shift;
3686 | 16 | 50µs | 16 | 26µs | if( isa( $_[0], 'ARRAY')) # spent 26µs making 16 calls to UNIVERSAL::isa, avg 2µs/call
3687 |  |  |  |  | { my $elt_array= shift;
3688 |  |  |  |  | return _unique_elts( map { $_->get_xpath( @_) } @$elt_array);
3689 |  |  |  |  | }
3690 |  |  |  |  | else
3691 | 16 | 54µs | 32 | 12.3ms | { return $twig->root->get_xpath( @_); } # spent 12.3ms making 16 calls to XML::Twig::Elt::get_xpath, avg 768µs/call # spent 10µs making 16 calls to XML::Twig::root, avg 625ns/call
3692 |  |  |  |  | }
3693 |  |  |  |  |
3694 |  |  |  |  | # get a list of elts and return a sorted list of unique elts
3695 |  |  |  |  | sub _unique_elts
3696 | 93 | 73µs | 93 | 2.91ms | # spent 1.56ms (60µs+1.50) within XML::Twig::_unique_elts which was called 16 times, avg 97µs/call: # 2 times (6µs+700ns) by XML::Twig::Elt::__ANON__[(eval 62)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 62)[XML/Twig.pm:7113], avg 3µs/call # once (6µs+543µs) by XML::Twig::Elt::__ANON__[(eval 68)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 68)[XML/Twig.pm:7113] # once (7µs+529µs) by XML::Twig::Elt::__ANON__[(eval 97)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 97)[XML/Twig.pm:7113] # once (6µs+366µs) by XML::Twig::Elt::__ANON__[(eval 70)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 70)[XML/Twig.pm:7113] # once (3µs+54µs) by XML::Twig::Elt::__ANON__[(eval 87)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 87)[XML/Twig.pm:7113] # once (5µs+700ns) by XML::Twig::Elt::__ANON__[(eval 58)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 58)[XML/Twig.pm:7113] # once (4µs+700ns) by XML::Twig::Elt::__ANON__[(eval 129)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 129)[XML/Twig.pm:7113] # once (4µs+500ns) by XML::Twig::Elt::__ANON__[(eval 60)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 60)[XML/Twig.pm:7113] # once (3µs+300ns) by XML::Twig::Elt::__ANON__[(eval 64)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 64)[XML/Twig.pm:7113] # once (3µs+300ns) by XML::Twig::Elt::__ANON__[(eval 61)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 61)[XML/Twig.pm:7113] # once (3µs+300ns) by XML::Twig::Elt::__ANON__[(eval 66)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 66)[XML/Twig.pm:7113] # once (3µs+300ns) by XML::Twig::Elt::__ANON__[(eval 103)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 103)[XML/Twig.pm:7113] # once (3µs+300ns) by XML::Twig::Elt::__ANON__[(eval 63)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 63)[XML/Twig.pm:7113] # once (2µs+300ns) by XML::Twig::Elt::__ANON__[(eval 76)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 76)[XML/Twig.pm:7113] # once (2µs+300ns) by XML::Twig::Elt::__ANON__[(eval 85)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 85)[XML/Twig.pm:7113] { my @sorted= sort { $a ->cmp( $b) } @_; # spent 1.50ms making 16 calls to CORE::sort, avg 94µs/call # spent 1.42ms making 77 calls to XML::Twig::Elt::cmp, avg 18µs/call
3697 | 16 | 2µs |  |  | my @unique;
3698 | 16 | 23µs |  |  | while( my $current= shift @sorted)
3699 |  |  |  |  | { push @unique, $current unless( @unique && ($unique[-1] == $current)); }
3700 | 16 | 21µs |  |  | return @unique;
3701 |  |  |  |  | }
3702 |  |  |  |  |
3703 |  |  |  |  | sub findvalue
3704 |  |  |  |  | { my $twig= shift;
3705 |  |  |  |  | if( isa( $_[0], 'ARRAY'))
3706 |  |  |  |  | { my $elt_array= shift;
3707 |  |  |  |  | return join( '', map { $_->findvalue( @_) } @$elt_array);
3708 |  |  |  |  | }
3709 |  |  |  |  | else
3710 |  |  |  |  | { return $twig->root->findvalue( @_); }
3711 |  |  |  |  | }
3712 |  |  |  |  |
3713 |  |  |  |  | sub findvalues
3714 |  |  |  |  | { my $twig= shift;
3715 |  |  |  |  | if( isa( $_[0], 'ARRAY'))
3716 |  |  |  |  | { my $elt_array= shift;
3717 |  |  |  |  | return map { $_->findvalues( @_) } @$elt_array;
3718 |  |  |  |  | }
3719 |  |  |  |  | else
3720 |  |  |  |  | { return $twig->root->findvalues( @_); }
3721 |  |  |  |  | }
3722 |  |  |  |  |
3723 |  |  |  |  | sub set_id_seed
3724 |  |  |  |  | { my $t= shift;
3725 |  |  |  |  | XML::Twig::Elt->set_id_seed( @_);
3726 |  |  |  |  | return $t;
3727 |  |  |  |  | }
3728 |  |  |  |  |
3729 |  |  |  |  | # return an array ref to an index, or undef
3730 |  |  |  |  | sub index
3731 |  |  |  |  | { my( $twig, $name, $index)= @_;
3732 |  |  |  |  | return defined( $index) ? $twig->{_twig_index}->{$name}->[$index] : $twig->{_twig_index}->{$name};
3733 |  |  |  |  | }
3734 |  |  |  |  |
3735 |  |  |  |  | # return a list with just the root
3736 |  |  |  |  | # if a condition is given then return an empty list unless the root matches
3737 |  |  |  |  | sub children
3738 |  |  |  |  | { my( $t, $cond)= @_;
3739 |  |  |  |  | my $root= $t->root;
3740 |  |  |  |  | unless( $cond && !($root->passes( $cond)) )
3741 |  |  |  |  | { return ($root); }
3742 |  |  |  |  | else
3743 |  |  |  |  | { return (); }
3744 |  |  |  |  | }
3745 |  |  |  |  |
3746 |  |  |  |  | sub _children { return ($_[0]->root); }
3747 |  |  |  |  |
3748 |  |  |  |  | # weird, but here for completude
3749 |  |  |  |  | # used to solve (non-sensical) /doc[1] XPath queries
3750 |  |  |  |  | sub child
3751 |  |  |  |  | { my $t= shift;
3752 |  |  |  |  | my $nb= shift;
3753 |  |  |  |  | return ($t->children( @_))[$nb];
3754 |  |  |  |  | }
3755 |  |  |  |  |
3756 |  |  |  |  | sub descendants
3757 | 16 | 6µs |  |  | # spent 6.13ms (84µs+6.05) within XML::Twig::descendants which was called 16 times, avg 383µs/call: # 2 times (10µs+34µs) by XML::Twig::Elt::__ANON__[(eval 62)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 62)[XML/Twig.pm:7113], avg 22µs/call # once (5µs+3.87ms) by XML::Twig::Elt::__ANON__[(eval 70)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 70)[XML/Twig.pm:7113] # once (8µs+468µs) by XML::Twig::Elt::__ANON__[(eval 58)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 58)[XML/Twig.pm:7113] # once (4µs+371µs) by XML::Twig::Elt::__ANON__[(eval 85)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 85)[XML/Twig.pm:7113] # once (5µs+268µs) by XML::Twig::Elt::__ANON__[(eval 68)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 68)[XML/Twig.pm:7113] # once (5µs+179µs) by XML::Twig::Elt::__ANON__[(eval 87)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 87)[XML/Twig.pm:7113] # once (9µs+163µs) by XML::Twig::Elt::__ANON__[(eval 129)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 129)[XML/Twig.pm:7113] # once (5µs+164µs) by XML::Twig::Elt::__ANON__[(eval 76)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 76)[XML/Twig.pm:7113] # once (4µs+163µs) by XML::Twig::Elt::__ANON__[(eval 97)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 97)[XML/Twig.pm:7113] # once (5µs+124µs) by XML::Twig::Elt::__ANON__[(eval 64)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 64)[XML/Twig.pm:7113] # once (4µs+109µs) by XML::Twig::Elt::__ANON__[(eval 103)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 103)[XML/Twig.pm:7113] # once (4µs+102µs) by XML::Twig::Elt::__ANON__[(eval 66)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 66)[XML/Twig.pm:7113] # once (6µs+12µs) by XML::Twig::Elt::__ANON__[(eval 60)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 60)[XML/Twig.pm:7113] # once (4µs+11µs) by XML::Twig::Elt::__ANON__[(eval 61)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 61)[XML/Twig.pm:7113] # once (4µs+11µs) by XML::Twig::Elt::__ANON__[(eval 63)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 63)[XML/Twig.pm:7113] { my( $t, $cond)= @_;
3758 | 16 | 10µs | 16 | 8µs | my $root= $t->root; # spent 8µs making 16 calls to XML::Twig::root, avg 494ns/call
3759 | 16 | 16µs | 16 | 5.17ms | if( $root->passes( $cond) ) # spent 5.17ms making 16 calls to XML::Twig::Elt::passes, avg 323µs/call
3760 |  |  |  |  | { return ($root, $root->descendants( $cond)); }
3761 |  |  |  |  | else
3762 | 16 | 42µs | 16 | 870µs | { return ( $root->descendants( $cond)); } # spent 870µs making 16 calls to XML::Twig::Elt::descendants, avg 54µs/call
3763 |  |  |  |  | }
3764 |  |  |  |  |
3765 |  |  |  |  | sub simplify { my $t= shift; $t->root->simplify( @_); }
3766 |  |  |  |  | sub subs_text { my $t= shift; $t->root->subs_text( @_); }
3767 |  |  |  |  | sub trim { my $t= shift; $t->root->trim( @_); }
3768 |  |  |  |  |
3769 |  |  |  |  |
3770 |  |  |  |  | sub set_keep_encoding
3771 | 7 | 2µs |  |  | # spent 26µs (18+8) within XML::Twig::set_keep_encoding which was called 7 times, avg 4µs/call: # 7 times (18µs+8µs) by XML::Twig::new at line 655, avg 4µs/call { my( $t, $keep)= @_;
3772 | 7 | 2µs |  |  | $t->{twig_keep_encoding}= $keep;
3773 | 7 | 2µs |  |  | $t->{NoExpand}= $keep;
3774 | 7 | 11µs | 7 | 8µs | return XML::Twig::Elt::set_keep_encoding( $keep); # spent 8µs making 7 calls to XML::Twig::Elt::set_keep_encoding, avg 1µs/call
3775 |  |  |  |  | }
3776 |  |  |  |  |
3777 |  |  |  |  | sub set_expand_external_entities
3778 | 7 | 11µs | 7 | 8µs | # spent 20µs (11+8) within XML::Twig::set_expand_external_entities which was called 7 times, avg 3µs/call: # 7 times (11µs+8µs) by XML::Twig::new at line 538, avg 3µs/call { return XML::Twig::Elt::set_expand_external_entities( @_); } # spent 8µs making 7 calls to XML::Twig::Elt::set_expand_external_entities, avg 1µs/call
3779 |  |  |  |  |
3780 |  |  |  |  | sub escape_gt
3781 |  |  |  |  | { my $t= shift; $t->{twig_escape_gt}= 1; return XML::Twig::Elt::escape_gt( @_); }
3782 |  |  |  |  |
3783 |  |  |  |  | sub do_not_escape_gt
3784 |  |  |  |  | { my $t= shift; $t->{twig_escape_gt}= 0; return XML::Twig::Elt::do_not_escape_gt( @_); }
3785 |  |  |  |  |
3786 |  |  |  |  | sub elt_id
3787 |  |  |  |  | { return $_[0]->{twig_id_list}->{$_[1]}; }
3788 |  |  |  |  |
3789 |  |  |  |  | # change it in ALL twigs at the moment
3790 |  |  |  |  | sub change_gi
3791 |  |  |  |  | { my( $twig, $old_gi, $new_gi)= @_;
3792 |  |  |  |  | my $index;
3793 |  |  |  |  | return unless($index= $XML::Twig::gi2index{$old_gi});
3794 |  |  |  |  | $XML::Twig::index2gi[$index]= $new_gi;
3795 |  |  |  |  | delete $XML::Twig::gi2index{$old_gi};
3796 |  |  |  |  | $XML::Twig::gi2index{$new_gi}= $index;
3797 |  |  |  |  | return $twig;
3798 |  |  |  |  | }
3799 |  |  |  |  |
3800 |  |  |  |  |
3801 |  |  |  |  | # builds the DTD from the stored (possibly updated) data
3802 |  |  |  |  | sub dtd_text
3803 |  |  |  |  | { my $t= shift;
3804 |  |  |  |  | my $dtd= $t->{twig_dtd};
3805 |  |  |  |  | my $doctype= $t->{twig_doctype} or return '';
3806 |  |  |  |  | my $string= "<!DOCTYPE ".$doctype->{name};
3807 |  |  |  |  |
3808 |  |  |  |  | $string .= " [\n";
3809 |  |  |  |  |
3810 |  |  |  |  | foreach my $gi (@{$dtd->{elt_list}})
3811 |  |  |  |  | { $string.= "<!ELEMENT $gi ".$dtd->{model}->{$gi}.">\n" ;
3812 |  |  |  |  | if( $dtd->{att}->{$gi})
3813 |  |  |  |  | { my $attlist= $dtd->{att}->{$gi};
3814 |  |  |  |  | $string.= "<!ATTLIST $gi\n";
3815 |  |  |  |  | foreach my $att ( sort keys %{$attlist})
3816 |  |  |  |  | {
3817 |  |  |  |  | if( $attlist->{$att}->{fixed})
3818 |  |  |  |  | { $string.= " $att $attlist->{$att}->{type} #FIXED $attlist->{$att}->{default}"; }
3819 |  |  |  |  | else
3820 |  |  |  |  | { $string.= " $att $attlist->{$att}->{type} $attlist->{$att}->{default}"; }
3821 |  |  |  |  | $string.= "\n";
3822 |  |  |  |  | }
3823 |  |  |  |  | $string.= ">\n";
3824 |  |  |  |  | }
3825 |  |  |  |  | }
3826 |  |  |  |  | $string.= $t->entity_list->text if( $t->entity_list);
3827 |  |  |  |  | $string.= "\n]>\n";
3828 |  |  |  |  | return $string;
3829 |  |  |  |  | }
3830 |  |  |  |  |
3831 |  |  |  |  | # prints the DTD from the stored (possibly updated) data
3832 |  |  |  |  | sub dtd_print
3833 |  |  |  |  | { my $t= shift;
3834 |  |  |  |  | my $fh= isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar') ? shift : undef;
3835 |  |  |  |  | if( $fh) { print $fh $t->dtd_text; }
3836 |  |  |  |  | else { print $t->dtd_text; }
3837 |  |  |  |  | return $t;
3838 |  |  |  |  | }
3839 |  |  |  |  |
3840 |  |  |  |  | # build the subs that call directly expat
3841 |  |  |  |  | BEGIN
3842 | 1 | 1µs |  |  | # spent 29µs within XML::Twig::BEGIN@3842 which was called: # once (29µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 3858 { my @expat_methods= qw( depth in_element within_element context
3843 |  |  |  |  | current_line current_column current_byte
3844 |  |  |  |  | recognized_string original_string
3845 |  |  |  |  | xpcroak xpcarp
3846 |  |  |  |  | base current_element element_index
3847 |  |  |  |  | xml_escape
3848 |  |  |  |  | position_in_context);
3849 | 1 | 3µs |  |  | foreach my $method (@expat_methods)
3850 |  |  |  |  | {
3851 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
3852 | 2 | 70µs | 2 | 14µs | # spent 10µs (6+4) within XML::Twig::BEGIN@3852 which was called: # once (6µs+4µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 3852 no strict 'refs'; # spent 10µs making 1 call to XML::Twig::BEGIN@3852 # spent 4µs making 1 call to strict::unimport
3853 |  |  |  |  | *{$method}= sub { my $t= shift;
3854 |  |  |  |  | _croak( "calling $method after parsing is finished") unless( $t->{twig_parsing});
3855 |  |  |  |  | return $t->{twig_parser}->$method(@_);
3856 | 16 | 25µs |  |  | };
3857 |  |  |  |  | }
3858 | 1 | 1.21ms | 1 | 29µs | } # spent 29µs making 1 call to XML::Twig::BEGIN@3842
3859 |  |  |  |  |
3860 |  |  |  |  | sub path
3861 |  |  |  |  | { my( $t, $gi)= @_;
3862 |  |  |  |  | if( $t->{twig_map_xmlns})
3863 |  |  |  |  | { return "/" . join( "/", map { $t->_replace_prefix( $_)} ($t->{twig_parser}->context, $gi)); }
3864 |  |  |  |  | else
3865 |  |  |  |  | { return "/" . join( "/", ($t->{twig_parser}->context, $gi)); }
3866 |  |  |  |  | }
3867 |  |  |  |  |
3868 |  |  |  |  | sub finish
3869 |  |  |  |  | { my $t= shift;
3870 |  |  |  |  | return $t->{twig_parser}->finish;
3871 |  |  |  |  | }
3872 |  |  |  |  |
3873 |  |  |  |  | # just finish the parse by printing the rest of the document
3874 |  |  |  |  | sub finish_print
3875 |  |  |  |  | { my( $t, $fh)= @_;
3876 |  |  |  |  | my $old_fh;
3877 |  |  |  |  | unless( defined $fh)
3878 |  |  |  |  | { $t->_set_fh_to_twig_output_fh(); }
3879 |  |  |  |  | elsif( defined $fh)
3880 |  |  |  |  | { $old_fh= select $fh;
3881 |  |  |  |  | $t->{twig_original_selected_fh}= $old_fh if( $old_fh);
3882 |  |  |  |  | }
3883 |  |  |  |  |
3884 |  |  |  |  | my $p=$t->{twig_parser};
3885 |  |  |  |  | if( $t->{twig_keep_encoding})
3886 |  |  |  |  | { $p->setHandlers( %twig_handlers_finish_print); }
3887 |  |  |  |  | else
3888 |  |  |  |  | { $p->setHandlers( %twig_handlers_finish_print_original); }
3889 |  |  |  |  | return $t;
3890 |  |  |  |  | }
3891 |  |  |  |  |
3892 | 7 | 10µs | 7 | 5µs | # spent 14µs (9+5) within XML::Twig::set_remove_cdata which was called 7 times, avg 2µs/call: # 7 times (9µs+5µs) by XML::Twig::new at line 675, avg 2µs/call sub set_remove_cdata { return XML::Twig::Elt::set_remove_cdata( @_); } # spent 5µs making 7 calls to XML::Twig::Elt::set_remove_cdata, avg 729ns/call
3893 |  |  |  |  |
3894 |  |  |  |  | sub output_filter { return XML::Twig::Elt::output_filter( @_); }
3895 | 7 | 10µs | 7 | 25µs | # spent 34µs (9+25) within XML::Twig::set_output_filter which was called 7 times, avg 5µs/call: # 7 times (9µs+25µs) by XML::Twig::new at line 668, avg 5µs/call sub set_output_filter { return XML::Twig::Elt::set_output_filter( @_); } # spent 25µs making 7 calls to XML::Twig::Elt::set_output_filter, avg 4µs/call
3896 |  |  |  |  |
3897 |  |  |  |  | sub output_text_filter { return XML::Twig::Elt::output_text_filter( @_); }
3898 | 7 | 9µs | 7 | 20µs | # spent 28µs (9+20) within XML::Twig::set_output_text_filter which was called 7 times, avg 4µs/call: # 7 times (9µs+20µs) by XML::Twig::new at line 682, avg 4µs/call sub set_output_text_filter { return XML::Twig::Elt::set_output_text_filter( @_); } # spent 20µs making 7 calls to XML::Twig::Elt::set_output_text_filter, avg 3µs/call
3899 |  |  |  |  |
3900 |  |  |  |  | sub set_input_filter
3901 |  |  |  |  | { my( $t, $input_filter)= @_;
3902 |  |  |  |  | my $old_filter= $t->{twig_input_filter};
3903 |  |  |  |  | if( !$input_filter || isa( $input_filter, 'CODE') )
3904 |  |  |  |  | { $t->{twig_input_filter}= $input_filter; }
3905 |  |  |  |  | elsif( $input_filter eq 'latin1')
3906 |  |  |  |  | { $t->{twig_input_filter}= latin1(); }
3907 |  |  |  |  | elsif( $filter{$input_filter})
3908 |  |  |  |  | { $t->{twig_input_filter}= $filter{$input_filter}; }
3909 |  |  |  |  | else
3910 |  |  |  |  | { _croak( "invalid input filter: $input_filter"); }
3911 |  |  |  |  |
3912 |  |  |  |  | return $old_filter;
3913 |  |  |  |  | }
3914 |  |  |  |  |
3915 |  |  |  |  | sub set_empty_tag_style
3916 |  |  |  |  | { return XML::Twig::Elt::set_empty_tag_style( @_); }
3917 |  |  |  |  |
3918 |  |  |  |  | sub set_pretty_print
3919 |  |  |  |  | { return XML::Twig::Elt::set_pretty_print( @_); }
3920 |  |  |  |  |
3921 |  |  |  |  | sub set_quote
3922 | 7 | 8µs | 7 | 11µs | # spent 22µs (11+11) within XML::Twig::set_quote which was called 7 times, avg 3µs/call: # 7 times (11µs+11µs) by XML::Twig::new at line 720, avg 3µs/call { return XML::Twig::Elt::set_quote( @_); } # spent 11µs making 7 calls to XML::Twig::Elt::set_quote, avg 2µs/call
3923 |  |  |  |  |
3924 |  |  |  |  | sub set_indent
3925 |  |  |  |  | { return XML::Twig::Elt::set_indent( @_); }
3926 |  |  |  |  |
3927 |  |  |  |  | sub set_keep_atts_order
3928 | 14 | 10µs | 7 | 7µs | # spent 17µs (10+7) within XML::Twig::set_keep_atts_order which was called 7 times, avg 2µs/call: # 7 times (10µs+7µs) by XML::Twig::new at line 692, avg 2µs/call { shift; return XML::Twig::Elt::set_keep_atts_order( @_); } # spent 7µs making 7 calls to XML::Twig::Elt::set_keep_atts_order, avg 971ns/call
3929 |  |  |  |  |
3930 |  |  |  |  | sub keep_atts_order
3931 |  |  |  |  | { return XML::Twig::Elt::keep_atts_order( @_); }
3932 |  |  |  |  |
3933 |  |  |  |  | sub set_do_not_escape_amp_in_atts
3934 | 7 | 24µs | 7 | 7µs | # spent 17µs (11+7) within XML::Twig::set_do_not_escape_amp_in_atts which was called 7 times, avg 2µs/call: # 7 times (11µs+7µs) by XML::Twig::new at line 554, avg 2µs/call { return XML::Twig::Elt::set_do_not_escape_amp_in_atts( @_); } # spent 7µs making 7 calls to XML::Twig::Elt::set_do_not_escape_amp_in_atts, avg 943ns/call
3935 |  |  |  |  |
3936 |  |  |  |  | # save and restore package globals (the ones in XML::Twig::Elt)
3937 |  |  |  |  | # should probably return the XML::Twig object itself, but instead
3938 |  |  |  |  | # returns the state (as a hashref) for backward compatibility
3939 |  |  |  |  | sub save_global_state
3940 |  |  |  |  | { my $t= shift;
3941 |  |  |  |  | return $t->{twig_saved_state}= XML::Twig::Elt::global_state();
3942 |  |  |  |  | }
3943 |  |  |  |  |
3944 |  |  |  |  | sub restore_global_state
3945 |  |  |  |  | { my $t= shift;
3946 |  |  |  |  | XML::Twig::Elt::set_global_state( $t->{twig_saved_state});
3947 |  |  |  |  | }
3948 |  |  |  |  |
3949 |  |  |  |  | sub global_state
3950 |  |  |  |  | { return XML::Twig::Elt::global_state(); }
3951 |  |  |  |  |
3952 |  |  |  |  | sub set_global_state
3953 |  |  |  |  | { return XML::Twig::Elt::set_global_state( $_[1]); }
3954 |  |  |  |  |
3955 |  |  |  |  | sub dispose
3956 |  |  |  |  | { my $t= shift;
3957 |  |  |  |  | $t->DESTROY;
3958 |  |  |  |  | return;
3959 |  |  |  |  | }
3960 |  |  |  |  |
3961 |  |  |  |  | sub DESTROY
3962 | 6 | 1µs |  |  | # spent 584µs (125+459) within XML::Twig::DESTROY which was called 6 times, avg 97µs/call: # 3 times (49µs+305µs) by Spreadsheet::ParseXLSX::_parse_workbook at line 208 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 118µs/call # 2 times (32µs+137µs) by Spreadsheet::ParseXLSX::_extract_files at line 1013 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 85µs/call # once (44µs+18µs) by XML::Twig::_checked_parse_result at line 801 { my $t= shift;
3963 | 6 | 23µs | 12 | 460µs | if( $t->{twig_root} && isa( $t->{twig_root}, 'XML::Twig::Elt')) # spent 456µs making 6 calls to XML::Twig::Elt::delete, avg 76µs/call # spent 4µs making 6 calls to UNIVERSAL::isa, avg 600ns/call
3964 |  |  |  |  | { $t->{twig_root}->delete }
3965 |  |  |  |  |
3966 |  |  |  |  | # added to break circular references
3967 | 6 | 3µs |  |  | undef $t->{twig};
3968 | 6 | 2µs |  |  | undef $t->{twig_root}->{twig} if( $t->{twig_root});
3969 | 6 | 2µs |  |  | undef $t->{twig_parser};
3970 |  |  |  |  |
3971 | 6 | 88µs |  |  | undef %$t;# prevents memory leaks (especially when using mod_perl)
3972 | 6 | 11µs |  |  | undef $t;
3973 |  |  |  |  | }
3974 |  |  |  |  |
3975 |  |  |  |  | # return true if perl was compiled using perlio
3976 |  |  |  |  | # if perl is not available return true, these days perlio should be used
3977 |  |  |  |  | sub _use_perlio
3978 |  |  |  |  | { my $perl= _this_perl();
3979 |  |  |  |  | return $perl ? grep /useperlio=define/, `$perl -V` : 1;
3980 |  |  |  |  | }
3981 |  |  |  |  |
3982 |  |  |  |  | # returns the parth to the perl executable (if available)
3983 |  |  |  |  | sub _this_perl
3984 |  |  |  |  | { # straight from perlvar
3985 |  |  |  |  | my $secure_perl_path= $Config{perlpath};
3986 |  |  |  |  | if ($^O ne 'VMS')
3987 |  |  |  |  | { $secure_perl_path .= $Config{_exe} unless $secure_perl_path =~ m/$Config{_exe}$/i; }
3988 |  |  |  |  | if( ! -f $secure_perl_path) { $secure_perl_path= ''; } # when perl is not available (PDK)
3989 |  |  |  |  | return $secure_perl_path;
3990 |  |  |  |  | }
3991 |  |  |  |  |
3992 |  |  |  |  | #
3993 |  |  |  |  | # non standard handlers
3994 |  |  |  |  | #
3995 |  |  |  |  |
3996 |  |  |  |  | # kludge: expat 1.95.2 calls both Default AND Doctype handlers
3997 |  |  |  |  | # so if the default handler finds '<!DOCTYPE' then it must
3998 |  |  |  |  | # unset itself (_twig_print_doctype will reset it)
3999 |  |  |  |  | sub _twig_print_check_doctype
4000 |  |  |  |  | { # warn " in _twig_print_check_doctype...\n"; # DEBUG handler
4001 |  |  |  |  |
4002 |  |  |  |  | my $p= shift;
4003 |  |  |  |  | my $string= $p->recognized_string();
4004 |  |  |  |  | if( $string eq '<!DOCTYPE')
4005 |  |  |  |  | {
4006 |  |  |  |  | $p->setHandlers( Default => undef);
4007 |  |  |  |  | $p->setHandlers( Entity => undef);
4008 |  |  |  |  | $expat_1_95_2=1;
4009 |  |  |  |  | }
4010 |  |  |  |  | else
4011 |  |  |  |  | { print $string; }
4012 |  |  |  |  |
4013 |  |  |  |  | return;
4014 |  |  |  |  | }
4015 |  |  |  |  |
4016 |  |  |  |  |
4017 |  |  |  |  | sub _twig_print
4018 |  |  |  |  | { # warn " in _twig_print...\n"; # DEBUG handler
4019 |  |  |  |  | my $p= shift;
4020 |  |  |  |  | if( $expat_1_95_2 && ($p->recognized_string eq '[') && !$p->{twig}->{expat_1_95_2_seen_bracket})
4021 |  |  |  |  | { # otherwise the opening square bracket of the doctype gets printed twice
4022 |  |  |  |  | $p->{twig}->{expat_1_95_2_seen_bracket}=1;
4023 |  |  |  |  | }
4024 |  |  |  |  | else
4025 |  |  |  |  | { if( $p->{twig}->{twig_right_after_root})
4026 |  |  |  |  | { my $s= $p->recognized_string(); print $s if $s=~ m{\S}; }
4027 |  |  |  |  | else
4028 |  |  |  |  | { print $p->recognized_string(); }
4029 |  |  |  |  | }
4030 |  |  |  |  | return;
4031 |  |  |  |  | }
4032 |  |  |  |  | # recognized_string does not seem to work for entities, go figure!
4033 |  |  |  |  | # so this handler is used to print them anyway
4034 |  |  |  |  | sub _twig_print_entity
4035 |  |  |  |  | { # warn " in _twig_print_entity...\n"; # DEBUG handler
4036 |  |  |  |  | my $p= shift;
4037 |  |  |  |  | XML::Twig::Entity->new( @_)->print;
4038 |  |  |  |  | }
4039 |  |  |  |  |
4040 |  |  |  |  | # kludge: expat 1.95.2 calls both Default AND Doctype handlers
4041 |  |  |  |  | # so if the default handler finds '<!DOCTYPE' then it must
4042 |  |  |  |  | # unset itself (_twig_print_doctype will reset it)
4043 |  |  |  |  | sub _twig_print_original_check_doctype
4044 |  |  |  |  | { # warn " in _twig_print_original_check_doctype...\n"; # DEBUG handler
4045 |  |  |  |  |
4046 |  |  |  |  | my $p= shift;
4047 |  |  |  |  | my $string= $p->original_string();
4048 |  |  |  |  | if( $string eq '<!DOCTYPE')
4049 |  |  |  |  | { $p->setHandlers( Default => undef);
4050 |  |  |  |  | $p->setHandlers( Entity => undef);
4051 |  |  |  |  | $expat_1_95_2=1;
4052 |  |  |  |  | }
4053 |  |  |  |  | else
4054 |  |  |  |  | { print $string; }
4055 |  |  |  |  |
4056 |  |  |  |  | return;
4057 |  |  |  |  | }
4058 |  |  |  |  |
4059 |  |  |  |  | sub _twig_print_original
4060 |  |  |  |  | { # warn " in _twig_print_original...\n"; # DEBUG handler
4061 |  |  |  |  | my $p= shift;
4062 |  |  |  |  | print $p->original_string();
4063 |  |  |  |  | return;
4064 |  |  |  |  | }
4065 |  |  |  |  |
4066 |  |  |  |  |
4067 |  |  |  |  | sub _twig_print_original_doctype
4068 |  |  |  |  | { # warn " in _twig_print_original_doctype...\n"; # DEBUG handler
4069 |  |  |  |  |
4070 |  |  |  |  | my( $p, $name, $sysid, $pubid, $internal)= @_;
4071 |  |  |  |  | if( $name)
4072 |  |  |  |  | { # with recent versions of XML::Parser original_string does not work,
4073 |  |  |  |  | # hence we need to rebuild the doctype declaration
4074 |  |  |  |  | my $doctype='';
4075 |  |  |  |  | $doctype .= qq{<!DOCTYPE $name} if( $name);
4076 |  |  |  |  | $doctype .= qq{ PUBLIC "$pubid"} if( $pubid);
4077 |  |  |  |  | $doctype .= qq{ SYSTEM} if( $sysid && !$pubid);
4078 |  |  |  |  | $doctype .= qq{ "$sysid"} if( $sysid);
4079 |  |  |  |  | $doctype .= ' [' if( $internal && !$expat_1_95_2) ;
4080 |  |  |  |  | $doctype .= qq{>} unless( $internal || $expat_1_95_2);
4081 |  |  |  |  | $p->{twig}->{twig_doctype}->{has_internal}=$internal;
4082 |  |  |  |  | print $doctype;
4083 |  |  |  |  | }
4084 |  |  |  |  | $p->setHandlers( Default => \&_twig_print_original);
4085 |  |  |  |  | return;
4086 |  |  |  |  | }
4087 |  |  |  |  |
4088 |  |  |  |  | sub _twig_print_doctype
4089 |  |  |  |  | { # warn " in _twig_print_doctype...\n"; # DEBUG handler
4090 |  |  |  |  | my( $p, $name, $sysid, $pubid, $internal)= @_;
4091 |  |  |  |  | if( $name)
4092 |  |  |  |  | { # with recent versions of XML::Parser original_string does not work,
4093 |  |  |  |  | # hence we need to rebuild the doctype declaration
4094 |  |  |  |  | my $doctype='';
4095 |  |  |  |  | $doctype .= qq{<!DOCTYPE $name} if( $name);
4096 |  |  |  |  | $doctype .= qq{ PUBLIC "$pubid"} if( $pubid);
4097 |  |  |  |  | $doctype .= qq{ SYSTEM} if( $sysid && !$pubid);
4098 |  |  |  |  | $doctype .= qq{ "$sysid"} if( $sysid);
4099 |  |  |  |  | $doctype .= ' [' if( $internal) ;
4100 |  |  |  |  | $doctype .= qq{>} unless( $internal || $expat_1_95_2);
4101 |  |  |  |  | $p->{twig}->{twig_doctype}->{has_internal}=$internal;
4102 |  |  |  |  | print $doctype;
4103 |  |  |  |  | }
4104 |  |  |  |  | $p->setHandlers( Default => \&_twig_print);
4105 |  |  |  |  | return;
4106 |  |  |  |  | }
4107 |  |  |  |  |
4108 |  |  |  |  |
4109 |  |  |  |  | sub _twig_print_original_default
4110 |  |  |  |  | { # warn " in _twig_print_original_default...\n"; # DEBUG handler
4111 |  |  |  |  | my $p= shift;
4112 |  |  |  |  | print $p->original_string();
4113 |  |  |  |  | return;
4114 |  |  |  |  | }
4115 |  |  |  |  |
4116 |  |  |  |  | # account for the case where the element is empty
4117 |  |  |  |  | sub _twig_print_end_original
4118 |  |  |  |  | { # warn " in _twig_print_end_original...\n"; # DEBUG handler
4119 |  |  |  |  | my $p= shift;
4120 |  |  |  |  | print $p->original_string();
4121 |  |  |  |  | return;
4122 |  |  |  |  | }
4123 |  |  |  |  |
4124 |  |  |  |  | sub _twig_start_check_roots
4125 |  |  |  |  | # spent 8.21s (720ms+7.49) within XML::Twig::_twig_start_check_roots which was called 33799 times, avg 243µs/call: # 33799 times (720ms+7.49s) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 243µs/call { # warn " in _twig_start_check_roots...\n"; # DEBUG handler
4126 | 33799 | 4.60ms |  |  | my $p= shift;
4127 | 33799 | 8.37ms |  |  | my $gi= shift;
4128 |  |  |  |  |
4129 | 33799 | 7.52ms |  |  | my $t= $p->{twig};
4130 |  |  |  |  |
4131 | 33799 | 85.8ms | 33799 | 28.9ms | my $fh= $t->{twig_output_fh} || select() || \*STDOUT; # spent 28.9ms making 33799 calls to CORE::select, avg 856ns/call
4132 |  |  |  |  |
4133 | 33799 | 3.31ms |  |  | my $ns_decl;
4134 | 33799 | 58.4ms | 67597 | 2.51s | unless( $p->depth == 0) # spent 2.49s making 33798 calls to XML::Twig::_replace_ns, avg 74µs/call # spent 21.4ms making 33799 calls to XML::Parser::Expat::depth, avg 633ns/call
4135 |  |  |  |  | { if( $t->{twig_map_xmlns}) { $ns_decl= _replace_ns( $t, \$gi, \@_); }
4136 |  |  |  |  | }
4137 |  |  |  |  |
4138 | 33799 | 46.1ms |  |  | my $context= { $ST_TAG => $gi, @_};
4139 | 33799 | 3.39ms |  |  | $context->{$ST_NS}= $ns_decl if $ns_decl;
4140 | 33799 | 10.8ms |  |  | push @{$t->{_twig_context_stack}}, $context;
4141 | 33799 | 24.1ms |  |  | my %att= @_;
4142 |  |  |  |  |
4143 | 33799 | 24.8ms | 33799 | 409ms | if( _handler( $t, $t->{twig_roots}, $gi)) # spent 409ms making 33799 calls to XML::Twig::_handler, avg 12µs/call
4144 | 33792 | 55.3ms | 33792 | 1.70s | { $p->setHandlers( %twig_handlers); # restore regular handlers # spent 1.70s making 33792 calls to XML::Parser::Expat::setHandlers, avg 50µs/call
4145 | 33792 | 24.7ms | 33792 | 20.3ms | $t->{twig_root_depth}= $p->depth; # spent 20.3ms making 33792 calls to XML::Parser::Expat::depth, avg 600ns/call
4146 | 33792 | 9.42ms |  |  | pop @{$t->{_twig_context_stack}}; # will be pushed back in _twig_start
4147 | 33792 | 22.5ms | 33792 | 2.81s | _twig_start( $p, $gi, @_); # spent 2.81s making 33792 calls to XML::Twig::_twig_start, avg 83µs/call
4148 | 33792 | 119ms |  |  | return;
4149 |  |  |  |  | }
4150 |  |  |  |  |
4151 |  |  |  |  | # $tag will always be true if it needs to be printed (the tag string is never empty)
4152 | 7 | 3µs |  |  | my $tag= $t->{twig_default_print} ? $t->{twig_keep_encoding} ? $p->original_string
4153 |  |  |  |  | : $p->recognized_string
4154 |  |  |  |  | : '';
4155 |  |  |  |  |
4156 | 7 | 6µs | 7 | 3µs | if( $p->depth == 0) # spent 3µs making 7 calls to XML::Parser::Expat::depth, avg 471ns/call
4157 |  |  |  |  | {
4158 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
4159 | 2 | 107µs | 2 | 14µs | # spent 10µs (6+4) within XML::Twig::BEGIN@4159 which was called: # once (6µs+4µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4159 no strict 'refs'; # spent 10µs making 1 call to XML::Twig::BEGIN@4159 # spent 4µs making 1 call to strict::unimport
4160 | 1 | 300ns |  |  | print {$fh} $tag if( $tag);
4161 | 1 | 500ns |  |  | pop @{$t->{_twig_context_stack}}; # will be pushed back in _twig_start
4162 | 1 | 2µs | 1 | 236µs | _twig_start( $p, $gi, @_); # spent 236µs making 1 call to XML::Twig::_twig_start
4163 | 1 | 2µs | 1 | 700ns | $t->root->{'flushed'}=1; # or the root start tag gets output the first time we flush # spent 700ns making 1 call to XML::Twig::root
4164 |  |  |  |  | }
4165 |  |  |  |  | elsif( $t->{twig_starttag_handlers})
4166 |  |  |  |  | { # look for start tag handlers
4167 |  |  |  |  |
4168 |  |  |  |  | my @handlers= _handler( $t, $t->{twig_starttag_handlers}, $gi);
4169 |  |  |  |  | my $last_handler_res;
4170 |  |  |  |  | foreach my $handler ( @handlers)
4171 |  |  |  |  | { $last_handler_res= $handler->($t, $gi, %att);
4172 |  |  |  |  | last unless $last_handler_res;
4173 |  |  |  |  | }
4174 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
4175 | 2 | 32µs | 2 | 11µs | # spent 8µs (5+3) within XML::Twig::BEGIN@4175 which was called: # once (5µs+3µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4175 no strict 'refs'; # spent 8µs making 1 call to XML::Twig::BEGIN@4175 # spent 3µs making 1 call to strict::unimport
4176 |  |  |  |  | print {$fh} $tag if( $tag && (!@handlers || $last_handler_res));
4177 |  |  |  |  | }
4178 |  |  |  |  | else
4179 |  |  |  |  | {
4180 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
4181 | 2 | 140µs | 2 | 8µs | # spent 6µs (4+2) within XML::Twig::BEGIN@4181 which was called: # once (4µs+2µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4181 no strict 'refs'; # spent 6µs making 1 call to XML::Twig::BEGIN@4181 # spent 2µs making 1 call to strict::unimport
4182 | 6 | 700ns |  |  | print {$fh} $tag if( $tag);
4183 |  |  |  |  | }
4184 | 7 | 11µs |  |  | return;
4185 |  |  |  |  | }
4186 |  |  |  |  |
4187 |  |  |  |  | sub _twig_end_check_roots
4188 |  |  |  |  | # spent 80µs (50+30) within XML::Twig::_twig_end_check_roots which was called 7 times, avg 11µs/call: # 7 times (50µs+30µs) by XML::Parser::Expat::ParseString at line 486 of XML/Parser/Expat.pm, avg 11µs/call { # warn " in _twig_end_check_roots...\n"; # DEBUG handler
4189 |  |  |  |  |
4190 | 7 | 3µs |  |  | my( $p, $gi, %att)= @_;
4191 | 7 | 2µs |  |  | my $t= $p->{twig};
4192 |  |  |  |  | # $tag can be empty (<elt/>), hence the undef and the tests for defined
4193 | 7 | 3µs |  |  | my $tag= $t->{twig_default_print} ? $t->{twig_keep_encoding} ? $p->original_string
4194 |  |  |  |  | : $p->recognized_string
4195 |  |  |  |  | : undef;
4196 | 7 | 15µs | 7 | 5µs | my $fh= $t->{twig_output_fh} || select() || \*STDOUT; # spent 5µs making 7 calls to CORE::select, avg 657ns/call
4197 |  |  |  |  |
4198 | 7 | 2µs |  |  | if( $t->{twig_endtag_handlers})
4199 |  |  |  |  | { # look for end tag handlers
4200 |  |  |  |  | my @handlers= _handler( $t, $t->{twig_endtag_handlers}, $gi);
4201 |  |  |  |  | my $last_handler_res=1;
4202 |  |  |  |  | foreach my $handler ( @handlers)
4203 |  |  |  |  | { $last_handler_res= $handler->($t, $gi) || last; }
4204 |  |  |  |  | #if( ! $last_handler_res)
4205 |  |  |  |  | # { pop @{$t->{_twig_context_stack}}; warn "tested";
4206 |  |  |  |  | # return;
4207 |  |  |  |  | # }
4208 |  |  |  |  | }
4209 |  |  |  |  | {
4210 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
4211 | 9 | 166µs | 2 | 11µs | # spent 8µs (5+3) within XML::Twig::BEGIN@4211 which was called: # once (5µs+3µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4211 no strict 'refs'; # spent 8µs making 1 call to XML::Twig::BEGIN@4211 # spent 3µs making 1 call to strict::unimport
4212 | 7 | 1µs |  |  | print {$fh} $tag if( defined $tag);
4213 |  |  |  |  | }
4214 | 7 | 6µs | 7 | 3µs | if( $p->depth == 0) # spent 3µs making 7 calls to XML::Parser::Expat::depth, avg 457ns/call
4215 |  |  |  |  | {
4216 | 1 | 700ns | 1 | 21µs | _twig_end( $p, $gi); # spent 21µs making 1 call to XML::Twig::_twig_end
4217 | 1 | 2µs | 1 | 1µs | $t->root->{end_tag_flushed}=1; # spent 1µs making 1 call to XML::Twig::root
4218 |  |  |  |  | }
4219 |  |  |  |  |
4220 | 7 | 6µs |  |  | pop @{$t->{_twig_context_stack}};
4221 | 7 | 9µs |  |  | return;
4222 |  |  |  |  | }
4223 |  |  |  |  |
4224 |  |  |  |  | sub _twig_pi_check_roots
4225 |  |  |  |  | { # warn " in _twig_pi_check_roots...\n"; # DEBUG handler
4226 |  |  |  |  | my( $p, $target, $data)= @_;
4227 |  |  |  |  | my $t= $p->{twig};
4228 |  |  |  |  | my $pi= $t->{twig_default_print} ? $t->{twig_keep_encoding} ? $p->original_string
4229 |  |  |  |  | : $p->recognized_string
4230 |  |  |  |  | : undef;
4231 |  |  |  |  | my $fh= $t->{twig_output_fh} || select() || \*STDOUT;
4232 |  |  |  |  |
4233 |  |  |  |  | if( my $handler= $t->{twig_handlers}->{pi_handlers}->{$target}
4234 |  |  |  |  | || $t->{twig_handlers}->{pi_handlers}->{''}
4235 |  |  |  |  | )
4236 |  |  |  |  | { # if handler is called on pi, then it needs to be processed as a regular node
4237 |  |  |  |  | my @flags= qw( twig_process_pi twig_keep_pi);
4238 |  |  |  |  | my @save= @{$t}{@flags}; # save pi related flags
4239 |  |  |  |  | @{$t}{@flags}= (1, 0); # override them, pi needs to be processed
4240 |  |  |  |  | _twig_pi( @_); # call handler on the pi
4241 |  |  |  |  | @{$t}{@flags}= @save;; # restore flag
4242 |  |  |  |  | }
4243 |  |  |  |  | else
4244 |  |  |  |  | {
4245 |  |  |  |  | ## no critic (TestingAndDebugging::ProhibitNoStrict);
4246 | 2 | 1.52ms | 2 | 11µs | # spent 8µs (5+3) within XML::Twig::BEGIN@4246 which was called: # once (5µs+3µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4246 no strict 'refs'; # spent 8µs making 1 call to XML::Twig::BEGIN@4246 # spent 3µs making 1 call to strict::unimport
4247 |  |  |  |  | print {$fh} $pi if( defined( $pi));
4248 |  |  |  |  | }
4249 |  |  |  |  | return;
4250 |  |  |  |  | }
4251 |  |  |  |  |
4252 |  |  |  |  |
4253 |  |  |  |  | sub _output_ignored
4254 |  |  |  |  | { my( $t, $p)= @_;
4255 |  |  |  |  | my $action= $t->{twig_ignore_action};
4256 |  |  |  |  |
4257 |  |  |  |  | my $get_string= $t->{twig_keep_encoding} ? 'original_string' : 'recognized_string';
4258 |  |  |  |  |
4259 |  |  |  |  | if( $action eq 'print' ) { print $p->$get_string; }
4260 |  |  |  |  | else
4261 |  |  |  |  | { my $string_ref;
4262 |  |  |  |  | if( $action eq 'string')
4263 |  |  |  |  | { $string_ref= \$t->{twig_buffered_string}; }
4264 |  |  |  |  | elsif( ref( $action) && ref( $action) eq 'SCALAR')
4265 |  |  |  |  | { $string_ref= $action; }
4266 |  |  |  |  | else
4267 |  |  |  |  | { _croak( "wrong ignore action: $action"); }
4268 |  |  |  |  |
4269 |  |  |  |  | $$string_ref .= $p->$get_string;
4270 |  |  |  |  | }
4271 |  |  |  |  | }
4272 |  |  |  |  |
4273 |  |  |  |  |
4274 |  |  |  |  |
4275 |  |  |  |  | sub _twig_ignore_start
4276 |  |  |  |  | { # warn " in _twig_ignore_start...\n"; # DEBUG handler
4277 |  |  |  |  |
4278 |  |  |  |  | my( $p, $gi)= @_;
4279 |  |  |  |  | my $t= $p->{twig};
4280 |  |  |  |  | $t->{twig_ignore_level}++;
4281 |  |  |  |  | my $action= $t->{twig_ignore_action};
4282 |  |  |  |  |
4283 |  |  |  |  | $t->_output_ignored( $p) unless $action eq 'discard';
4284 |  |  |  |  | return;
4285 |  |  |  |  | }
4286 |  |  |  |  |
4287 |  |  |  |  | sub _twig_ignore_end
4288 |  |  |  |  | { # warn " in _twig_ignore_end...\n"; # DEBUG handler
4289 |  |  |  |  |
4290 |  |  |  |  | my( $p, $gi)= @_;
4291 |  |  |  |  | my $t= $p->{twig};
4292 |  |  |  |  |
4293 |  |  |  |  | my $action= $t->{twig_ignore_action};
4294 |  |  |  |  | $t->_output_ignored( $p) unless $action eq 'discard';
4295 |  |  |  |  |
4296 |  |  |  |  | $t->{twig_ignore_level}--;
4297 |  |  |  |  |
4298 |  |  |  |  | if( ! $t->{twig_ignore_level})
4299 |  |  |  |  | {
4300 |  |  |  |  | $t->{twig_current} = $t->{twig_ignore_elt};
4301 |  |  |  |  | $t->{twig_current}->{'twig_current'}=1;
4302 |  |  |  |  |
4303 |  |  |  |  | $t->{twig_ignore_elt}->cut; # there could possibly be a memory leak here (delete would avoid it,
4304 |  |  |  |  | # but could also delete elements that should not be deleted)
4305 |  |  |  |  |
4306 |  |  |  |  | # restore the saved stack to the current level
4307 |  |  |  |  | splice( @{$t->{_twig_context_stack}}, $p->depth+ 1 );
4308 |  |  |  |  | #warn "stack: ", _dump_stack( $t->{_twig_context_stack}), "\n";
4309 |  |  |  |  |
4310 |  |  |  |  | $p->setHandlers( @{$t->{twig_saved_handlers}});
4311 |  |  |  |  | # test for handlers
4312 |  |  |  |  | if( $t->{twig_endtag_handlers})
4313 |  |  |  |  | { # look for end tag handlers
4314 |  |  |  |  | my @handlers= _handler( $t, $t->{twig_endtag_handlers}, $gi);
4315 |  |  |  |  | my $last_handler_res=1;
4316 |  |  |  |  | foreach my $handler ( @handlers)
4317 |  |  |  |  | { $last_handler_res= $handler->($t, $gi) || last; }
4318 |  |  |  |  | }
4319 |  |  |  |  | pop @{$t->{_twig_context_stack}};
4320 |  |  |  |  | };
4321 |  |  |  |  | return;
4322 |  |  |  |  | }
4323 |  |  |  |  |
4324 |  |  |  |  | #sub _dump_stack { my( $stack)= @_; return join( ":", map { $_->{$ST_TAG} } @$stack); }
4325 |  |  |  |  |
4326 |  |  |  |  | sub ignore
4327 |  |  |  |  | { my( $t, $elt, $action)= @_;
4328 |  |  |  |  | my $current= $t->{twig_current};
4329 |  |  |  |  |
4330 |  |  |  |  | if( ! ($elt && ref( $elt) && isa( $elt, 'XML::Twig::Elt'))) { $elt= $current; }
4331 |  |  |  |  |
4332 |  |  |  |  | #warn "ignore: current = ", $current->tag, ", elt = ", $elt->tag, ")\n";
4333 |  |  |  |  |
4334 |  |  |  |  | # we need the ($elt == $current->{last_child}) test because the current element is set to the
4335 |  |  |  |  | # parent _before_ handlers are called (and I can't figure out how to fix this)
4336 |  |  |  |  | unless( ($elt == $current) || ($current->{last_child} && ($elt == $current->{last_child})) || $current->in( $elt))
4337 |  |  |  |  | { _croak( "element to be ignored must be ancestor of current element"); }
4338 |  |  |  |  |
4339 |  |  |  |  | $t->{twig_ignore_level}= $current == $elt ? 1 : $t->_level_in_stack( $current) - $t->_level_in_stack($elt) + 1;
4340 |  |  |  |  | #warn "twig_ignore_level: $t->{twig_ignore_level} (current: ", $current->tag, ", elt: ", $elt->tag, ")\n";
4341 |  |  |  |  | $t->{twig_ignore_elt} = $elt; # save it, so we can delete it later
4342 |  |  |  |  |
4343 |  |  |  |  | $action ||= 'discard';
4344 |  |  |  |  | if( !($action eq 'print' || $action eq 'string' || ( ref( $action) && ref( $action) eq 'SCALAR')))
4345 |  |  |  |  | { $action= 'discard'; }
4346 |  |  |  |  |
4347 |  |  |  |  | $t->{twig_ignore_action}= $action;
4348 |  |  |  |  |
4349 |  |  |  |  | my $p= $t->{twig_parser};
4350 |  |  |  |  | my @saved_handlers= $p->setHandlers( %twig_handlers_ignore); # set handlers
4351 |  |  |  |  |
4352 |  |  |  |  | my $get_string= $t->{twig_keep_encoding} ? 'original_string' : 'recognized_string';
4353 |  |  |  |  |
4354 |  |  |  |  | my $default_handler;
4355 |  |  |  |  |
4356 |  |  |  |  | if( $action ne 'discard')
4357 |  |  |  |  | { if( $action eq 'print')
4358 |  |  |  |  | { $p->setHandlers( Default => sub { print $_[0]->$get_string; }); }
4359 |  |  |  |  | else
4360 |  |  |  |  | { my $string_ref;
4361 |  |  |  |  | if( $action eq 'string')
4362 |  |  |  |  | { if( ! exists $t->{twig_buffered_string}) { $t->{twig_buffered_string}=''; }
4363 |  |  |  |  | $string_ref= \$t->{twig_buffered_string};
4364 |  |  |  |  | }
4365 |  |  |  |  | elsif( ref( $action) && ref( $action) eq 'SCALAR')
4366 |  |  |  |  | { $string_ref= $action; }
4367 |  |  |  |  |
4368 |  |  |  |  | $p->setHandlers( Default => sub { $$string_ref .= $_[0]->$get_string; });
4369 |  |  |  |  | }
4370 |  |  |  |  | $t->_output_ignored( $p, $action);
4371 |  |  |  |  | }
4372 |  |  |  |  |
4373 |  |  |  |  |
4374 |  |  |  |  | $t->{twig_saved_handlers}= \@saved_handlers; # save current handlers
4375 |  |  |  |  | }
4376 |  |  |  |  |
4377 |  |  |  |  | sub _level_in_stack
4378 |  |  |  |  | { my( $t, $elt)= @_;
4379 |  |  |  |  | my $level=1;
4380 |  |  |  |  | foreach my $elt_in_stack ( @{$t->{_twig_context_stack}} )
4381 |  |  |  |  | { if( $elt_in_stack->{$ST_ELT} && ($elt == $elt_in_stack->{$ST_ELT})) { return $level }
4382 |  |  |  |  | $level++;
4383 |  |  |  |  | }
4384 |  |  |  |  | }
4385 |  |  |  |  |
- - |  |  |  |  |
4388 |  |  |  |  | # select $t->{twig_output_fh} and store the current selected fh
4389 |  |  |  |  | sub _set_fh_to_twig_output_fh
4390 | 7 | 1µs |  |  | # spent 6µs within XML::Twig::_set_fh_to_twig_output_fh which was called 7 times, avg 929ns/call: # 7 times (6µs+0s) by XML::Twig::_twig_init at line 1974, avg 929ns/call { my $t= shift;
4391 | 7 | 1µs |  |  | my $output_fh= $t->{twig_output_fh};
4392 | 7 | 6µs |  |  | if( $output_fh && !$t->{twig_output_fh_selected})
4393 |  |  |  |  | { # there is an output fh
4394 |  |  |  |  | $t->{twig_selected_fh}= select(); # store the currently selected fh
4395 |  |  |  |  | $t->{twig_output_fh_selected}=1;
4396 |  |  |  |  | select $output_fh; # select the output fh for the twig
4397 |  |  |  |  | }
4398 |  |  |  |  | }
4399 |  |  |  |  |
4400 |  |  |  |  | # select the fh that was stored in $t->{twig_selected_fh}
4401 |  |  |  |  | # (before $t->{twig_output_fh} was selected)
4402 |  |  |  |  | sub _set_fh_to_selected_fh
4403 | 7 | 1µs |  |  | # spent 8µs within XML::Twig::_set_fh_to_selected_fh which was called 7 times, avg 1µs/call: # 7 times (8µs+0s) by XML::Twig::_twig_final at line 2736, avg 1µs/call { my $t= shift;
4404 | 7 | 9µs |  |  | return unless( $t->{twig_output_fh});
4405 |  |  |  |  | my $selected_fh= $t->{twig_selected_fh};
4406 |  |  |  |  | $t->{twig_output_fh_selected}=0;
4407 |  |  |  |  | select $selected_fh;
4408 |  |  |  |  | return;
4409 |  |  |  |  | }
4410 |  |  |  |  |
4411 |  |  |  |  |
4412 |  |  |  |  | sub encoding
4413 |  |  |  |  | { return $_[0]->{twig_xmldecl}->{encoding} if( $_[0]->{twig_xmldecl}); }
4414 |  |  |  |  |
4415 |  |  |  |  | sub set_encoding
4416 |  |  |  |  | { my( $t, $encoding)= @_;
4417 |  |  |  |  | $t->{twig_xmldecl} ||={};
4418 |  |  |  |  | $t->set_xml_version( "1.0") unless( $t->xml_version);
4419 |  |  |  |  | $t->{twig_xmldecl}->{encoding}= $encoding;
4420 |  |  |  |  | return $t;
4421 |  |  |  |  | }
4422 |  |  |  |  |
4423 |  |  |  |  | sub output_encoding
4424 |  |  |  |  | { return $_[0]->{output_encoding}; }
4425 |  |  |  |  |
4426 |  |  |  |  | sub set_output_encoding
4427 |  |  |  |  | { my( $t, $encoding)= @_;
4428 |  |  |  |  | my $output_filter= $t->output_filter || '';
4429 |  |  |  |  |
4430 |  |  |  |  | if( ($encoding && $encoding !~ m{^utf-?8$}i) || $t->{twig_keep_encoding} || $output_filter)
4431 |  |  |  |  | { $t->set_output_filter( _encoding_filter( $encoding || '')); }
4432 |  |  |  |  |
4433 |  |  |  |  | $t->{output_encoding}= $encoding;
4434 |  |  |  |  | return $t;
4435 |  |  |  |  | }
4436 |  |  |  |  |
4437 |  |  |  |  | sub xml_version
4438 |  |  |  |  | { return $_[0]->{twig_xmldecl}->{version} if( $_[0]->{twig_xmldecl}); }
4439 |  |  |  |  |
4440 |  |  |  |  | sub set_xml_version
4441 |  |  |  |  | { my( $t, $version)= @_;
4442 |  |  |  |  | $t->{twig_xmldecl} ||={};
4443 |  |  |  |  | $t->{twig_xmldecl}->{version}= $version;
4444 |  |  |  |  | return $t;
4445 |  |  |  |  | }
4446 |  |  |  |  |
4447 |  |  |  |  | sub standalone
4448 |  |  |  |  | { return $_[0]->{twig_xmldecl}->{standalone} if( $_[0]->{twig_xmldecl}); }
4449 |  |  |  |  |
4450 |  |  |  |  | sub set_standalone
4451 |  |  |  |  | { my( $t, $standalone)= @_;
4452 |  |  |  |  | $t->{twig_xmldecl} ||={};
4453 |  |  |  |  | $t->set_xml_version( "1.0") unless( $t->xml_version);
4454 |  |  |  |  | $t->{twig_xmldecl}->{standalone}= $standalone;
4455 |  |  |  |  | return $t;
4456 |  |  |  |  | }
4457 |  |  |  |  |
4458 |  |  |  |  |
4459 |  |  |  |  | # SAX methods
4460 |  |  |  |  |
4461 |  |  |  |  | sub toSAX1
4462 |  |  |  |  | { _croak( "cannot use toSAX1 while parsing (use flush_toSAX1)") if (defined $_[0]->{twig_parser});
4463 |  |  |  |  | shift(@_)->_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX1,
4464 |  |  |  |  | \&XML::Twig::Elt::_end_tag_data_SAX1
4465 |  |  |  |  | );
4466 |  |  |  |  | }
4467 |  |  |  |  |
4468 |  |  |  |  | sub toSAX2
4469 |  |  |  |  | { _croak( "cannot use toSAX2 while parsing (use flush_toSAX2)") if (defined $_[0]->{twig_parser});
4470 |  |  |  |  | shift(@_)->_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX2,
4471 |  |  |  |  | \&XML::Twig::Elt::_end_tag_data_SAX2
4472 |  |  |  |  | );
4473 |  |  |  |  | }
4474 |  |  |  |  |
4475 |  |  |  |  |
4476 |  |  |  |  | sub _toSAX
4477 |  |  |  |  | { my( $t, $handler, $start_tag_data, $end_tag_data) = @_;
4478 |  |  |  |  |
4479 |  |  |  |  | if( my $start_document = $handler->can( 'start_document'))
4480 |  |  |  |  | { $start_document->( $handler); }
4481 |  |  |  |  |
4482 |  |  |  |  | $t->_prolog_toSAX( $handler);
4483 |  |  |  |  |
4484 |  |  |  |  | if( $t->root) { $t->root->_toSAX( $handler, $start_tag_data, $end_tag_data) ; }
4485 |  |  |  |  | if( my $end_document = $handler->can( 'end_document'))
4486 |  |  |  |  | { $end_document->( $handler); }
4487 |  |  |  |  | }
4488 |  |  |  |  |
4489 |  |  |  |  |
4490 |  |  |  |  | sub flush_toSAX1
4491 |  |  |  |  | { shift(@_)->_flush_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX1,
4492 |  |  |  |  | \&XML::Twig::Elt::_end_tag_data_SAX1
4493 |  |  |  |  | );
4494 |  |  |  |  | }
4495 |  |  |  |  |
4496 |  |  |  |  | sub flush_toSAX2
4497 |  |  |  |  | { shift(@_)->_flush_toSAX(@_, \&XML::Twig::Elt::_start_tag_data_SAX2,
4498 |  |  |  |  | \&XML::Twig::Elt::_end_tag_data_SAX2
4499 |  |  |  |  | );
4500 |  |  |  |  | }
4501 |  |  |  |  |
4502 |  |  |  |  | sub _flush_toSAX
4503 |  |  |  |  | { my( $t, $handler, $start_tag_data, $end_tag_data)= @_;
4504 |  |  |  |  |
4505 |  |  |  |  | # the "real" last element processed, as _twig_end has closed it
4506 |  |  |  |  | my $last_elt;
4507 |  |  |  |  | if( $t->{twig_current})
4508 |  |  |  |  | { $last_elt= $t->{twig_current}->{last_child}; }
4509 |  |  |  |  | else
4510 |  |  |  |  | { $last_elt= $t->{twig_root}; }
4511 |  |  |  |  |
4512 |  |  |  |  | my $elt= $t->{twig_root};
4513 |  |  |  |  | unless( $elt->{'flushed'})
4514 |  |  |  |  | { # init unless already done (ie root has been flushed)
4515 |  |  |  |  | if( my $start_document = $handler->can( 'start_document'))
4516 |  |  |  |  | { $start_document->( $handler); }
4517 |  |  |  |  | # flush the DTD
4518 |  |  |  |  | $t->_prolog_toSAX( $handler)
4519 |  |  |  |  | }
4520 |  |  |  |  |
4521 |  |  |  |  | while( $elt)
4522 |  |  |  |  | { my $next_elt;
4523 |  |  |  |  | if( $last_elt && $last_elt->in( $elt))
4524 |  |  |  |  | {
4525 |  |  |  |  | unless( $elt->{'flushed'})
4526 |  |  |  |  | { # just output the front tag
4527 |  |  |  |  | if( my $start_element = $handler->can( 'start_element'))
4528 |  |  |  |  | { if( my $tag_data= $start_tag_data->( $elt))
4529 |  |  |  |  | { $start_element->( $handler, $tag_data); }
4530 |  |  |  |  | }
4531 |  |  |  |  | $elt->{'flushed'}=1;
4532 |  |  |  |  | }
4533 |  |  |  |  | $next_elt= $elt->{first_child};
4534 |  |  |  |  | }
4535 |  |  |  |  | else
4536 |  |  |  |  | { # an element before the last one or the last one,
4537 |  |  |  |  | $next_elt= $elt->{next_sibling};
4538 |  |  |  |  | $elt->_toSAX( $handler, $start_tag_data, $end_tag_data);
4539 |  |  |  |  | $elt->delete;
4540 |  |  |  |  | last if( $last_elt && ($elt == $last_elt));
4541 |  |  |  |  | }
4542 |  |  |  |  | $elt= $next_elt;
4543 |  |  |  |  | }
4544 |  |  |  |  | if( !$t->{twig_parsing})
4545 |  |  |  |  | { if( my $end_document = $handler->can( 'end_document'))
4546 |  |  |  |  | { $end_document->( $handler); }
4547 |  |  |  |  | }
4548 |  |  |  |  | }
4549 |  |  |  |  |
4550 |  |  |  |  |
4551 |  |  |  |  | sub _prolog_toSAX
4552 |  |  |  |  | { my( $t, $handler)= @_;
4553 |  |  |  |  | $t->_xmldecl_toSAX( $handler);
4554 |  |  |  |  | $t->_DTD_toSAX( $handler);
4555 |  |  |  |  | }
4556 |  |  |  |  |
4557 |  |  |  |  | sub _xmldecl_toSAX
4558 |  |  |  |  | { my( $t, $handler)= @_;
4559 |  |  |  |  | my $decl= $t->{twig_xmldecl};
4560 |  |  |  |  | my $data= { Version => $decl->{version},
4561 |  |  |  |  | Encoding => $decl->{encoding},
4562 |  |  |  |  | Standalone => $decl->{standalone},
4563 |  |  |  |  | };
4564 |  |  |  |  | if( my $xml_decl= $handler->can( 'xml_decl'))
4565 |  |  |  |  | { $xml_decl->( $handler, $data); }
4566 |  |  |  |  | }
4567 |  |  |  |  |
4568 |  |  |  |  | sub _DTD_toSAX
4569 |  |  |  |  | { my( $t, $handler)= @_;
4570 |  |  |  |  | my $doctype= $t->{twig_doctype};
4571 |  |  |  |  | return unless( $doctype);
4572 |  |  |  |  | my $data= { Name => $doctype->{name},
4573 |  |  |  |  | PublicId => $doctype->{pub},
4574 |  |  |  |  | SystemId => $doctype->{sysid},
4575 |  |  |  |  | };
4576 |  |  |  |  |
4577 |  |  |  |  | if( my $start_dtd= $handler->can( 'start_dtd'))
4578 |  |  |  |  | { $start_dtd->( $handler, $data); }
4579 |  |  |  |  |
4580 |  |  |  |  | # I should call code to export the internal subset here
4581 |  |  |  |  |
4582 |  |  |  |  | if( my $end_dtd= $handler->can( 'end_dtd'))
4583 |  |  |  |  | { $end_dtd->( $handler); }
4584 |  |  |  |  | }
4585 |  |  |  |  |
4586 |  |  |  |  | # input/output filters
4587 |  |  |  |  |
4588 |  |  |  |  | sub latin1
4589 |  |  |  |  | { local $SIG{__DIE__};
4590 |  |  |  |  | if( _use( 'Encode'))
4591 |  |  |  |  | { return encode_convert( 'ISO-8859-15'); }
4592 |  |  |  |  | elsif( _use( 'Text::Iconv'))
4593 |  |  |  |  | { return iconv_convert( 'ISO-8859-15'); }
4594 |  |  |  |  | elsif( _use( 'Unicode::Map8') && _use( 'Unicode::String'))
4595 |  |  |  |  | { return unicode_convert( 'ISO-8859-15'); }
4596 |  |  |  |  | else
4597 |  |  |  |  | { return \&regexp2latin1; }
4598 |  |  |  |  | }
4599 |  |  |  |  |
4600 |  |  |  |  | sub _encoding_filter
4601 |  |  |  |  | {
4602 |  |  |  |  | { local $SIG{__DIE__};
4603 |  |  |  |  | my $encoding= $_[1] || $_[0];
4604 |  |  |  |  | if( _use( 'Encode'))
4605 |  |  |  |  | { my $sub= encode_convert( $encoding);
4606 |  |  |  |  | return $sub;
4607 |  |  |  |  | }
4608 |  |  |  |  | elsif( _use( 'Text::Iconv'))
4609 |  |  |  |  | { return iconv_convert( $encoding); }
4610 |  |  |  |  | elsif( _use( 'Unicode::Map8') && _use( 'Unicode::String'))
4611 |  |  |  |  | { return unicode_convert( $encoding); }
4612 |  |  |  |  | }
4613 |  |  |  |  | _croak( "Encode, Text::Iconv or Unicode::Map8 and Unicode::String need to be installed in order to use encoding options");
4614 |  |  |  |  | }
4615 |  |  |  |  |
4616 |  |  |  |  | # shamelessly lifted from XML::TyePYX (works only with XML::Parse 2.27)
4617 |  |  |  |  | sub regexp2latin1
4618 |  |  |  |  | { my $text=shift;
4619 |  |  |  |  | $text=~s{([\xc0-\xc3])(.)}{ my $hi = ord($1);
4620 |  |  |  |  | my $lo = ord($2);
4621 |  |  |  |  | chr((($hi & 0x03) <<6) | ($lo & 0x3F))
4622 |  |  |  |  | }ge;
4623 |  |  |  |  | return $text;
4624 |  |  |  |  | }
4625 |  |  |  |  |
4626 |  |  |  |  |
4627 |  |  |  |  | sub html_encode
4628 |  |  |  |  | { _use( 'HTML::Entities') or croak "cannot use html_encode: missing HTML::Entities";
4629 |  |  |  |  | return HTML::Entities::encode_entities($_[0] );
4630 |  |  |  |  | }
4631 |  |  |  |  |
4632 |  |  |  |  | sub safe_encode
4633 |  |  |  |  | { my $str= shift;
4634 |  |  |  |  | if( $perl_version < 5.008)
4635 |  |  |  |  | { # the no utf8 makes the regexp work in 5.6
4636 | 2 | 91µs | 2 | 12µs | # spent 10µs (8+2) within XML::Twig::BEGIN@4636 which was called: # once (8µs+2µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4636 no utf8; # = perl 5.6 # spent 10µs making 1 call to XML::Twig::BEGIN@4636 # spent 2µs making 1 call to utf8::unimport
4637 |  |  |  |  | $str =~ s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}
4638 |  |  |  |  | {_XmlUtf8Decode($1)}egs;
4639 |  |  |  |  | }
4640 |  |  |  |  | else
4641 |  |  |  |  | { $str= encode( ascii => $str, $FB_HTMLCREF); }
4642 |  |  |  |  | return $str;
4643 |  |  |  |  | }
4644 |  |  |  |  |
4645 |  |  |  |  | sub safe_encode_hex
4646 |  |  |  |  | { my $str= shift;
4647 |  |  |  |  | if( $perl_version < 5.008)
4648 |  |  |  |  | { # the no utf8 makes the regexp work in 5.6
4649 | 2 | 1.73ms | 2 | 7µs | # spent 6µs (5+1) within XML::Twig::BEGIN@4649 which was called: # once (5µs+1µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 4649 no utf8; # = perl 5.6 # spent 6µs making 1 call to XML::Twig::BEGIN@4649 # spent 1µs making 1 call to utf8::unimport
4650 |  |  |  |  | $str =~ s{([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)}
4651 |  |  |  |  | {_XmlUtf8Decode($1, 1)}egs;
4652 |  |  |  |  | }
4653 |  |  |  |  | else
4654 |  |  |  |  | { $str= encode( ascii => $str, $FB_XMLCREF); }
4655 |  |  |  |  | return $str;
4656 |  |  |  |  | }
4657 |  |  |  |  |
4658 |  |  |  |  | # this one shamelessly lifted from XML::DOM
4659 |  |  |  |  | # does NOT work on 5.8.0
4660 |  |  |  |  | sub _XmlUtf8Decode
4661 |  |  |  |  | { my ($str, $hex) = @_;
4662 |  |  |  |  | my $len = length ($str);
4663 |  |  |  |  | my $n;
4664 |  |  |  |  |
4665 |  |  |  |  | if ($len == 2)
4666 |  |  |  |  | { my @n = unpack "C2", $str;
4667 |  |  |  |  | $n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);
4668 |  |  |  |  | }
4669 |  |  |  |  | elsif ($len == 3)
4670 |  |  |  |  | { my @n = unpack "C3", $str;
4671 |  |  |  |  | $n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) + ($n[2] & 0x3f);
4672 |  |  |  |  | }
4673 |  |  |  |  | elsif ($len == 4)
4674 |  |  |  |  | { my @n = unpack "C4", $str;
4675 |  |  |  |  | $n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12)
4676 |  |  |  |  | + (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);
4677 |  |  |  |  | }
4678 |  |  |  |  | elsif ($len == 1) # just to be complete...
4679 |  |  |  |  | { $n = ord ($str); }
4680 |  |  |  |  | else
4681 |  |  |  |  | { croak "bad value [$str] for _XmlUtf8Decode"; }
4682 |  |  |  |  |
4683 |  |  |  |  | my $char= $hex ? sprintf ("&#x%x;", $n) : "&#$n;";
4684 |  |  |  |  | return $char;
4685 |  |  |  |  | }
4686 |  |  |  |  |
4687 |  |  |  |  |
4688 |  |  |  |  | sub unicode_convert
4689 |  |  |  |  | { my $enc= $_[1] ? $_[1] : $_[0]; # so the method can be called on the twig or directly
4690 |  |  |  |  | _use( 'Unicode::Map8') or croak "Unicode::Map8 not available, needed for encoding filter: $!";
4691 |  |  |  |  | _use( 'Unicode::String') or croak "Unicode::String not available, needed for encoding filter: $!";
4692 |  |  |  |  | import Unicode::String qw(utf8);
4693 |  |  |  |  | my $sub= eval qq{ { $NO_WARNINGS;
4694 |  |  |  |  | my \$cnv;
4695 |  |  |  |  | BEGIN { \$cnv= Unicode::Map8->new(\$enc)
4696 |  |  |  |  | or croak "Can't create converter to \$enc";
4697 |  |  |  |  | }
4698 |  |  |  |  | sub { return \$cnv->to8 (utf8(\$_[0])->ucs2); }
4699 |  |  |  |  | }
4700 |  |  |  |  | };
4701 |  |  |  |  | unless( $sub) { croak $@; }
4702 |  |  |  |  | return $sub;
4703 |  |  |  |  | }
4704 |  |  |  |  |
4705 |  |  |  |  | sub iconv_convert
4706 |  |  |  |  | { my $enc= $_[1] ? $_[1] : $_[0]; # so the method can be called on the twig or directly
4707 |  |  |  |  | _use( 'Text::Iconv') or croak "Text::Iconv not available, needed for encoding filter: $!";
4708 |  |  |  |  | my $sub= eval qq{ { $NO_WARNINGS;
4709 |  |  |  |  | my \$cnv;
4710 |  |  |  |  | BEGIN { \$cnv = Text::Iconv->new( 'utf8', \$enc)
4711 |  |  |  |  | or croak "Can't create iconv converter to \$enc";
4712 |  |  |  |  | }
4713 |  |  |  |  | sub { return \$cnv->convert( \$_[0]); }
4714 |  |  |  |  | }
4715 |  |  |  |  | };
4716 |  |  |  |  | unless( $sub)
4717 |  |  |  |  | { if( $@=~ m{^Unsupported conversion: Invalid argument})
4718 |  |  |  |  | { croak "Unsupported encoding: $enc"; }
4719 |  |  |  |  | else
4720 |  |  |  |  | { croak $@; }
4721 |  |  |  |  | }
4722 |  |  |  |  |
4723 |  |  |  |  | return $sub;
4724 |  |  |  |  | }
4725 |  |  |  |  |
4726 |  |  |  |  | sub encode_convert
4727 |  |  |  |  | { my $enc= $_[1] ? $_[1] : $_[0]; # so the method can be called on the twig or directly
4728 |  |  |  |  | my $sub= eval qq{sub { $NO_WARNINGS; return encode( "$enc", \$_[0]); } };
4729 |  |  |  |  | croak "can't create Encode-based filter: $@" unless( $sub);
4730 |  |  |  |  | return $sub;
4731 |  |  |  |  | }
4732 |  |  |  |  |
4733 |  |  |  |  |
4734 |  |  |  |  | # XML::XPath compatibility
4735 |  |  |  |  | sub getRootNode { return $_[0]; }
4736 |  |  |  |  | sub getParentNode { return undef; }
4737 |  |  |  |  | sub getChildNodes { my @children= ($_[0]->root); return wantarray ? @children : \@children; }
4738 |  |  |  |  |
4739 |  |  |  |  | sub _weakrefs { return $weakrefs; }
4740 |  |  |  |  | sub _set_weakrefs { $weakrefs=shift() || 0; XML::Twig::Elt::set_destroy()if ! $weakrefs; } # for testing purposes
4741 |  |  |  |  |
4742 |  |  |  |  | sub _dump
4743 |  |  |  |  | { my $t= shift;
4744 |  |  |  |  | my $dump='';
4745 |  |  |  |  |
4746 |  |  |  |  | $dump="document\n"; # should dump twig level data here
4747 |  |  |  |  | if( $t->root) { $dump .= $t->root->_dump( @_); }
4748 |  |  |  |  |
4749 |  |  |  |  | return $dump;
4750 |  |  |  |  |
4751 |  |  |  |  | }
4752 |  |  |  |  |
4753 |  |  |  |  |
4754 |  |  |  |  | 1;
4755 |  |  |  |  |
4756 |  |  |  |  | ######################################################################
4757 |  |  |  |  | package XML::Twig::Entity_list;
4758 |  |  |  |  | ######################################################################
4759 |  |  |  |  |
4760 | 1 | 800ns |  |  | *isa= *UNIVERSAL::isa;
4761 |  |  |  |  |
4762 |  |  |  |  | sub new
4763 | 7 | 1µs |  |  | # spent 13µs within XML::Twig::Entity_list::new which was called 7 times, avg 2µs/call: # 7 times (13µs+0s) by XML::Twig::new at line 742, avg 2µs/call { my $class = shift;
4764 | 7 | 6µs |  |  | my $self={ entities => {}, updated => 0};
4765 |  |  |  |  |
4766 | 7 | 2µs |  |  | bless $self, $class;
4767 | 7 | 7µs |  |  | return $self;
4768 |  |  |  |  |
4769 |  |  |  |  | }
4770 |  |  |  |  |
4771 |  |  |  |  | sub add_new_ent
4772 |  |  |  |  | { my $ent_list= shift;
4773 |  |  |  |  | my $ent= XML::Twig::Entity->new( @_);
4774 |  |  |  |  | $ent_list->add( $ent);
4775 |  |  |  |  | return $ent_list;
4776 |  |  |  |  | }
4777 |  |  |  |  |
4778 |  |  |  |  | sub _add_list
4779 |  |  |  |  | { my( $ent_list, $to_add)= @_;
4780 |  |  |  |  | my $ents_to_add= $to_add->{entities};
4781 |  |  |  |  | return $ent_list unless( $ents_to_add && %$ents_to_add);
4782 |  |  |  |  | @{$ent_list->{entities}}{keys %$ents_to_add}= values %$ents_to_add;
4783 |  |  |  |  | $ent_list->{updated}=1;
4784 |  |  |  |  | return $ent_list;
4785 |  |  |  |  | }
4786 |  |  |  |  |
4787 |  |  |  |  | sub add
4788 |  |  |  |  | { my( $ent_list, $ent)= @_;
4789 |  |  |  |  | $ent_list->{entities}->{$ent->{name}}= $ent;
4790 |  |  |  |  | $ent_list->{updated}=1;
4791 |  |  |  |  | return $ent_list;
4792 |  |  |  |  | }
4793 |  |  |  |  |
4794 |  |  |  |  | sub ent
4795 |  |  |  |  | { my( $ent_list, $ent_name)= @_;
4796 |  |  |  |  | return $ent_list->{entities}->{$ent_name};
4797 |  |  |  |  | }
4798 |  |  |  |  |
4799 |  |  |  |  | # can be called with an entity or with an entity name
4800 |  |  |  |  | sub delete
4801 |  |  |  |  | { my $ent_list= shift;
4802 |  |  |  |  | if( isa( ref $_[0], 'XML::Twig::Entity'))
4803 |  |  |  |  | { # the second arg is an entity
4804 |  |  |  |  | my $ent= shift;
4805 |  |  |  |  | delete $ent_list->{entities}->{$ent->{name}};
4806 |  |  |  |  | }
4807 |  |  |  |  | else
4808 |  |  |  |  | { # the second arg was not entity, must be a string then
4809 |  |  |  |  | my $name= shift;
4810 |  |  |  |  | delete $ent_list->{entities}->{$name};
4811 |  |  |  |  | }
4812 |  |  |  |  | $ent_list->{updated}=1;
4813 |  |  |  |  | return $ent_list;
4814 |  |  |  |  | }
4815 |  |  |  |  |
4816 |  |  |  |  | sub print
4817 |  |  |  |  | { my ($ent_list, $fh)= @_;
4818 |  |  |  |  | my $old_select= defined $fh ? select $fh : undef;
4819 |  |  |  |  |
4820 |  |  |  |  | foreach my $ent_name ( sort keys %{$ent_list->{entities}})
4821 |  |  |  |  | { my $ent= $ent_list->{entities}->{$ent_name};
4822 |  |  |  |  | # we have to test what the entity is or un-defined entities can creep in
4823 |  |  |  |  | if( isa( $ent, 'XML::Twig::Entity')) { $ent->print(); }
4824 |  |  |  |  | }
4825 |  |  |  |  | select $old_select if( defined $old_select);
4826 |  |  |  |  | return $ent_list;
4827 |  |  |  |  | }
4828 |  |  |  |  |
4829 |  |  |  |  | sub text
4830 |  |  |  |  | { my ($ent_list)= @_;
4831 |  |  |  |  | return join "\n", map { $ent_list->{entities}->{$_}->text} sort keys %{$ent_list->{entities}};
4832 |  |  |  |  | }
4833 |  |  |  |  |
4834 |  |  |  |  | # return the list of entity names
4835 |  |  |  |  | sub entity_names
4836 |  |  |  |  | { my $ent_list= shift;
4837 |  |  |  |  | return (sort keys %{$ent_list->{entities}}) ;
4838 |  |  |  |  | }
4839 |  |  |  |  |
4840 |  |  |  |  |
4841 |  |  |  |  | sub list
4842 |  |  |  |  | { my ($ent_list)= @_;
4843 |  |  |  |  | return map { $ent_list->{entities}->{$_} } sort keys %{$ent_list->{entities}};
4844 |  |  |  |  | }
4845 |  |  |  |  |
4846 |  |  |  |  | 1;
4847 |  |  |  |  |
4848 |  |  |  |  | ######################################################################
4849 |  |  |  |  | package XML::Twig::Entity;
4850 |  |  |  |  | ######################################################################
4851 |  |  |  |  |
4852 |  |  |  |  | #*isa= *UNIVERSAL::isa;
4853 |  |  |  |  |
4854 |  |  |  |  | sub new
4855 |  |  |  |  | { my( $class, $name, $val, $sysid, $pubid, $ndata, $param)= @_;
4856 |  |  |  |  | $class= ref( $class) || $class;
4857 |  |  |  |  |
4858 |  |  |  |  | my $self={};
4859 |  |  |  |  |
4860 |  |  |  |  | $self->{name} = $name;
4861 |  |  |  |  | $self->{val} = $val if( defined $val );
4862 |  |  |  |  | $self->{sysid} = $sysid if( defined $sysid);
4863 |  |  |  |  | $self->{pubid} = $pubid if( defined $pubid);
4864 |  |  |  |  | $self->{ndata} = $ndata if( defined $ndata);
4865 |  |  |  |  | $self->{param} = $param if( defined $param);
4866 |  |  |  |  |
4867 |  |  |  |  | bless $self, $class;
4868 |  |  |  |  | return $self;
4869 |  |  |  |  | }
4870 |  |  |  |  |
4871 |  |  |  |  |
4872 |  |  |  |  | sub name { return $_[0]->{name}; }
4873 |  |  |  |  | sub val { return $_[0]->{val}; }
4874 |  |  |  |  | sub sysid { return defined( $_[0]->{sysid}) ? $_[0]->{sysid} : ''; }
4875 |  |  |  |  | sub pubid { return defined( $_[0]->{pubid}) ? $_[0]->{pubid} : ''; }
4876 |  |  |  |  | sub ndata { return defined( $_[0]->{ndata}) ? $_[0]->{ndata} : ''; }
4877 |  |  |  |  | sub param { return defined( $_[0]->{param}) ? $_[0]->{param} : ''; }
4878 |  |  |  |  |
4879 |  |  |  |  |
4880 |  |  |  |  | sub print
4881 |  |  |  |  | { my ($ent, $fh)= @_;
4882 |  |  |  |  | my $text= $ent->text;
4883 |  |  |  |  | if( $fh) { print $fh $text . "\n"; }
4884 |  |  |  |  | else { print $text . "\n"; }
4885 |  |  |  |  | }
4886 |  |  |  |  |
4887 |  |  |  |  | sub sprint
4888 |  |  |  |  | { my ($ent)= @_;
4889 |  |  |  |  | return $ent->text;
4890 |  |  |  |  | }
4891 |  |  |  |  |
4892 |  |  |  |  | sub text
4893 |  |  |  |  | { my ($ent)= @_;
4894 |  |  |  |  | #warn "text called: '", $ent->_dump, "'\n";
4895 |  |  |  |  | return '' if( !$ent->{name});
4896 |  |  |  |  | my @tokens;
4897 |  |  |  |  | push @tokens, '<!ENTITY';
4898 |  |  |  |  |
4899 |  |  |  |  | push @tokens, '%' if( $ent->{param});
4900 |  |  |  |  | push @tokens, $ent->{name};
4901 |  |  |  |  |
4902 |  |  |  |  | if( defined $ent->{val} && !defined( $ent->{sysid}) && !defined($ent->{pubid}) )
4903 |  |  |  |  | { push @tokens, _quoted_val( $ent->{val});
4904 |  |  |  |  | }
4905 |  |  |  |  | elsif( defined $ent->{sysid})
4906 |  |  |  |  | { push @tokens, 'PUBLIC', _quoted_val( $ent->{pubid}) if( $ent->{pubid});
4907 |  |  |  |  | push @tokens, 'SYSTEM' unless( $ent->{pubid});
4908 |  |  |  |  | push @tokens, _quoted_val( $ent->{sysid});
4909 |  |  |  |  | push @tokens, 'NDATA', $ent->{ndata} if( $ent->{ndata});
4910 |  |  |  |  | }
4911 |  |  |  |  | return join( ' ', @tokens) . '>';
4912 |  |  |  |  | }
4913 |  |  |  |  |
4914 |  |  |  |  | sub _quoted_val
4915 |  |  |  |  | { my $q= $_[0]=~ m{"} ? q{'} : q{"};
4916 |  |  |  |  | return qq{$q$_[0]$q};
4917 |  |  |  |  | }
4918 |  |  |  |  |
4919 |  |  |  |  | sub _dump
4920 |  |  |  |  | { my( $ent)= @_; return join( " - ", map { "$_ => '$ent->{$_}'" } grep { defined $ent->{$_} } sort keys %$ent); }
4921 |  |  |  |  |
4922 |  |  |  |  | 1;
4923 |  |  |  |  |
4924 |  |  |  |  | ######################################################################
4925 |  |  |  |  | package XML::Twig::Notation_list;
4926 |  |  |  |  | ######################################################################
4927 |  |  |  |  |
4928 | 1 | 200ns |  |  | *isa= *UNIVERSAL::isa;
4929 |  |  |  |  |
4930 |  |  |  |  | sub new
4931 | 7 | 1µs |  |  | # spent 10µs within XML::Twig::Notation_list::new which was called 7 times, avg 1µs/call: # 7 times (10µs+0s) by XML::Twig::new at line 743, avg 1µs/call { my $class = shift;
4932 | 7 | 4µs |  |  | my $self={ notations => {}, updated => 0};
4933 |  |  |  |  |
4934 | 7 | 1µs |  |  | bless $self, $class;
4935 | 7 | 6µs |  |  | return $self;
4936 |  |  |  |  |
4937 |  |  |  |  | }
4938 |  |  |  |  |
4939 |  |  |  |  | sub add_new_notation
4940 |  |  |  |  | { my $notation_list= shift;
4941 |  |  |  |  | my $notation= XML::Twig::Notation->new( @_);
4942 |  |  |  |  | $notation_list->add( $notation);
4943 |  |  |  |  | return $notation_list;
4944 |  |  |  |  | }
4945 |  |  |  |  |
4946 |  |  |  |  | sub _add_list
4947 |  |  |  |  | { my( $notation_list, $to_add)= @_;
4948 |  |  |  |  | my $notations_to_add= $to_add->{notations};
4949 |  |  |  |  | return $notation_list unless( $notations_to_add && %$notations_to_add);
4950 |  |  |  |  | @{$notation_list->{notations}}{keys %$notations_to_add}= values %$notations_to_add;
4951 |  |  |  |  | $notation_list->{updated}=1;
4952 |  |  |  |  | return $notation_list;
4953 |  |  |  |  | }
4954 |  |  |  |  |
4955 |  |  |  |  | sub add
4956 |  |  |  |  | { my( $notation_list, $notation)= @_;
4957 |  |  |  |  | $notation_list->{notations}->{$notation->{name}}= $notation;
4958 |  |  |  |  | $notation_list->{updated}=1;
4959 |  |  |  |  | return $notation_list;
4960 |  |  |  |  | }
4961 |  |  |  |  |
4962 |  |  |  |  | sub notation
4963 |  |  |  |  | { my( $notation_list, $notation_name)= @_;
4964 |  |  |  |  | return $notation_list->{notations}->{$notation_name};
4965 |  |  |  |  | }
4966 |  |  |  |  |
4967 |  |  |  |  | # can be called with an notation or with an notation name
4968 |  |  |  |  | sub delete
4969 |  |  |  |  | { my $notation_list= shift;
4970 |  |  |  |  | if( isa( ref $_[0], 'XML::Twig::Notation'))
4971 |  |  |  |  | { # the second arg is an notation
4972 |  |  |  |  | my $notation= shift;
4973 |  |  |  |  | delete $notation_list->{notations}->{$notation->{name}};
4974 |  |  |  |  | }
4975 |  |  |  |  | else
4976 |  |  |  |  | { # the second arg was not notation, must be a string then
4977 |  |  |  |  | my $name= shift;
4978 |  |  |  |  | delete $notation_list->{notations}->{$name};
4979 |  |  |  |  | }
4980 |  |  |  |  | $notation_list->{updated}=1;
4981 |  |  |  |  | return $notation_list;
4982 |  |  |  |  | }
4983 |  |  |  |  |
4984 |  |  |  |  | sub print
4985 |  |  |  |  | { my ($notation_list, $fh)= @_;
4986 |  |  |  |  | my $old_select= defined $fh ? select $fh : undef;
4987 |  |  |  |  |
4988 |  |  |  |  | foreach my $notation_name ( sort keys %{$notation_list->{notations}})
4989 |  |  |  |  | { my $notation= $notation_list->{notations}->{$notation_name};
4990 |  |  |  |  | # we have to test what the notation is or un-defined notations can creep in
4991 |  |  |  |  | if( isa( $notation, 'XML::Twig::Notation')) { $notation->print(); }
4992 |  |  |  |  | }
4993 |  |  |  |  | select $old_select if( defined $old_select);
4994 |  |  |  |  | return $notation_list;
4995 |  |  |  |  | }
4996 |  |  |  |  |
4997 |  |  |  |  | sub text
4998 |  |  |  |  | { my ($notation_list)= @_;
4999 |  |  |  |  | return join "\n", map { $notation_list->{notations}->{$_}->text} sort keys %{$notation_list->{notations}};
5000 |  |  |  |  | }
5001 |  |  |  |  |
5002 |  |  |  |  | # return the list of notation names
5003 |  |  |  |  | sub notation_names
5004 |  |  |  |  | { my $notation_list= shift;
5005 |  |  |  |  | return (sort keys %{$notation_list->{notations}}) ;
5006 |  |  |  |  | }
5007 |  |  |  |  |
5008 |  |  |  |  |
5009 |  |  |  |  | sub list
5010 |  |  |  |  | { my ($notation_list)= @_;
5011 |  |  |  |  | return map { $notation_list->{notations}->{$_} } sort keys %{$notation_list->{notations}};
5012 |  |  |  |  | }
5013 |  |  |  |  |
5014 |  |  |  |  | 1;
5015 |  |  |  |  |
5016 |  |  |  |  | ######################################################################
5017 |  |  |  |  | package XML::Twig::Notation;
5018 |  |  |  |  | ######################################################################
5019 |  |  |  |  |
5020 |  |  |  |  | #*isa= *UNIVERSAL::isa;
5021 |  |  |  |  |
5022 |  |  |  |  | BEGIN
5023 | 1 | 4µs |  |  | # spent 3µs within XML::Twig::Notation::BEGIN@5023 which was called: # once (3µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 5024 { *sprint= *text;
5024 | 1 | 313µs | 1 | 3µs | } # spent 3µs making 1 call to XML::Twig::Notation::BEGIN@5023
5025 |  |  |  |  |
5026 |  |  |  |  | sub new
5027 |  |  |  |  | { my( $class, $name, $base, $sysid, $pubid)= @_;
5028 |  |  |  |  | $class= ref( $class) || $class;
5029 |  |  |  |  |
5030 |  |  |  |  | my $self={};
5031 |  |  |  |  |
5032 |  |  |  |  | $self->{name} = $name;
5033 |  |  |  |  | $self->{base} = $base if( defined $base );
5034 |  |  |  |  | $self->{sysid} = $sysid if( defined $sysid);
5035 |  |  |  |  | $self->{pubid} = $pubid if( defined $pubid);
5036 |  |  |  |  |
5037 |  |  |  |  | bless $self, $class;
5038 |  |  |  |  | return $self;
5039 |  |  |  |  | }
5040 |  |  |  |  |
5041 |  |  |  |  |
5042 |  |  |  |  | sub name { return $_[0]->{name}; }
5043 |  |  |  |  | sub base { return $_[0]->{base}; }
5044 |  |  |  |  | sub sysid { return $_[0]->{sysid}; }
5045 |  |  |  |  | sub pubid { return $_[0]->{pubid}; }
5046 |  |  |  |  |
5047 |  |  |  |  |
5048 |  |  |  |  | sub print
5049 |  |  |  |  | { my ($notation, $fh)= @_;
5050 |  |  |  |  | my $text= $notation->text;
5051 |  |  |  |  | if( $fh) { print $fh $text . "\n"; }
5052 |  |  |  |  | else { print $text . "\n"; }
5053 |  |  |  |  | }
5054 |  |  |  |  |
5055 |  |  |  |  | sub text
5056 |  |  |  |  | { my ($notation)= @_;
5057 |  |  |  |  | return '' if( !$notation->{name});
5058 |  |  |  |  | my @tokens;
5059 |  |  |  |  | push @tokens, '<!NOTATION';
5060 |  |  |  |  | push @tokens, $notation->{name};
5061 |  |  |  |  | push @tokens, ( 'PUBLIC', _quoted_val( $notation->{pubid} ) ) if $notation->{pubid};
5062 |  |  |  |  | push @tokens, ( 'SYSTEM') if ! $notation->{pubid} && $notation->{sysid};
5063 |  |  |  |  | push @tokens, (_quoted_val( $notation->{sysid}) ) if $notation->{sysid};
5064 |  |  |  |  |
5065 |  |  |  |  | return join( ' ', @tokens) . '>';
5066 |  |  |  |  | }
5067 |  |  |  |  |
5068 |  |  |  |  | sub _quoted_val
5069 |  |  |  |  | { my $q= $_[0]=~ m{"} ? q{'} : q{"};
5070 |  |  |  |  | return qq{$q$_[0]$q};
5071 |  |  |  |  | }
5072 |  |  |  |  |
5073 |  |  |  |  | sub _dump
5074 |  |  |  |  | { my( $notation)= @_; return join( " - ", map { "$_ => '$notation->{$_}'" } grep { defined $notation->{$_} } sort keys %$notation); }
5075 |  |  |  |  |
5076 |  |  |  |  | 1;
5077 |  |  |  |  |
5078 |  |  |  |  | ######################################################################
5079 |  |  |  |  | package XML::Twig::Elt;
5080 |  |  |  |  | ######################################################################
5081 |  |  |  |  |
5082 | 2 | 253µs | 2 | 54µs | # spent 31µs (7+24) within XML::Twig::Elt::BEGIN@5082 which was called: # once (7µs+24µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 5082 use Carp; # spent 31µs making 1 call to XML::Twig::Elt::BEGIN@5082 # spent 24µs making 1 call to Exporter::import
5083 | 1 | 200ns |  |  | *isa= *UNIVERSAL::isa;
5084 |  |  |  |  |
5085 | 1 | 200ns |  |  | my $CDATA_START = "<![CDATA[";
5086 | 1 | 100ns |  |  | my $CDATA_END = "]]>";
5087 | 1 | 100ns |  |  | my $PI_START = "<?";
5088 | 1 | 100ns |  |  | my $PI_END = "?>";
5089 | 1 | 100ns |  |  | my $COMMENT_START = "<!--";
5090 | 1 | 100ns |  |  | my $COMMENT_END = "-->";
5091 |  |  |  |  |
5092 | 1 | 100ns |  |  | my $XMLNS_URI = 'http://www.w3.org/2000/xmlns/';
5093 |  |  |  |  |
5094 |  |  |  |  |
5095 |  |  |  |  | BEGIN
5096 |  |  |  |  | # spent 49µs (33+16) within XML::Twig::Elt::BEGIN@5096 which was called: # once (33µs+16µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 5162 { # set some aliases for methods
5097 | 1 | 700ns |  |  | *tag = *gi;
5098 | 1 | 200ns |  |  | *name = *gi;
5099 | 1 | 100ns |  |  | *set_tag = *set_gi;
5100 | 1 | 100ns |  |  | *set_name = *set_gi;
5101 | 1 | 100ns |  |  | *find_nodes = *get_xpath; # as in XML::DOM
5102 | 1 | 100ns |  |  | *findnodes = *get_xpath; # as in XML::LibXML
5103 | 1 | 100ns |  |  | *field = *first_child_text;
5104 | 1 | 200ns |  |  | *trimmed_field = *first_child_trimmed_text;
5105 | 1 | 100ns |  |  | *is_field = *contains_only_text;
5106 | 1 | 100ns |  |  | *is = *passes;
5107 | 1 | 100ns |  |  | *matches = *passes;
5108 | 1 | 100ns |  |  | *has_child = *first_child;
5109 | 1 | 100ns |  |  | *has_children = *first_child;
5110 | 1 | 100ns |  |  | *all_children_pass = *all_children_are;
5111 | 1 | 100ns |  |  | *all_children_match= *all_children_are;
5112 | 1 | 200ns |  |  | *getElementsByTagName= *descendants;
5113 | 1 | 100ns |  |  | *find_by_tag_name= *descendants_or_self;
5114 | 1 | 100ns |  |  | *unwrap = *erase;
5115 | 1 | 200ns |  |  | *inner_xml = *xml_string;
5116 | 1 | 100ns |  |  | *outer_xml = *sprint;
5117 | 1 | 100ns |  |  | *add_class = *add_to_class;
5118 |  |  |  |  |
5119 | 1 | 200ns |  |  | *first_child_is = *first_child_matches;
5120 | 1 | 100ns |  |  | *last_child_is = *last_child_matches;
5121 | 1 | 100ns |  |  | *next_sibling_is = *next_sibling_matches;
5122 | 1 | 200ns |  |  | *prev_sibling_is = *prev_sibling_matches;
5123 | 1 | 100ns |  |  | *next_elt_is = *next_elt_matches;
5124 | 1 | 100ns |  |  | *prev_elt_is = *prev_elt_matches;
5125 | 1 | 100ns |  |  | *parent_is = *parent_matches;
5126 | 1 | 100ns |  |  | *child_is = *child_matches;
5127 | 1 | 100ns |  |  | *inherited_att = *inherit_att;
5128 |  |  |  |  |
5129 | 1 | 100ns |  |  | *sort_children_by_value= *sort_children_on_value;
5130 |  |  |  |  |
5131 | 1 | 200ns |  |  | *has_atts= *att_nb;
5132 |  |  |  |  |
5133 |  |  |  |  | # imports from XML::Twig
5134 | 1 | 400ns |  |  | *_is_fh= *XML::Twig::_is_fh;
5135 |  |  |  |  |
5136 |  |  |  |  | # XML::XPath compatibility
5137 | 1 | 100ns |  |  | *string_value = *text;
5138 | 1 | 100ns |  |  | *toString = *sprint;
5139 | 1 | 100ns |  |  | *getName = *gi;
5140 | 1 | 100ns |  |  | *getRootNode = *twig;
5141 | 1 | 200ns |  |  | *getNextSibling = *_next_sibling;
5142 | 1 | 100ns |  |  | *getPreviousSibling = *_prev_sibling;
5143 | 1 | 100ns |  |  | *isElementNode = *is_elt;
5144 | 1 | 100ns |  |  | *isTextNode = *is_text;
5145 | 1 | 100ns |  |  | *isPI = *is_pi;
5146 | 1 | 100ns |  |  | *isPINode = *is_pi;
5147 | 1 | 100ns |  |  | *isProcessingInstructionNode= *is_pi;
5148 | 1 | 100ns |  |  | *isComment = *is_comment;
5149 | 1 | 100ns |  |  | *isCommentNode = *is_comment;
5150 | 1 | 100ns |  |  | *getTarget = *target;
5151 | 1 | 200ns |  |  | *getFirstChild = *_first_child;
5152 | 1 | 100ns |  |  | *getLastChild = *_last_child;
5153 |  |  |  |  |
5154 |  |  |  |  | # try using weak references
5155 |  |  |  |  | # test whether we can use weak references
5156 | 2 | 3µs |  |  | { local $SIG{__DIE__};
5157 | 1 | 19µs | 1 | 16µs | if( eval 'require Scalar::Util' && defined( &Scalar::Util::weaken) ) # spent 16µs making 1 call to Exporter::import # spent 2µs executing statements in string eval
5158 |  |  |  |  | { import Scalar::Util qw(weaken); }
5159 |  |  |  |  | elsif( eval 'require WeakRef')
5160 |  |  |  |  | { import WeakRef; }
5161 |  |  |  |  | }
5162 | 1 | 5.55ms | 1 | 49µs | } # spent 49µs making 1 call to XML::Twig::Elt::BEGIN@5096
5163 |  |  |  |  |
5164 |  |  |  |  |
5165 |  |  |  |  | # can be called as XML::Twig::Elt->new( [[$gi, $atts, [@content]])
5166 |  |  |  |  | # - gi is an optional gi given to the element
5167 |  |  |  |  | # - $atts is a hashref to attributes for the element
5168 |  |  |  |  | # - @content is an optional list of text and elements that will
5169 |  |  |  |  | # be inserted under the element
5170 |  |  |  |  | sub new
5171 | 364369 | 55.7ms |  |  | # spent 1.82s (1.71+110ms) within XML::Twig::Elt::new which was called 364369 times, avg 5µs/call: # 364369 times (1.71s+110ms) by XML::Twig::_twig_start at line 2079, avg 5µs/call { my $class= shift;
5172 | 364369 | 70.5ms |  |  | $class= ref $class || $class;
5173 | 364369 | 28.0ms |  |  | my $elt = {};
5174 | 364369 | 69.0ms |  |  | bless ($elt, $class);
5175 |  |  |  |  |
5176 | 364369 | 45.0ms |  |  | return $elt unless @_;
5177 |  |  |  |  |
5178 | 364369 | 657ms | 364369 | 110ms | if( @_ == 1 && $_[0]=~ m{^\s*<}) { return $class->parse( @_); } # spent 110ms making 364369 calls to CORE::match, avg 301ns/call
5179 |  |  |  |  |
5180 |  |  |  |  | # if a gi is passed then use it
5181 | 364369 | 57.1ms |  |  | my $gi= shift;
5182 | 364369 | 170ms | 117 | 242µs | $elt->{gi}=$XML::Twig::gi2index{$gi} or $elt->set_gi( $gi); # spent 242µs making 117 calls to XML::Twig::Elt::set_gi, avg 2µs/call
5183 |  |  |  |  |
5184 |  |  |  |  |
5185 | 364369 | 92.5ms |  |  | my $atts= ref $_[0] eq 'HASH' ? shift : undef;
5186 |  |  |  |  |
5187 | 364369 | 42.6ms |  |  | if( $atts && defined $atts->{$CDATA})
5188 |  |  |  |  | { delete $atts->{$CDATA};
5189 |  |  |  |  |
5190 |  |  |  |  | my $cdata= $class->new( $CDATA => @_);
5191 |  |  |  |  | return $class->new( $gi, $atts, $cdata);
5192 |  |  |  |  | }
5193 |  |  |  |  |
5194 | 364369 | 183ms |  |  | if( $gi eq $PCDATA)
5195 |  |  |  |  | { if( grep { ref $_ } @_) { croak "element $PCDATA can only be created from text"; }
5196 |  |  |  |  | $elt->{pcdata}= join '', @_;
5197 |  |  |  |  | }
5198 |  |  |  |  | elsif( $gi eq $ENT)
5199 |  |  |  |  | { $elt->{ent}= shift; }
5200 |  |  |  |  | elsif( $gi eq $CDATA)
5201 |  |  |  |  | { if( grep { ref $_ } @_) { croak "element $CDATA can only be created from text"; }
5202 |  |  |  |  | $elt->{cdata}= join '', @_;
5203 |  |  |  |  | }
5204 |  |  |  |  | elsif( $gi eq $COMMENT)
5205 |  |  |  |  | { if( grep { ref $_ } @_) { croak "element $COMMENT can only be created from text"; }
5206 |  |  |  |  | $elt->{comment}= join '', @_;
5207 |  |  |  |  | }
5208 |  |  |  |  | elsif( $gi eq $PI)
5209 |  |  |  |  | { if( grep { ref $_ } @_) { croak "element $PI can only be created from text"; }
5210 |  |  |  |  | $elt->_set_pi( shift, join '', @_);
5211 |  |  |  |  | }
5212 |  |  |  |  | else
5213 |  |  |  |  | { # the rest of the arguments are the content of the element
5214 | 364369 | 73.9ms |  |  | if( @_)
5215 |  |  |  |  | { $elt->set_content( @_); }
5216 |  |  |  |  | else
5217 | 364369 | 79.0ms |  |  | { $elt->{empty}= 1; }
5218 |  |  |  |  | }
5219 |  |  |  |  |
5220 | 364369 | 31.5ms |  |  | if( $atts)
5221 |  |  |  |  | { # the attribute hash can be used to pass the asis status
5222 |  |  |  |  | if( defined $atts->{$ASIS}) { $elt->set_asis( $atts->{$ASIS} ); delete $atts->{$ASIS}; }
5223 |  |  |  |  | if( defined $atts->{$EMPTY}) { $elt->{empty}= $atts->{$EMPTY}; delete $atts->{$EMPTY}; }
5224 |  |  |  |  | if( keys %$atts) { $elt->set_atts( $atts); }
5225 |  |  |  |  | $elt->_set_id( $atts->{$ID}) if( $atts->{$ID});
5226 |  |  |  |  | }
5227 |  |  |  |  |
5228 | 364369 | 679ms |  |  | return $elt;
5229 |  |  |  |  | }
5230 |  |  |  |  |
5231 |  |  |  |  | # optimized version of $elt->new( PCDATA, $text);
5232 |  |  |  |  | sub _new_pcdata
5233 |  |  |  |  | { my $class= $_[0];
5234 |  |  |  |  | $class= ref $class || $class;
5235 |  |  |  |  | my $elt = {};
5236 |  |  |  |  | bless $elt, $class;
5237 |  |  |  |  | $elt->{gi}=$XML::Twig::gi2index{$PCDATA} or $elt->set_gi( $PCDATA);
5238 |  |  |  |  | $elt->{pcdata}= $_[1];
5239 |  |  |  |  | return $elt;
5240 |  |  |  |  | }
5241 |  |  |  |  |
5242 |  |  |  |  | # this function creates an XM:::Twig::Elt from a string
5243 |  |  |  |  | # it is quite clumsy at the moment, as it just creates a
5244 |  |  |  |  | # new twig then returns its root
5245 |  |  |  |  | # there might also be memory leaks there
5246 |  |  |  |  | # additional arguments are passed to new XML::Twig
5247 |  |  |  |  | sub parse
5248 |  |  |  |  | { my $class= shift;
5249 |  |  |  |  | if( ref( $class)) { $class= ref( $class); }
5250 |  |  |  |  | my $string= shift;
5251 |  |  |  |  | my %args= @_;
5252 |  |  |  |  | my $t= XML::Twig->new(%args);
5253 |  |  |  |  | $t->parse( $string);
5254 |  |  |  |  | my $elt= $t->root;
5255 |  |  |  |  | # clean-up the node
5256 |  |  |  |  | delete $elt->{twig}; # get rid of the twig data
5257 |  |  |  |  | delete $elt->{twig_current}; # better get rid of this too
5258 |  |  |  |  | if( $t->{twig_id_list}) { $elt->{twig_id_list}= $t->{twig_id_list}; }
5259 |  |  |  |  | $elt->cut;
5260 |  |  |  |  | undef $t->{twig_root};
5261 |  |  |  |  | return $elt;
5262 |  |  |  |  | }
5263 |  |  |  |  |
5264 |  |  |  |  | sub set_inner_xml
5265 |  |  |  |  | { my( $elt, $xml, @args)= @_;
5266 |  |  |  |  | my $new_elt= $elt->parse( "<dummy>$xml</dummy>", @args);
5267 |  |  |  |  | $elt->cut_children;
5268 |  |  |  |  | $new_elt->paste_first_child( $elt);
5269 |  |  |  |  | $new_elt->erase;
5270 |  |  |  |  | return $elt;
5271 |  |  |  |  | }
5272 |  |  |  |  |
5273 |  |  |  |  | sub set_outer_xml
5274 |  |  |  |  | { my( $elt, $xml, @args)= @_;
5275 |  |  |  |  | my $new_elt= $elt->parse( "<dummy>$xml</dummy>", @args);
5276 |  |  |  |  | $elt->cut_children;
5277 |  |  |  |  | $new_elt->replace( $elt);
5278 |  |  |  |  | $new_elt->erase;
5279 |  |  |  |  | return $new_elt;
5280 |  |  |  |  | }
5281 |  |  |  |  |
5282 |  |  |  |  |
5283 |  |  |  |  | sub set_inner_html
5284 |  |  |  |  | { my( $elt, $html)= @_;
5285 |  |  |  |  | my $t= XML::Twig->new->parse_html( "<html>$html</html>");
5286 |  |  |  |  | my $new_elt= $t->root;
5287 |  |  |  |  | if( $elt->tag eq 'head')
5288 |  |  |  |  | { $new_elt->first_child( 'head')->unwrap;
5289 |  |  |  |  | $new_elt->first_child( 'body')->cut;
5290 |  |  |  |  | }
5291 |  |  |  |  | elsif( $elt->tag ne 'html')
5292 |  |  |  |  | { $new_elt->first_child( 'head')->cut;
5293 |  |  |  |  | $new_elt->first_child( 'body')->unwrap;
5294 |  |  |  |  | }
5295 |  |  |  |  | $new_elt->cut;
5296 |  |  |  |  | $elt->cut_children;
5297 |  |  |  |  | $new_elt->paste_first_child( $elt);
5298 |  |  |  |  | $new_elt->erase;
5299 |  |  |  |  | return $elt;
5300 |  |  |  |  | }
5301 |  |  |  |  |
5302 |  |  |  |  | sub set_gi
5303 | 117 | 22µs |  |  | # spent 242µs within XML::Twig::Elt::set_gi which was called 117 times, avg 2µs/call: # 117 times (242µs+0s) by XML::Twig::Elt::new at line 5182, avg 2µs/call { my ($elt, $gi)= @_;
5304 | 117 | 38µs |  |  | unless( defined $XML::Twig::gi2index{$gi})
5305 |  |  |  |  | { # new gi, create entries in %gi2index and @index2gi
5306 | 117 | 39µs |  |  | push @XML::Twig::index2gi, $gi;
5307 | 117 | 72µs |  |  | $XML::Twig::gi2index{$gi}= $#XML::Twig::index2gi;
5308 |  |  |  |  | }
5309 | 117 | 29µs |  |  | $elt->{gi}= $XML::Twig::gi2index{$gi};
5310 | 117 | 91µs |  |  | return $elt;
5311 |  |  |  |  | }
5312 |  |  |  |  |
5313 | 127487 | 249ms |  |  | # spent 64.6ms within XML::Twig::Elt::gi which was called 127487 times, avg 507ns/call: # 127276 times (64.5ms+0s) by XML::Twig::Elt::__ANON__[(eval 128)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 128)[XML/Twig.pm:5871], avg 507ns/call # 103 times (30µs+0s) by XML::Twig::Elt::__ANON__[(eval 86)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 86)[XML/Twig.pm:5871], avg 286ns/call # 28 times (8µs+0s) by XML::Twig::Elt::__ANON__[(eval 91)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 91)[XML/Twig.pm:5871], avg 268ns/call # 15 times (10µs+0s) by Spreadsheet::ParseXLSX::_get_text_and_rich_font_by_cell at line 583 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 660ns/call # 14 times (5µs+0s) by XML::Twig::Elt::__ANON__[(eval 90)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 90)[XML/Twig.pm:5871], avg 336ns/call # 14 times (5µs+0s) by XML::Twig::Elt::__ANON__[(eval 95)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 95)[XML/Twig.pm:5871], avg 336ns/call # 14 times (4µs+0s) by XML::Twig::Elt::__ANON__[(eval 96)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 96)[XML/Twig.pm:5871], avg 271ns/call # 12 times (4µs+0s) by Spreadsheet::ParseXLSX::_parse_themes at line 672 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 292ns/call # 6 times (8µs+0s) by XML::Twig::Elt::is_elt at line 5418, avg 1µs/call # 5 times (2µs+0s) by XML::Twig::Elt::__ANON__[(eval 101)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:5871]:1] at line 1 of (eval 101)[XML/Twig.pm:5871], avg 440ns/call sub gi { return $XML::Twig::index2gi[$_[0]->{gi}]; }
5314 |  |  |  |  |
5315 |  |  |  |  | sub local_name
5316 |  |  |  |  | { my $elt= shift;
5317 |  |  |  |  | return _local_name( $XML::Twig::index2gi[$elt->{'gi'}]);
5318 |  |  |  |  | }
5319 |  |  |  |  |
5320 |  |  |  |  | sub ns_prefix
5321 |  |  |  |  | { my $elt= shift;
5322 |  |  |  |  | return _ns_prefix( $XML::Twig::index2gi[$elt->{'gi'}]);
5323 |  |  |  |  | }
5324 |  |  |  |  |
5325 |  |  |  |  | # namespace prefix for any qname (can be used for elements or attributes)
5326 |  |  |  |  | sub _ns_prefix
5327 |  |  |  |  | { my $qname= shift;
5328 |  |  |  |  | if( $qname=~ m{^([^:]*):})
5329 |  |  |  |  | { return $1; }
5330 |  |  |  |  | else
5331 |  |  |  |  | { return( ''); } # should it be '' ?
5332 |  |  |  |  | }
5333 |  |  |  |  |
5334 |  |  |  |  | # local name for any qname (can be used for elements or attributes)
5335 |  |  |  |  | sub _local_name
5336 |  |  |  |  | { my $qname= shift;
5337 |  |  |  |  | (my $local= $qname)=~ s{^[^:]*:}{};
5338 |  |  |  |  | return $local;
5339 |  |  |  |  | }
5340 |  |  |  |  |
5341 |  |  |  |  | #sub get_namespace
5342 |  |  |  |  | sub namespace ## no critic (Subroutines::ProhibitNestedSubs);
5343 |  |  |  |  | { my $elt= shift;
5344 |  |  |  |  | my $prefix= defined $_[0] ? shift() : $elt->ns_prefix;
5345 |  |  |  |  | my $ns_att= $prefix ? "xmlns:$prefix" : "xmlns";
5346 |  |  |  |  | my $expanded= $DEFAULT_NS{$prefix} || $elt->_inherit_att_through_cut( $ns_att) || '';
5347 |  |  |  |  | return $expanded;
5348 |  |  |  |  | }
5349 |  |  |  |  |
5350 |  |  |  |  | sub declare_missing_ns ## no critic (Subroutines::ProhibitNestedSubs);
5351 |  |  |  |  | { my $root= shift;
5352 |  |  |  |  | my %missing_prefix;
5353 |  |  |  |  | my $map= $root->_current_ns_prefix_map;
5354 |  |  |  |  |
5355 |  |  |  |  | foreach my $prefix (keys %$map)
5356 |  |  |  |  | { my $prefix_att= $prefix eq '#default' ? 'xmlns' : "xmlns:$prefix";
5357 |  |  |  |  | if( ! $root->{'att'}->{$prefix_att})
5358 |  |  |  |  | { $root->set_att( $prefix_att => $map->{$prefix}); }
5359 |  |  |  |  | }
5360 |  |  |  |  | return $root;
5361 |  |  |  |  | }
5362 |  |  |  |  |
5363 |  |  |  |  | sub _current_ns_prefix_map
5364 |  |  |  |  | { my( $elt)= shift;
5365 |  |  |  |  | my $map;
5366 |  |  |  |  | while( $elt)
5367 |  |  |  |  | { foreach my $att ($elt->att_names)
5368 |  |  |  |  | { my $prefix= $att eq 'xmlns' ? '#default'
5369 |  |  |  |  | : $att=~ m{^xmlns:(.*)$} ? $1
5370 |  |  |  |  | : next
5371 |  |  |  |  | ;
5372 |  |  |  |  | if( ! exists $map->{$prefix}) { $map->{$prefix}= $elt->{'att'}->{$att}; }
5373 |  |  |  |  | }
5374 |  |  |  |  | $elt= $elt->{parent} || ($elt->{former} && $elt->{former}->{parent});
5375 |  |  |  |  | }
5376 |  |  |  |  | return $map;
5377 |  |  |  |  | }
5378 |  |  |  |  |
5379 |  |  |  |  | sub set_ns_decl
5380 |  |  |  |  | { my( $elt, $uri, $prefix)= @_;
5381 |  |  |  |  | my $ns_att= $prefix ? "xmlns:$prefix" : 'xmlns';
5382 |  |  |  |  | $elt->set_att( $ns_att => $uri);
5383 |  |  |  |  | return $elt;
5384 |  |  |  |  | }
5385 |  |  |  |  |
5386 |  |  |  |  | sub set_ns_as_default
5387 |  |  |  |  | { my( $root, $uri)= @_;
5388 |  |  |  |  | my @ns_decl_to_remove;
5389 |  |  |  |  | foreach my $elt ($root->descendants_or_self)
5390 |  |  |  |  | { if( $elt->_ns_prefix && $elt->namespace eq $uri)
5391 |  |  |  |  | { $elt->set_tag( $elt->local_name); }
5392 |  |  |  |  | # store any namespace declaration for that uri
5393 |  |  |  |  | foreach my $ns_decl (grep { $_=~ m{xmlns(:|$)} && $elt->{'att'}->{$_} eq $uri } $elt->att_names)
5394 |  |  |  |  | { push @ns_decl_to_remove, [$elt, $ns_decl]; }
5395 |  |  |  |  | }
5396 |  |  |  |  | $root->set_ns_decl( $uri);
5397 |  |  |  |  | # now remove the ns declarations (if done earlier then descendants of an element with the ns declaration
5398 |  |  |  |  | # are not considered being in the namespace
5399 |  |  |  |  | foreach my $ns_decl_to_remove ( @ns_decl_to_remove)
5400 |  |  |  |  | { my( $elt, $ns_decl)= @$ns_decl_to_remove;
5401 |  |  |  |  | $elt->del_att( $ns_decl);
5402 |  |  |  |  | }
5403 |  |  |  |  |
5404 |  |  |  |  | return $root;
5405 |  |  |  |  | }
5406 |  |  |  |  |
5407 |  |  |  |  |
5408 |  |  |  |  |
5409 |  |  |  |  | # return #ELT for an element and #PCDATA... for others
5410 |  |  |  |  | sub get_type
5411 |  |  |  |  | { my $gi_nb= $_[0]->{gi}; # the number, not the string
5412 |  |  |  |  | return $ELT if( $gi_nb >= $XML::Twig::SPECIAL_GI);
5413 |  |  |  |  | return $_[0]->gi;
5414 |  |  |  |  | }
5415 |  |  |  |  |
5416 |  |  |  |  | # return the gi if it's a "real" element, 0 otherwise
5417 |  |  |  |  | sub is_elt
5418 | 6 | 16µs | 6 | 8µs | # spent 26µs (18+8) within XML::Twig::Elt::is_elt which was called 6 times, avg 4µs/call: # 6 times (18µs+8µs) by XML::Twig::Elt::cut at line 7171, avg 4µs/call { if( $_[0]->{gi} >= $XML::Twig::SPECIAL_GI) # spent 8µs making 6 calls to XML::Twig::Elt::gi, avg 1µs/call
5419 |  |  |  |  | { return $_[0]->gi; }
5420 |  |  |  |  | else
5421 |  |  |  |  | { return 0; }
5422 |  |  |  |  | }
5423 |  |  |  |  |
5424 |  |  |  |  |
5425 |  |  |  |  | sub is_pcdata
5426 |  |  |  |  | { my $elt= shift;
5427 |  |  |  |  | return (exists $elt->{'pcdata'});
5428 |  |  |  |  | }
5429 |  |  |  |  |
5430 |  |  |  |  | sub is_cdata
5431 |  |  |  |  | { my $elt= shift;
5432 |  |  |  |  | return (exists $elt->{'cdata'});
5433 |  |  |  |  | }
5434 |  |  |  |  |
5435 |  |  |  |  | sub is_pi
5436 |  |  |  |  | { my $elt= shift;
5437 |  |  |  |  | return (exists $elt->{'target'});
5438 |  |  |  |  | }
5439 |  |  |  |  |
5440 |  |  |  |  | sub is_comment
5441 |  |  |  |  | { my $elt= shift;
5442 |  |  |  |  | return (exists $elt->{'comment'});
5443 |  |  |  |  | }
5444 |  |  |  |  |
5445 |  |  |  |  | sub is_ent
5446 |  |  |  |  | { my $elt= shift;
5447 |  |  |  |  | return (exists $elt->{ent} || $elt->{ent_name});
5448 |  |  |  |  | }
5449 |  |  |  |  |
5450 |  |  |  |  |
5451 |  |  |  |  | sub is_text
5452 |  |  |  |  | { my $elt= shift;
5453 |  |  |  |  | return (exists( $elt->{'pcdata'}) || (exists $elt->{'cdata'}));
5454 |  |  |  |  | }
5455 |  |  |  |  |
5456 |  |  |  |  | sub is_empty
5457 |  |  |  |  | { return $_[0]->{empty} || 0; }
5458 |  |  |  |  |
5459 |  |  |  |  | sub set_empty
5460 |  |  |  |  | { $_[0]->{empty}= defined( $_[1]) ? $_[1] : 1; return $_[0]; }
5461 |  |  |  |  |
5462 |  |  |  |  | sub set_not_empty
5463 |  |  |  |  | { delete $_[0]->{empty} if( $_[0]->{'empty'}); return $_[0]; }
5464 |  |  |  |  |
5465 |  |  |  |  |
5466 |  |  |  |  | sub set_asis
5467 |  |  |  |  | { my $elt=shift;
5468 |  |  |  |  |
5469 |  |  |  |  | foreach my $descendant ($elt, $elt->_descendants )
5470 |  |  |  |  | { $descendant->{asis}= 1;
5471 |  |  |  |  | if( (exists $descendant->{'cdata'}))
5472 |  |  |  |  | { $descendant->{gi}=$XML::Twig::gi2index{$PCDATA} or $descendant->set_gi( $PCDATA);
5473 |  |  |  |  | $descendant->{pcdata}= $descendant->{cdata};
5474 |  |  |  |  | }
5475 |  |  |  |  |
5476 |  |  |  |  | }
5477 |  |  |  |  | return $elt;
5478 |  |  |  |  | }
5479 |  |  |  |  |
5480 |  |  |  |  | sub set_not_asis
5481 |  |  |  |  | { my $elt=shift;
5482 |  |  |  |  | foreach my $descendant ($elt, $elt->descendants)
5483 |  |  |  |  | { delete $descendant->{asis} if $descendant->{asis};}
5484 |  |  |  |  | return $elt;
5485 |  |  |  |  | }
5486 |  |  |  |  |
5487 |  |  |  |  | sub is_asis
5488 |  |  |  |  | { return $_[0]->{asis}; }
5489 |  |  |  |  |
5490 |  |  |  |  | sub closed
5491 |  |  |  |  | { my $elt= shift;
5492 |  |  |  |  | my $t= $elt->twig || return;
5493 |  |  |  |  | my $curr_elt= $t->{twig_current};
5494 |  |  |  |  | return 1 unless( $curr_elt);
5495 |  |  |  |  | return $curr_elt->in( $elt);
5496 |  |  |  |  | }
5497 |  |  |  |  |
5498 |  |  |  |  | sub set_pcdata
5499 |  |  |  |  | { my( $elt, $pcdata)= @_;
5500 |  |  |  |  |
5501 |  |  |  |  | if( $elt->{extra_data_in_pcdata})
5502 |  |  |  |  | { _try_moving_extra_data( $elt, $pcdata);
5503 |  |  |  |  | }
5504 |  |  |  |  | $elt->{pcdata}= $pcdata;
5505 |  |  |  |  | return $elt;
5506 |  |  |  |  | }
5507 |  |  |  |  |
5508 |  |  |  |  | sub _extra_data_in_pcdata { return $_[0]->{extra_data_in_pcdata}; }
5509 |  |  |  |  | sub _set_extra_data_in_pcdata { $_[0]->{extra_data_in_pcdata}= $_[1]; return $_[0]; }
5510 |  |  |  |  | sub _del_extra_data_in_pcdata { delete $_[0]->{extra_data_in_pcdata}; return $_[0]; }
5511 |  |  |  |  | sub _unshift_extra_data_in_pcdata
5512 |  |  |  |  | { my $e= shift;
5513 |  |  |  |  | $e->{extra_data_in_pcdata}||=[];
5514 |  |  |  |  | unshift @{$e->{extra_data_in_pcdata}}, { text => shift(), offset => shift() };
5515 |  |  |  |  | }
5516 |  |  |  |  | sub _push_extra_data_in_pcdata
5517 |  |  |  |  | { my $e= shift;
5518 |  |  |  |  | $e->{extra_data_in_pcdata}||=[];
5519 |  |  |  |  | push @{$e->{extra_data_in_pcdata}}, { text => shift(), offset => shift() };
5520 |  |  |  |  | }
5521 |  |  |  |  |
5522 |  |  |  |  | sub _extra_data_before_end_tag { return $_[0]->{extra_data_before_end_tag} || ''; }
5523 |  |  |  |  | sub _set_extra_data_before_end_tag { $_[0]->{extra_data_before_end_tag}= $_[1]; return $_[0]}
5524 |  |  |  |  | sub _del_extra_data_before_end_tag { delete $_[0]->{extra_data_before_end_tag}; return $_[0]}
5525 |  |  |  |  | sub _prefix_extra_data_before_end_tag
5526 |  |  |  |  | { my( $elt, $data)= @_;
5527 |  |  |  |  | if($elt->{extra_data_before_end_tag})
5528 |  |  |  |  | { $elt->{extra_data_before_end_tag}= $data . $elt->{extra_data_before_end_tag}; }
5529 |  |  |  |  | else
5530 |  |  |  |  | { $elt->{extra_data_before_end_tag}= $data; }
5531 |  |  |  |  | return $elt;
5532 |  |  |  |  | }
5533 |  |  |  |  |
5534 |  |  |  |  | # internal, in cases where we know there is no extra_data (inlined anyway!)
5535 |  |  |  |  | sub _set_pcdata { $_[0]->{pcdata}= $_[1]; }
5536 |  |  |  |  |
5537 |  |  |  |  | # try to figure out if we can keep the extra_data around
5538 |  |  |  |  | sub _try_moving_extra_data
5539 |  |  |  |  | { my( $elt, $modified)=@_;
5540 |  |  |  |  | my $initial= $elt->{pcdata};
5541 |  |  |  |  | my $cpis= $elt->{extra_data_in_pcdata};
5542 |  |  |  |  |
5543 |  |  |  |  | if( (my $offset= index( $modified, $initial)) != -1)
5544 |  |  |  |  | { # text has been added
5545 |  |  |  |  | foreach (@$cpis) { $_->{offset}+= $offset; }
5546 |  |  |  |  | }
5547 |  |  |  |  | elsif( ($offset= index( $initial, $modified)) != -1)
5548 |  |  |  |  | { # text has been cut
5549 |  |  |  |  | my $len= length( $modified);
5550 |  |  |  |  | foreach my $cpi (@$cpis) { $cpi->{offset} -= $offset; }
5551 |  |  |  |  | $elt->_set_extra_data_in_pcdata( [ grep { $_->{offset} >= 0 && $_->{offset} < $len } @$cpis ]);
5552 |  |  |  |  | }
5553 |  |  |  |  | else
5554 |  |  |  |  | { _match_extra_data_words( $elt, $initial, $modified)
5555 |  |  |  |  | || _match_extra_data_chars( $elt, $initial, $modified)
5556 |  |  |  |  | || $elt->_del_extra_data_in_pcdata;
5557 |  |  |  |  | }
5558 |  |  |  |  | }
5559 |  |  |  |  |
5560 |  |  |  |  | sub _match_extra_data_words
5561 |  |  |  |  | { my( $elt, $initial, $modified)= @_;
5562 |  |  |  |  | my @initial= split /\b/, $initial;
5563 |  |  |  |  | my @modified= split /\b/, $modified;
5564 |  |  |  |  |
5565 |  |  |  |  | return _match_extra_data( $elt, length( $initial), \@initial, \@modified);
5566 |  |  |  |  | }
5567 |  |  |  |  |
5568 |  |  |  |  | sub _match_extra_data_chars
5569 |  |  |  |  | { my( $elt, $initial, $modified)= @_;
5570 |  |  |  |  | my @initial= split //, $initial;
5571 |  |  |  |  | my @modified= split //, $modified;
5572 |  |  |  |  |
5573 |  |  |  |  | return _match_extra_data( $elt, length( $initial), \@initial, \@modified);
5574 |  |  |  |  | }
5575 |  |  |  |  |
5576 |  |  |  |  | sub _match_extra_data
5577 |  |  |  |  | { my( $elt, $length, $initial, $modified)= @_;
5578 |  |  |  |  |
5579 |  |  |  |  | my $cpis= $elt->{extra_data_in_pcdata};
5580 |  |  |  |  |
5581 |  |  |  |  | if( @$initial <= @$modified)
5582 |  |  |  |  | {
5583 |  |  |  |  | my( $ok, $positions, $offsets)= _pos_offset( $initial, $modified);
5584 |  |  |  |  | if( $ok)
5585 |  |  |  |  | { my $offset=0;
5586 |  |  |  |  | my $pos= shift @$positions;
5587 |  |  |  |  | foreach my $cpi (@$cpis)
5588 |  |  |  |  | { while( $cpi->{offset} >= $pos)
5589 |  |  |  |  | { $offset= shift @$offsets;
5590 |  |  |  |  | $pos= shift @$positions || $length +1;
5591 |  |  |  |  | }
5592 |  |  |  |  | $cpi->{offset} += $offset;
5593 |  |  |  |  | }
5594 |  |  |  |  | return 1;
5595 |  |  |  |  | }
5596 |  |  |  |  | }
5597 |  |  |  |  | else
5598 |  |  |  |  | { my( $ok, $positions, $offsets)= _pos_offset( $modified, $initial);
5599 |  |  |  |  | if( $ok)
5600 |  |  |  |  | { #print STDERR "pos: ", join( ':', @$positions), "\n",
5601 |  |  |  |  | # "offset: ", join( ':', @$offsets), "\n";
5602 |  |  |  |  | my $offset=0;
5603 |  |  |  |  | my $pos= shift @$positions;
5604 |  |  |  |  | my $prev_pos= 0;
5605 |  |  |  |  |
5606 |  |  |  |  | foreach my $cpi (@$cpis)
5607 |  |  |  |  | { while( $cpi->{offset} >= $pos)
5608 |  |  |  |  | { $offset= shift @$offsets;
5609 |  |  |  |  | $prev_pos= $pos;
5610 |  |  |  |  | $pos= shift @$positions || $length +1;
5611 |  |  |  |  | }
5612 |  |  |  |  | $cpi->{offset} -= $offset;
5613 |  |  |  |  | if( $cpi->{offset} < $prev_pos) { delete $cpi->{text}; }
5614 |  |  |  |  | }
5615 |  |  |  |  | $elt->_set_extra_data_in_pcdata( [ grep { exists $_->{text} } @$cpis ]);
5616 |  |  |  |  | return 1;
5617 |  |  |  |  | }
5618 |  |  |  |  | }
5619 |  |  |  |  | return 0;
5620 |  |  |  |  | }
5621 |  |  |  |  |
5622 |  |  |  |  |
5623 |  |  |  |  | sub _pos_offset
5624 |  |  |  |  | { my( $short, $long)= @_;
5625 |  |  |  |  | my( @pos, @offset);
5626 |  |  |  |  | my( $s_length, $l_length)=(0,0);
5627 |  |  |  |  | while (@$short)
5628 |  |  |  |  | { my $s_word= shift @$short;
5629 |  |  |  |  | my $l_word= shift @$long;
5630 |  |  |  |  | if( $s_word ne $l_word)
5631 |  |  |  |  | { while( @$long && $s_word ne $l_word)
5632 |  |  |  |  | { $l_length += length( $l_word);
5633 |  |  |  |  | $l_word= shift @$long;
5634 |  |  |  |  | }
5635 |  |  |  |  | if( !@$long && $s_word ne $l_word) { return 0; }
5636 |  |  |  |  | push @pos, $s_length;
5637 |  |  |  |  | push @offset, $l_length - $s_length;
5638 |  |  |  |  | }
5639 |  |  |  |  | my $length= length( $s_word);
5640 |  |  |  |  | $s_length += $length;
5641 |  |  |  |  | $l_length += $length;
5642 |  |  |  |  | }
5643 |  |  |  |  | return( 1, \@pos, \@offset);
5644 |  |  |  |  | }
5645 |  |  |  |  |
5646 |  |  |  |  | sub append_pcdata
5647 |  |  |  |  | { $_[0]->{'pcdata'}.= $_[1];
5648 |  |  |  |  | return $_[0];
5649 |  |  |  |  | }
5650 |  |  |  |  |
5651 |  |  |  |  | sub pcdata { return $_[0]->{pcdata}; }
5652 |  |  |  |  |
5653 |  |  |  |  |
5654 |  |  |  |  | sub append_extra_data
5655 |  |  |  |  | { $_[0]->{extra_data}.= $_[1];
5656 |  |  |  |  | return $_[0];
5657 |  |  |  |  | }
5658 |  |  |  |  |
5659 |  |  |  |  | sub set_extra_data
5660 |  |  |  |  | { $_[0]->{extra_data}= $_[1];
5661 |  |  |  |  | return $_[0];
5662 |  |  |  |  | }
5663 |  |  |  |  | sub extra_data { return $_[0]->{extra_data} || ''; }
5664 |  |  |  |  |
5665 |  |  |  |  | sub set_target
5666 |  |  |  |  | { my( $elt, $target)= @_;
5667 |  |  |  |  | $elt->{target}= $target;
5668 |  |  |  |  | return $elt;
5669 |  |  |  |  | }
5670 |  |  |  |  | sub target { return $_[0]->{target}; }
5671 |  |  |  |  |
5672 |  |  |  |  | sub set_data
5673 |  |  |  |  | { $_[0]->{'data'}= $_[1];
5674 |  |  |  |  | return $_[0];
5675 |  |  |  |  | }
5676 |  |  |  |  | sub data { return $_[0]->{data}; }
5677 |  |  |  |  |
5678 |  |  |  |  | sub set_pi
5679 |  |  |  |  | { my $elt= shift;
5680 |  |  |  |  | unless( $elt->{gi} == $XML::Twig::gi2index{$PI})
5681 |  |  |  |  | { $elt->cut_children;
5682 |  |  |  |  | $elt->{gi}=$XML::Twig::gi2index{$PI} or $elt->set_gi( $PI);
5683 |  |  |  |  | }
5684 |  |  |  |  | return $elt->_set_pi( @_);
5685 |  |  |  |  | }
5686 |  |  |  |  |
5687 |  |  |  |  | sub _set_pi
5688 |  |  |  |  | { $_[0]->set_target( $_[1]);
5689 |  |  |  |  | $_[0]->{data}= $_[2];
5690 |  |  |  |  | return $_[0];
5691 |  |  |  |  | }
5692 |  |  |  |  |
5693 |  |  |  |  | sub pi_string { my $string= $PI_START . $_[0]->{target};
5694 |  |  |  |  | my $data= $_[0]->{data};
5695 |  |  |  |  | if( defined( $data) && $data ne '') { $string .= " $data"; }
5696 |  |  |  |  | $string .= $PI_END ;
5697 |  |  |  |  | return $string;
5698 |  |  |  |  | }
5699 |  |  |  |  |
5700 |  |  |  |  | sub set_comment
5701 |  |  |  |  | { my $elt= shift;
5702 |  |  |  |  | unless( $elt->{gi} == $XML::Twig::gi2index{$COMMENT})
5703 |  |  |  |  | { $elt->cut_children;
5704 |  |  |  |  | $elt->{gi}=$XML::Twig::gi2index{$COMMENT} or $elt->set_gi( $COMMENT);
5705 |  |  |  |  | }
5706 |  |  |  |  | $elt->{comment}= $_[0];
5707 |  |  |  |  | return $elt;
5708 |  |  |  |  | }
5709 |  |  |  |  |
5710 |  |  |  |  | sub _set_comment { $_[0]->{comment}= $_[1]; return $_[0]; }
5711 |  |  |  |  | sub comment { return $_[0]->{comment}; }
5712 |  |  |  |  | sub comment_string { return $COMMENT_START . _comment_escaped_string( $_[0]->{comment}) . $COMMENT_END; }
5713 |  |  |  |  | # comments cannot start or end with
5714 |  |  |  |  | sub _comment_escaped_string
5715 |  |  |  |  | { my( $c)= @_;
5716 |  |  |  |  | $c=~ s{^-}{ -};
5717 |  |  |  |  | $c=~ s{-$}{- };
5718 |  |  |  |  | $c=~ s{--}{- -}g;
5719 |  |  |  |  | return $c;
5720 |  |  |  |  | }
5721 |  |  |  |  |
5722 |  |  |  |  | sub set_ent { $_[0]->{ent}= $_[1]; return $_[0]; }
5723 |  |  |  |  | sub ent { return $_[0]->{ent}; }
5724 |  |  |  |  | sub ent_name { return substr( $_[0]->{ent}, 1, -1);}
5725 |  |  |  |  |
5726 |  |  |  |  | sub set_cdata
5727 |  |  |  |  | { my $elt= shift;
5728 |  |  |  |  | unless( $elt->{gi} == $XML::Twig::gi2index{$CDATA})
5729 |  |  |  |  | { $elt->cut_children;
5730 |  |  |  |  | $elt->insert_new_elt( first_child => $CDATA, @_);
5731 |  |  |  |  | return $elt;
5732 |  |  |  |  | }
5733 |  |  |  |  | $elt->{cdata}= $_[0];
5734 |  |  |  |  | return $_[0];
5735 |  |  |  |  | }
5736 |  |  |  |  |
5737 |  |  |  |  | sub _set_cdata
5738 |  |  |  |  | { $_[0]->{cdata}= $_[1];
5739 |  |  |  |  | return $_[0];
5740 |  |  |  |  | }
5741 |  |  |  |  |
5742 |  |  |  |  | sub append_cdata
5743 |  |  |  |  | { $_[0]->{cdata}.= $_[1];
5744 |  |  |  |  | return $_[0];
5745 |  |  |  |  | }
5746 |  |  |  |  | sub cdata { return $_[0]->{cdata}; }
5747 |  |  |  |  |
5748 |  |  |  |  |
5749 |  |  |  |  | sub contains_only_text
5750 |  |  |  |  | { my $elt= shift;
5751 |  |  |  |  | return 0 unless $elt->is_elt;
5752 |  |  |  |  | foreach my $child ($elt->_children)
5753 |  |  |  |  | { return 0 if $child->is_elt; }
5754 |  |  |  |  | return $elt;
5755 |  |  |  |  | }
5756 |  |  |  |  |
5757 |  |  |  |  | sub contains_only
5758 |  |  |  |  | { my( $elt, $exp)= @_;
5759 |  |  |  |  | my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
5760 |  |  |  |  | foreach my $child (@children)
5761 |  |  |  |  | { return 0 unless $child->is( $exp); }
5762 |  |  |  |  | return @children || 1;
5763 |  |  |  |  | }
5764 |  |  |  |  |
5765 |  |  |  |  | sub contains_a_single
5766 |  |  |  |  | { my( $elt, $exp)= @_;
5767 |  |  |  |  | my $child= $elt->{first_child} or return 0;
5768 |  |  |  |  | return 0 unless $child->passes( $exp);
5769 |  |  |  |  | return 0 if( $child->{next_sibling});
5770 |  |  |  |  | return $child;
5771 |  |  |  |  | }
5772 |  |  |  |  |
5773 |  |  |  |  |
5774 |  |  |  |  | sub root
5775 | 16 | 2µs |  |  | # spent 40µs within XML::Twig::Elt::root which was called 16 times, avg 3µs/call: # 16 times (40µs+0s) by XML::Twig::Elt::twig at line 5788, avg 3µs/call { my $elt= shift;
5776 | 16 | 31µs |  |  | while( $elt->{parent}) { $elt= $elt->{parent}; }
5777 | 16 | 16µs |  |  | return $elt;
5778 |  |  |  |  | }
5779 |  |  |  |  |
5780 |  |  |  |  | sub _root_through_cut
5781 |  |  |  |  | { my $elt= shift;
5782 |  |  |  |  | while( $elt->{parent} || ($elt->{former} && $elt->{former}->{parent})) { $elt= $elt->{parent} || ($elt->{former} && $elt->{former}->{parent}); }
5783 |  |  |  |  | return $elt;
5784 |  |  |  |  | }
5785 |  |  |  |  |
5786 |  |  |  |  | sub twig
5787 | 16 | 2µs |  |  | # spent 78µs (38+40) within XML::Twig::Elt::twig which was called 16 times, avg 5µs/call: # 2 times (5µs+4µs) by XML::Twig::Elt::__ANON__[(eval 62)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 62)[XML/Twig.pm:7113], avg 4µs/call # once (4µs+5µs) by XML::Twig::Elt::__ANON__[(eval 129)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 129)[XML/Twig.pm:7113] # once (4µs+3µs) by XML::Twig::Elt::__ANON__[(eval 58)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 58)[XML/Twig.pm:7113] # once (3µs+3µs) by XML::Twig::Elt::__ANON__[(eval 60)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 60)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 64)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 64)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 103)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 103)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 61)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 61)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 97)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 97)[XML/Twig.pm:7113] # once (2µs+3µs) by XML::Twig::Elt::__ANON__[(eval 63)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 63)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 70)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 70)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 76)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 76)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 85)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 85)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 68)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 68)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 87)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 87)[XML/Twig.pm:7113] # once (2µs+2µs) by XML::Twig::Elt::__ANON__[(eval 66)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 66)[XML/Twig.pm:7113] { my $elt= shift;
5788 | 16 | 13µs | 16 | 40µs | my $root= $elt->root; # spent 40µs making 16 calls to XML::Twig::Elt::root, avg 3µs/call
5789 | 16 | 30µs |  |  | return $root->{twig};
5790 |  |  |  |  | }
5791 |  |  |  |  |
5792 |  |  |  |  | sub _twig_through_cut
5793 |  |  |  |  | { my $elt= shift;
5794 |  |  |  |  | my $root= $elt->_root_through_cut;
5795 |  |  |  |  | return $root->{twig};
5796 |  |  |  |  | }
5797 |  |  |  |  |
5798 |  |  |  |  |
5799 |  |  |  |  | # used for navigation
5800 |  |  |  |  | # returns undef or the element, depending on whether $elt passes $cond
5801 |  |  |  |  | # $cond can be
5802 |  |  |  |  | # - empty: the element passes the condition
5803 |  |  |  |  | # - ELT ('#ELT'): the element passes the condition if it is a "real" element
5804 |  |  |  |  | # - TEXT ('#TEXT'): the element passes if it is a CDATA or PCDATA element
5805 |  |  |  |  | # - a string with an XPath condition (only a subset of XPath is actually
5806 |  |  |  |  | # supported).
5807 |  |  |  |  | # - a regexp: the element passes if its gi matches the regexp
5808 |  |  |  |  | # - a code ref: the element passes if the code, applied on the element,
5809 |  |  |  |  | # returns true
5810 |  |  |  |  |
5811 | 1 | 100ns |  |  | my %cond_cache; # expression => coderef
5812 |  |  |  |  |
5813 |  |  |  |  | sub reset_cond_cache { %cond_cache=(); }
5814 |  |  |  |  |
5815 |  |  |  |  | {
5816 |  |  |  |  | sub _install_cond
5817 | 37 | 7µs |  |  | # spent 7.38ms (6.09+1.29) within XML::Twig::Elt::_install_cond which was called 37 times, avg 199µs/call: # 26 times (1.65ms+654µs) by XML::Twig::Elt::first_child at line 5999, avg 89µs/call # 11 times (4.43ms+637µs) by XML::Twig::Elt::passes at line 5974, avg 461µs/call { my $cond= shift;
5818 | 37 | 3µs |  |  | my $test;
5819 | 37 | 6µs |  |  | my $init='';
5820 |  |  |  |  |
5821 | 37 | 6µs |  |  | my $original_cond= $cond;
5822 |  |  |  |  |
5823 | 37 | 62µs | 37 | 20µs | my $not= ($cond=~ s{^\s*!}{}) ? '!' : ''; # spent 20µs making 37 calls to CORE::subst, avg 543ns/call
5824 |  |  |  |  |
5825 | 37 | 11µs |  |  | if( ref $cond eq 'CODE') { return $cond; }
5826 |  |  |  |  |
5827 | 37 | 11µs |  |  | if( ref $cond eq 'Regexp')
5828 |  |  |  |  | { $test = qq{(\$_[0]->gi=~ /$cond/)}; }
5829 |  |  |  |  | else
5830 | 37 | 4µs |  |  | { my @tests;
5831 | 37 | 9µs |  |  | while( $cond)
5832 |  |  |  |  | {
5833 |  |  |  |  | # the condition is a string
5834 | 37 | 696µs | 222 | 513µs | if( $cond=~ s{$ELT$SEP}{}) # spent 406µs making 111 calls to CORE::regcomp, avg 4µs/call # spent 107µs making 111 calls to CORE::subst, avg 966ns/call
5835 |  |  |  |  | { push @tests, qq{\$_[0]->is_elt}; }
5836 |  |  |  |  | elsif( $cond=~ s{$TEXT$SEP}{})
5837 |  |  |  |  | { push @tests, qq{\$_[0]->is_text}; }
5838 |  |  |  |  | elsif( $cond=~ s{^\s*($REG_TAG_PART)$SEP}{})
5839 | 37 | 33µs | 37 | 153µs | { push @tests, _gi_test( $1); } # spent 153µs making 37 calls to XML::Twig::Elt::_gi_test, avg 4µs/call
5840 |  |  |  |  | elsif( $cond=~ s{^\s*($REG_REGEXP)$SEP}{})
5841 |  |  |  |  | { # /regexp/
5842 |  |  |  |  | push @tests, qq{ \$_[0]->gi=~ $1 };
5843 |  |  |  |  | }
5844 |  |  |  |  | elsif( $cond=~ s{^\s*($REG_TAG_PART)?\s* # $1
5845 |  |  |  |  | \[\s*(-?)\s*(\d+)\s*\] # [$2]
5846 |  |  |  |  | $SEP}{}xo
5847 |  |  |  |  | )
5848 |  |  |  |  | { my( $gi, $neg, $index)= ($1, $2, $3);
5849 |  |  |  |  | my $siblings= $neg ? q{$_[0]->_next_siblings} : q{$_[0]->_prev_siblings};
5850 |  |  |  |  | if( $gi && ($gi ne '*'))
5851 |  |  |  |  | #{ $test= qq{((\$_[0]->gi eq "$gi") && (scalar( grep { \$_->gi eq "$gi" } $siblings) + 1 == $index))}; }
5852 |  |  |  |  | { push @tests, _and( _gi_test( $gi), qq{ (scalar( grep { \$_->gi eq "$gi" } $siblings) + 1 == $index)}); }
5853 |  |  |  |  | else
5854 |  |  |  |  | { push @tests, qq{(scalar( $siblings) + 1 == $index)}; }
5855 |  |  |  |  | }
5856 |  |  |  |  | elsif( $cond=~ s{^\s*($REG_TAG_PART?)\s*($REG_PREDICATE)$SEP}{})
5857 |  |  |  |  | { my( $gi, $predicate)= ( $1, $2);
5858 |  |  |  |  | push @tests, _and( _gi_test( $gi), _parse_predicate_in_step( $predicate));
5859 |  |  |  |  | }
5860 |  |  |  |  | elsif( $cond=~ s{^\s*($REG_NAKED_PREDICATE)$SEP}{})
5861 |  |  |  |  | { push @tests, _parse_predicate_in_step( $1); }
5862 |  |  |  |  | else
5863 |  |  |  |  | { croak "wrong navigation condition '$original_cond' ($@)"; }
5864 |  |  |  |  | }
5865 | 37 | 18µs |  |  | $test= @tests > 1 ? '(' . join( '||', map { "($_)" } @tests) . ')' : $tests[0];
5866 |  |  |  |  | }
5867 |  |  |  |  |
5868 |  |  |  |  | #warn "init: '$init' - test: '$test'\n";
5869 |  |  |  |  |
5870 | 37 | 15µs |  |  | my $sub= qq{sub { $NO_WARNINGS; $init; return $not($test) ? \$_[0] : undef; } };
5871 | 37 | 984µs |  |  | my $s= eval $sub; # spent 818ms executing statements in string eval # includes 54.5ms spent executing 202908 calls to 2 subs defined therein. # spent 627ms executing statements in string eval # includes 299ms spent executing 127277 calls to 2 subs defined therein. # spent 574ms executing statements in string eval # includes 49.6ms spent executing 127277 calls to 2 subs defined therein. # spent 156µs executing statements in 4 string evals (merged) # includes 42µs spent executing 50 calls to 5 subs defined therein. # spent 137µs executing statements in 4 string evals (merged) # includes 31µs spent executing 17 calls to 5 subs defined therein. # spent 125µs executing statements in 3 string evals (merged) # includes 28µs spent executing 16 calls to 4 subs defined therein. # spent 120µs executing statements in string eval # includes 96µs spent executing 104 calls to 2 subs defined therein. # spent 109µs executing statements in 3 string evals (merged) # includes 33µs spent executing 22 calls to 4 subs defined therein. # spent 109µs executing statements in 3 string evals (merged) # includes 24µs spent executing 26 calls to 4 subs defined therein. # spent 82µs executing statements in 2 string evals (merged) # includes 15µs spent executing 8 calls to 3 subs defined therein. # spent 70µs executing statements in 2 string evals (merged) # includes 18µs spent executing 9 calls to 3 subs defined therein. # spent 56µs executing statements in string eval # includes 32µs spent executing 29 calls to 2 subs defined therein. # spent 47µs executing statements in string eval # includes 20µs spent executing 15 calls to 2 subs defined therein. # spent 45µs executing statements in string eval # includes 19µs spent executing 15 calls to 2 subs defined therein. # spent 45µs executing statements in string eval # includes 8µs spent executing 2 calls to 2 subs defined therein. # spent 45µs executing statements in string eval # includes 13µs spent executing 7 calls to 2 subs defined therein. # spent 43µs executing statements in string eval # includes 19µs spent executing 15 calls to 2 subs defined therein. # spent 40µs executing statements in string eval # includes 15µs spent executing 6 calls to 2 subs defined therein. # spent 38µs executing statements in string eval # includes 8µs spent executing 2 calls to 2 subs defined therein. # spent 36µs executing statements in string eval # includes 10µs spent executing 11 calls to 2 subs defined therein. # spent 35µs executing statements in string eval # includes 7µs spent executing 2 calls to 2 subs defined therein. # spent 33µs executing statements in string eval # includes 8µs spent executing 5 calls to 2 subs defined therein. # spent 32µs executing statements in string eval # includes 7µs spent executing 3 calls to 2 subs defined therein.
5872 |  |  |  |  | #warn "cond: $cond\n$sub\n";
5873 | 37 | 7µs |  |  | if( $@)
5874 |  |  |  |  | { croak "wrong navigation condition '$original_cond' ($@);" }
5875 | 37 | 68µs |  |  | return $s;
5876 |  |  |  |  | }
5877 |  |  |  |  |
5878 |  |  |  |  | sub _gi_test
5879 | 37 | 25µs |  |  | # spent 153µs (112+41) within XML::Twig::Elt::_gi_test which was called 37 times, avg 4µs/call: # 37 times (112µs+41µs) by XML::Twig::Elt::_install_cond at line 5839, avg 4µs/call { my( $full_gi)= @_;
5880 |  |  |  |  |
5881 |  |  |  |  | # optimize if the gi exists, including the case where the gi includes a dot
5882 | 37 | 14µs |  |  | my $index= $XML::Twig::gi2index{$full_gi};
5883 | 37 | 3.72ms |  |  | if( $index) { return qq{\$_[0]->{gi} == $index}; }
5884 |  |  |  |  |
5885 | 7 | 25µs | 7 | 15µs | my( $gi, $class, $id)= $full_gi=~ m{^(.*?)(?:[.]([^.]*)|[#](.*))?$}; # spent 15µs making 7 calls to CORE::match, avg 2µs/call
5886 |  |  |  |  |
5887 | 7 | 1µs |  |  | my $gi_test='';
5888 | 7 | 3µs |  |  | if( $gi && $gi ne '*' )
5889 |  |  |  |  | { # 2 options, depending on whether the gi exists in gi2index
5890 |  |  |  |  | # start optimization
5891 | 7 | 2µs |  |  | my $index= $XML::Twig::gi2index{$gi};
5892 | 7 | 2µs |  |  | if( $index)
5893 |  |  |  |  | { # the gi exists, use its index as a faster shortcut
5894 |  |  |  |  | $gi_test = qq{\$_[0]->{gi} == $index};
5895 |  |  |  |  | }
5896 |  |  |  |  | else
5897 |  |  |  |  | { # it does not exist (but might be created later), compare the strings
5898 |  |  |  |  |
5899 | 7 | 3µs |  |  | $gi_test = qq{ \$_[0]->gi eq "$gi"};
5900 |  |  |  |  | }
5901 |  |  |  |  | }
5902 |  |  |  |  | else
5903 |  |  |  |  | { $gi_test= 1; }
5904 |  |  |  |  |
5905 | 7 | 1µs |  |  | my $class_test='';
5906 |  |  |  |  | #warn "class: '$class'";
5907 | 7 | 1µs |  |  | if( $class)
5908 |  |  |  |  | { $class_test = qq{ defined( \$_[0]->{att}->{class}) && \$_[0]->{att}->{class}=~ m{\\b$class\\b} }; }
5909 |  |  |  |  |
5910 | 7 | 1µs |  |  | my $id_test='';
5911 |  |  |  |  | #warn "id: '$id'";
5912 | 7 | 600ns |  |  | if( $id)
5913 |  |  |  |  | { $id_test = qq{ defined( \$_[0]->{att}->{$ID}) && \$_[0]->{att}->{$ID} eq '$id' }; }
5914 |  |  |  |  |
5915 |  |  |  |  |
5916 |  |  |  |  | #warn "gi_test: '$gi_test' - class_test: '$class_test' returning ", _and( $gi_test, $class_test);
5917 | 7 | 13µs | 7 | 26µs | return _and( $gi_test, $class_test, $id_test); # spent 26µs making 7 calls to XML::Twig::Elt::_and, avg 4µs/call
5918 |  |  |  |  | }
5919 |  |  |  |  |
5920 |  |  |  |  |
5921 |  |  |  |  | # input: the original predicate
5922 |  |  |  |  | sub _parse_predicate_in_step
5923 |  |  |  |  | { my $cond= shift;
5924 |  |  |  |  | my %PERL_ALPHA_TEST= ( '=' => ' eq ', '!=' => ' ne ', '>' => ' gt ', '>=' => ' ge ', '<' => ' lt ', '<=' => ' le ');
5925 |  |  |  |  |
5926 |  |  |  |  | $cond=~ s{^\s*\[\s*}{};
5927 |  |  |  |  | $cond=~ s{\s*\]\s*$}{};
5928 |  |  |  |  | $cond=~ s{( ($REG_STRING|$REG_REGEXP) # strings or regexps
5929 |  |  |  |  | { my( $token, $string, $att, $bare_att, $num_test, $alpha_test, $func, $string_regexp, $string_eq, $string_test, $and_or)
5930 |  |  |  |  | = ( $1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11);
5931 |  |  |  |  |
5932 |  |  |  |  | if( defined $string) { $token }
5933 |  |  |  |  | elsif( $att) { "( \$_[0]->{att} && exists( \$_[0]->{att}->{'$att'}) && \$_[0]->{att}->{'$att'})"; }
5934 |  |  |  |  | elsif( $bare_att) { "(\$_[0]->{att} && defined( \$_[0]->{att}->{'$bare_att'}))"; }
5935 |  |  |  |  | elsif( $num_test && ($num_test eq '=') ) { "==" } # others tests are unchanged
5936 |  |  |  |  | elsif( $alpha_test) { $PERL_ALPHA_TEST{$alpha_test} }
5937 |  |  |  |  | elsif( $func && $func=~ m{^(?:string|text)})
5938 |  |  |  |  | { "\$_[0]->text"; }
5939 |  |  |  |  | elsif( $string_regexp && $string_regexp =~ m{(?:string|text)\(\s*($REG_TAG_NAME)\s*\)\s*($REG_MATCH)\s*($REG_REGEXP)})
5940 |  |  |  |  | { "(XML::Twig::_first_n { (\$_->gi eq '$1') && (\$_->text $2 $3) } 1, \$_[0]->_children)"; }
5941 |  |  |  |  | elsif( $string_eq && $string_eq =~ m{(?:string|text)\(\s*($REG_TAG_NAME)\s*\)\s*(!?=)\s*($REG_VALUE)})
5942 |  |  |  |  | {"(XML::Twig::_first_n { (\$_->gi eq '$1') && (\$_->text $PERL_ALPHA_TEST{$2} $3) } 1, \$_[0]->_children)"; }
5943 |  |  |  |  | elsif( $string_test && $string_test =~ m{(?:string|text)\(\s*($REG_TAG_NAME)\s*\)\s*([<>]=?)\s*($REG_VALUE)})
5944 |  |  |  |  | { "(XML::Twig::_first_n { (\$_->gi eq '$1') && (\$_->text $2 $3) } 1, \$_[0]->_children)"; }
5945 |  |  |  |  | elsif( $and_or) { $and_or eq 'and' ? '&&' : '||' ; }
5946 |  |  |  |  | else { $token; }
5947 |  |  |  |  | }gexs;
5948 |  |  |  |  |
- - |  |  |  |  |
5960 |  |  |  |  | return "($cond)";
5961 |  |  |  |  | }
5962 |  |  |  |  |
5963 |  |  |  |  |
5964 |  |  |  |  | sub _op
5965 | 5 | 2µs |  |  | # spent 10µs within XML::Twig::Elt::_op which was called 5 times, avg 2µs/call: # 5 times (10µs+0s) by XML::Twig::Elt::_install_xpath at line 7079, avg 2µs/call { my $op= shift;
5966 | 5 | 3µs |  |  | if( $op eq '=') { $op= 'eq'; }
5967 |  |  |  |  | elsif( $op eq '!=') { $op= 'ne'; }
5968 | 5 | 7µs |  |  | return $op;
5969 |  |  |  |  | }
5970 |  |  |  |  |
5971 |  |  |  |  | sub passes
5972 | 458 | 41µs |  |  | # spent 5.29ms (190µs+5.10) within XML::Twig::Elt::passes which was called 458 times, avg 12µs/call: # 442 times (122µs+0s) by XML::Twig::Elt::ancestors at line 6341, avg 275ns/call # 16 times (68µs+5.10ms) by XML::Twig::descendants at line 3759, avg 323µs/call { my( $elt, $cond)= @_;
5973 | 458 | 258µs |  |  | return $elt unless $cond;
5974 | 16 | 16µs | 11 | 5.07ms | my $sub= ($cond_cache{$cond} ||= _install_cond( $cond)); # spent 5.07ms making 11 calls to XML::Twig::Elt::_install_cond, avg 461µs/call
5975 | 16 | 30µs | 16 | 32µs | return $sub->( $elt); # spent 7µs making 6 calls to XML::Twig::Elt::__ANON__[(eval 59)[XML/Twig.pm:5871]:1], avg 1µs/call # spent 5µs making 1 call to XML::Twig::Elt::__ANON__[(eval 86)[XML/Twig.pm:5871]:1] # spent 4µs making 2 calls to XML::Twig::Elt::__ANON__[(eval 105)[XML/Twig.pm:5871]:1], avg 2µs/call # spent 3µs making 1 call to XML::Twig::Elt::__ANON__[(eval 130)[XML/Twig.pm:5871]:1] # spent 3µs making 1 call to XML::Twig::Elt::__ANON__[(eval 71)[XML/Twig.pm:5871]:1] # spent 2µs making 1 call to XML::Twig::Elt::__ANON__[(eval 104)[XML/Twig.pm:5871]:1] # spent 2µs making 1 call to XML::Twig::Elt::__ANON__[(eval 65)[XML/Twig.pm:5871]:1] # spent 2µs making 1 call to XML::Twig::Elt::__ANON__[(eval 69)[XML/Twig.pm:5871]:1] # spent 2µs making 1 call to XML::Twig::Elt::__ANON__[(eval 72)[XML/Twig.pm:5871]:1] # spent 2µs making 1 call to XML::Twig::Elt::__ANON__[(eval 67)[XML/Twig.pm:5871]:1]
5976 |  |  |  |  | }
5977 |  |  |  |  | }
5978 |  |  |  |  |
5979 |  |  |  |  | sub set_parent
5980 | 1 | 200ns |  |  | { $_[0]->{parent}= $_[1];
5981 |  |  |  |  | if( $XML::Twig::weakrefs) { weaken( $_[0]->{parent}); }
5982 |  |  |  |  | }
5983 |  |  |  |  |
5984 |  |  |  |  | sub parent
5985 |  |  |  |  | { my $elt= shift;
5986 |  |  |  |  | my $cond= shift || return $elt->{parent};
5987 |  |  |  |  | do { $elt= $elt->{parent} || return; } until ( $elt->passes( $cond));
5988 |  |  |  |  | return $elt;
5989 |  |  |  |  | }
5990 |  |  |  |  |
5991 |  |  |  |  | sub set_first_child
5992 |  |  |  |  | { $_[0]->{'first_child'}= $_[1];
5993 |  |  |  |  | }
5994 |  |  |  |  |
5995 |  |  |  |  | sub first_child
5996 | 421560 | 35.3ms |  |  | # spent 2.08s (1.66+427ms) within XML::Twig::Elt::first_child which was called 421560 times, avg 5µs/call: # 202907 times (775ms+364ms) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 423 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 6µs/call # 202907 times (775ms+49.7ms) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 375 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 4µs/call # 15651 times (105ms+11.9ms) by XML::Twig::Elt::children at line 6271, avg 7µs/call # 20 times (53µs+180µs) by Spreadsheet::ParseXLSX::_parse_styles at line 822 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 12µs/call # 18 times (79µs+324µs) by Spreadsheet::ParseXLSX::_parse_styles at line 872 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 22µs/call # 15 times (20µs+111µs) by Spreadsheet::ParseXLSX::_parse_styles at line 912 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 9µs/call # 15 times (22µs+105µs) by Spreadsheet::ParseXLSX::_parse_styles at line 911 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 9µs/call # 5 times (40µs+404µs) by Spreadsheet::ParseXLSX::_parse_styles at line 829 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 89µs/call # 5 times (20µs+75µs) by Spreadsheet::ParseXLSX::_parse_styles at line 834 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 19µs/call # 5 times (20µs+4µs) by Spreadsheet::ParseXLSX::_parse_styles at line 833 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 5µs/call # 3 times (20µs+118µs) by Spreadsheet::ParseXLSX::_parse_styles at line 856 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 46µs/call # 3 times (19µs+109µs) by Spreadsheet::ParseXLSX::_parse_styles at line 857 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 43µs/call # 3 times (10µs+85µs) by Spreadsheet::ParseXLSX::_parse_styles at line 858 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 32µs/call # 3 times (14µs+81µs) by Spreadsheet::ParseXLSX::_parse_styles at line 861 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 32µs/call { my $elt= shift;
5997 | 421560 | 48.4ms |  |  | my $cond= shift || return $elt->{first_child};
5998 | 421532 | 54.3ms |  |  | my $child= $elt->{first_child};
5999 | 421532 | 79.2ms | 26 | 2.31ms | my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond)); # spent 2.31ms making 26 calls to XML::Twig::Elt::_install_cond, avg 89µs/call
6000 | 421532 | 192ms | 270241 | 425ms | while( $child && !$test_cond->( $child)) # spent 364ms making 127276 calls to XML::Twig::Elt::__ANON__[(eval 128)[XML/Twig.pm:5871]:1], avg 3µs/call # spent 49.6ms making 127276 calls to XML::Twig::Elt::__ANON__[(eval 127)[XML/Twig.pm:5871]:1], avg 390ns/call # spent 11.2ms making 15608 calls to XML::Twig::Elt::__ANON__[(eval 126)[XML/Twig.pm:5871]:1], avg 717ns/call # spent 12µs making 5 calls to XML::Twig::Elt::__ANON__[(eval 101)[XML/Twig.pm:5871]:1], avg 2µs/call # spent 10µs making 6 calls to XML::Twig::Elt::__ANON__[(eval 91)[XML/Twig.pm:5871]:1], avg 2µs/call # spent 7µs making 3 calls to XML::Twig::Elt::__ANON__[(eval 95)[XML/Twig.pm:5871]:1], avg 2µs/call # spent 6µs making 3 calls to XML::Twig::Elt::__ANON__[(eval 90)[XML/Twig.pm:5871]:1], avg 2µs/call # spent 6µs making 3 calls to XML::Twig::Elt::__ANON__[(eval 96)[XML/Twig.pm:5871]:1], avg 2µs/call # spent 5µs making 15 calls to XML::Twig::Elt::__ANON__[(eval 104)[XML/Twig.pm:5871]:1], avg 347ns/call # spent 5µs making 13 calls to XML::Twig::Elt::__ANON__[(eval 73)[XML/Twig.pm:5871]:1], avg 400ns/call # spent 4µs making 11 calls to XML::Twig::Elt::__ANON__[(eval 130)[XML/Twig.pm:5871]:1], avg 409ns/call # spent 3µs making 6 calls to XML::Twig::Elt::__ANON__[(eval 100)[XML/Twig.pm:5871]:1], avg 567ns/call # spent 3µs making 4 calls to XML::Twig::Elt::__ANON__[(eval 105)[XML/Twig.pm:5871]:1], avg 650ns/call # spent 2µs making 3 calls to XML::Twig::Elt::__ANON__[(eval 72)[XML/Twig.pm:5871]:1], avg 767ns/call # spent 2µs making 2 calls to XML::Twig::Elt::__ANON__[(eval 80)[XML/Twig.pm:5871]:1], avg 850ns/call # spent 2µs making 2 calls to XML::Twig::Elt::__ANON__[(eval 79)[XML/Twig.pm:5871]:1], avg 750ns/call # spent 2µs making 3 calls to XML::Twig::Elt::__ANON__[(eval 94)[XML/Twig.pm:5871]:1], avg 500ns/call # spent 1µs making 2 calls to XML::Twig::Elt::__ANON__[(eval 71)[XML/Twig.pm:5871]:1], avg 650ns/call
6001 | 127404 | 32.1ms | 106 | 72µs | { $child= $child->{next_sibling}; } # spent 24µs making 22 calls to XML::Twig::Elt::__ANON__[(eval 91)[XML/Twig.pm:5871]:1], avg 1µs/call # spent 13µs making 11 calls to XML::Twig::Elt::__ANON__[(eval 90)[XML/Twig.pm:5871]:1], avg 1µs/call # spent 12µs making 11 calls to XML::Twig::Elt::__ANON__[(eval 95)[XML/Twig.pm:5871]:1], avg 1µs/call # spent 12µs making 11 calls to XML::Twig::Elt::__ANON__[(eval 96)[XML/Twig.pm:5871]:1], avg 1µs/call # spent 3µs making 16 calls to XML::Twig::Elt::__ANON__[(eval 104)[XML/Twig.pm:5871]:1], avg 206ns/call # spent 2µs making 7 calls to XML::Twig::Elt::__ANON__[(eval 105)[XML/Twig.pm:5871]:1], avg 243ns/call # spent 2µs making 8 calls to XML::Twig::Elt::__ANON__[(eval 73)[XML/Twig.pm:5871]:1], avg 212ns/call # spent 2µs making 7 calls to XML::Twig::Elt::__ANON__[(eval 94)[XML/Twig.pm:5871]:1], avg 214ns/call # spent 1µs making 6 calls to XML::Twig::Elt::__ANON__[(eval 72)[XML/Twig.pm:5871]:1], avg 233ns/call # spent 1µs making 4 calls to XML::Twig::Elt::__ANON__[(eval 71)[XML/Twig.pm:5871]:1], avg 250ns/call # spent 700ns making 2 calls to XML::Twig::Elt::__ANON__[(eval 80)[XML/Twig.pm:5871]:1], avg 350ns/call # spent 300ns making 1 call to XML::Twig::Elt::__ANON__[(eval 130)[XML/Twig.pm:5871]:1]
6002 | 421532 | 849ms |  |  | return $child;
6003 |  |  |  |  | }
6004 |  |  |  |  |
6005 |  |  |  |  | sub _first_child { return $_[0]->{first_child}; }
6006 |  |  |  |  | sub _last_child { return $_[0]->{last_child}; }
6007 |  |  |  |  | sub _next_sibling { return $_[0]->{next_sibling}; }
6008 |  |  |  |  | sub _prev_sibling { return $_[0]->{prev_sibling}; }
6009 |  |  |  |  | sub _parent { return $_[0]->{parent}; }
6010 |  |  |  |  | sub _next_siblings { my $elt= shift; my @siblings; while( $elt= $elt->{next_sibling}) { push @siblings, $elt; } return @siblings; }
6011 |  |  |  |  | sub _prev_siblings { my $elt= shift; my @siblings; while( $elt= $elt->{prev_sibling}) { push @siblings, $elt; } return @siblings; }
6012 |  |  |  |  |
6013 |  |  |  |  | # sets a field
6014 |  |  |  |  | # arguments $record, $cond, @content
6015 |  |  |  |  | sub set_field
6016 |  |  |  |  | { my $record = shift;
6017 |  |  |  |  | my $cond = shift;
6018 |  |  |  |  | my $child= $record->first_child( $cond);
6019 |  |  |  |  | if( $child)
6020 |  |  |  |  | { $child->set_content( @_); }
6021 |  |  |  |  | else
6022 |  |  |  |  | { if( $cond=~ m{^\s*($REG_TAG_NAME)})
6023 |  |  |  |  | { my $gi= $1;
6024 |  |  |  |  | $child= $record->insert_new_elt( last_child => $gi, @_);
6025 |  |  |  |  | }
6026 |  |  |  |  | else
6027 |  |  |  |  | { croak "can't create a field name from $cond"; }
6028 |  |  |  |  | }
6029 |  |  |  |  | return $child;
6030 |  |  |  |  | }
6031 |  |  |  |  |
6032 |  |  |  |  | sub set_last_child
6033 |  |  |  |  | { $_[0]->{'last_child'}= $_[1];
6034 |  |  |  |  | delete $_->[0]->{empty};
6035 |  |  |  |  | if( $XML::Twig::weakrefs) { weaken( $_[0]->{'last_child'}); }
6036 |  |  |  |  | }
6037 |  |  |  |  |
6038 |  |  |  |  | sub last_child
6039 |  |  |  |  | { my $elt= shift;
6040 |  |  |  |  | my $cond= shift || return $elt->{last_child};
6041 |  |  |  |  | my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
6042 |  |  |  |  | my $child= $elt->{last_child};
6043 |  |  |  |  | while( $child && !$test_cond->( $child) )
6044 |  |  |  |  | { $child= $child->{prev_sibling}; }
6045 |  |  |  |  | return $child
6046 |  |  |  |  | }
6047 |  |  |  |  |
6048 |  |  |  |  |
6049 |  |  |  |  | sub set_prev_sibling
6050 |  |  |  |  | { $_[0]->{'prev_sibling'}= $_[1];
6051 |  |  |  |  | if( $XML::Twig::weakrefs) { weaken( $_[0]->{'prev_sibling'}); }
6052 |  |  |  |  | }
6053 |  |  |  |  |
6054 |  |  |  |  | sub prev_sibling
6055 |  |  |  |  | { my $elt= shift;
6056 |  |  |  |  | my $cond= shift || return $elt->{prev_sibling};
6057 |  |  |  |  | my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
6058 |  |  |  |  | my $sibling= $elt->{prev_sibling};
6059 |  |  |  |  | while( $sibling && !$test_cond->( $sibling) )
6060 |  |  |  |  | { $sibling= $sibling->{prev_sibling}; }
6061 |  |  |  |  | return $sibling;
6062 |  |  |  |  | }
6063 |  |  |  |  |
6064 |  |  |  |  | sub set_next_sibling { $_[0]->{'next_sibling'}= $_[1]; }
6065 |  |  |  |  |
6066 |  |  |  |  | sub next_sibling
6067 | 202986 | 17.2ms |  |  | # spent 958ms (915+43.3) within XML::Twig::Elt::next_sibling which was called 202986 times, avg 5µs/call: # 202986 times (915ms+43.3ms) by XML::Twig::Elt::children at line 6274, avg 5µs/call { my $elt= shift;
6068 | 202986 | 17.8ms |  |  | my $cond= shift || return $elt->{next_sibling};
6069 | 202947 | 28.9ms |  |  | my $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond));
6070 | 202947 | 30.7ms |  |  | my $sibling= $elt->{next_sibling};
6071 | 202947 | 82.0ms | 187324 | 43.3ms | while( $sibling && !$test_cond->( $sibling) ) # spent 43.3ms making 187299 calls to XML::Twig::Elt::__ANON__[(eval 126)[XML/Twig.pm:5871]:1], avg 231ns/call # spent 3µs making 14 calls to XML::Twig::Elt::__ANON__[(eval 104)[XML/Twig.pm:5871]:1], avg 229ns/call # spent 2µs making 9 calls to XML::Twig::Elt::__ANON__[(eval 72)[XML/Twig.pm:5871]:1], avg 233ns/call # spent 500ns making 2 calls to XML::Twig::Elt::__ANON__[(eval 73)[XML/Twig.pm:5871]:1], avg 250ns/call
6072 |  |  |  |  | { $sibling= $sibling->{next_sibling}; }
6073 | 202947 | 359ms |  |  | return $sibling;
6074 |  |  |  |  | }
6075 |  |  |  |  |
6076 |  |  |  |  | # methods dealing with the class attribute, convenient if you work with xhtml
6077 |  |  |  |  | sub class { $_[0]->{att}->{class}; }
6078 |  |  |  |  | # lvalue version of class. separate from class to avoid problem like RT#
6079 |  |  |  |  | sub lclass
6080 |  |  |  |  | :lvalue # > perl 5.5
6081 |  |  |  |  | { $_[0]->{att}->{class}; }
6082 |  |  |  |  |
6083 |  |  |  |  | sub set_class { my( $elt, $class)= @_; $elt->set_att( class => $class); }
6084 |  |  |  |  |
6085 |  |  |  |  | # adds a class to an element
6086 |  |  |  |  | sub add_to_class
6087 |  |  |  |  | { my( $elt, $new_class)= @_;
6088 |  |  |  |  | return $elt unless $new_class;
6089 |  |  |  |  | my $class= $elt->class;
6090 |  |  |  |  | my %class= $class ? map { $_ => 1 } split /\s+/, $class : ();
6091 |  |  |  |  | $class{$new_class}= 1;
6092 |  |  |  |  | $elt->set_class( join( ' ', sort keys %class));
6093 |  |  |  |  | }
6094 |  |  |  |  |
6095 |  |  |  |  | sub remove_class
6096 |  |  |  |  | { my( $elt, $class_to_remove)= @_;
6097 |  |  |  |  | return $elt unless $class_to_remove;
6098 |  |  |  |  | my $class= $elt->class;
6099 |  |  |  |  | my %class= $class ? map { $_ => 1 } split /\s+/, $class : ();
6100 |  |  |  |  | delete $class{$class_to_remove};
6101 |  |  |  |  | $elt->set_class( join( ' ', sort keys %class));
6102 |  |  |  |  | }
6103 |  |  |  |  |
6104 |  |  |  |  | sub att_to_class { my( $elt, $att)= @_; $elt->set_class( $elt->{'att'}->{$att}); }
6105 |  |  |  |  | sub add_att_to_class { my( $elt, $att)= @_; $elt->add_to_class( $elt->{'att'}->{$att}); }
6106 |  |  |  |  | sub move_att_to_class { my( $elt, $att)= @_; $elt->add_to_class( $elt->{'att'}->{$att});
6107 |  |  |  |  | $elt->del_att( $att);
6108 |  |  |  |  | }
6109 |  |  |  |  | sub tag_to_class { my( $elt)= @_; $elt->set_class( $elt->tag); }
6110 |  |  |  |  | sub add_tag_to_class { my( $elt)= @_; $elt->add_to_class( $elt->tag); }
6111 |  |  |  |  | sub set_tag_class { my( $elt, $new_tag)= @_; $elt->add_tag_to_class; $elt->set_tag( $new_tag); }
6112 |  |  |  |  |
6113 |  |  |  |  | sub tag_to_span
6114 |  |  |  |  | { my( $elt)= @_;
6115 |  |  |  |  | $elt->set_class( $elt->tag) unless( $elt->tag eq 'span' && $elt->class); # set class to span unless it would mean replacing it with span
6116 |  |  |  |  | $elt->set_tag( 'span');
6117 |  |  |  |  | }
6118 |  |  |  |  |
6119 |  |  |  |  | sub tag_to_div
6120 |  |  |  |  | { my( $elt)= @_;
6121 |  |  |  |  | $elt->set_class( $elt->tag) unless( $elt->tag eq 'div' && $elt->class); # set class to div unless it would mean replacing it with div
6122 |  |  |  |  | $elt->set_tag( 'div');
6123 |  |  |  |  | }
6124 |  |  |  |  |
6125 |  |  |  |  | sub in_class
6126 |  |  |  |  | { my( $elt, $class)= @_;
6127 |  |  |  |  | my $elt_class= $elt->class;
6128 |  |  |  |  | return unless( defined $elt_class);
6129 |  |  |  |  | return $elt->class=~ m{(?:^|\s)\Q$class\E(?:\s|$)} ? $elt : 0;
6130 |  |  |  |  | }
6131 |  |  |  |  |
6132 |  |  |  |  |
6133 |  |  |  |  | # get or set all attributes
6134 |  |  |  |  | # argument can be a hash or a hashref
6135 |  |  |  |  | sub set_atts
6136 | 364369 | 43.3ms |  |  | # spent 1.69s (1.56+128ms) within XML::Twig::Elt::set_atts which was called 364369 times, avg 5µs/call: # 364369 times (1.56s+128ms) by XML::Twig::_twig_start at line 2080, avg 5µs/call { my $elt= shift;
6137 | 364369 | 41.3ms |  |  | my %atts;
6138 | 364369 | 181ms | 364369 | 128ms | tie %atts, 'Tie::IxHash' if( keep_atts_order()); # spent 128ms making 364369 calls to XML::Twig::Elt::keep_atts_order, avg 352ns/call
6139 | 364369 | 318ms |  |  | %atts= @_ == 1 ? %{$_[0]} : @_;
6140 | 364369 | 106ms |  |  | $elt->{att}= \%atts;
6141 | 364369 | 62.8ms |  |  | if( exists $atts{$ID}) { $elt->_set_id( $atts{$ID}); }
6142 | 364369 | 793ms |  |  | return $elt;
6143 |  |  |  |  | }
6144 |  |  |  |  |
6145 |  |  |  |  | sub atts { return $_[0]->{att}; }
6146 |  |  |  |  | sub att_names { return (sort keys %{$_[0]->{att}}); }
6147 |  |  |  |  | sub del_atts { $_[0]->{att}={}; return $_[0]; }
6148 |  |  |  |  |
6149 |  |  |  |  | # get or set a single attribute (set works for several atts)
6150 |  |  |  |  | sub set_att
6151 |  |  |  |  | { my $elt= shift;
6152 |  |  |  |  |
6153 |  |  |  |  | if( $_[0] && ref( $_[0]) && !$_[1])
6154 |  |  |  |  | { croak "improper call to set_att, usage is \$elt->set_att( att1 => 'val1', att2 => 'val2',...)"; }
6155 |  |  |  |  |
6156 |  |  |  |  | unless( $elt->{att})
6157 |  |  |  |  | { $elt->{att}={};
6158 |  |  |  |  | tie %{$elt->{att}}, 'Tie::IxHash' if( keep_atts_order());
6159 |  |  |  |  | }
6160 |  |  |  |  |
6161 |  |  |  |  | while(@_)
6162 |  |  |  |  | { my( $att, $val)= (shift, shift);
6163 |  |  |  |  | $elt->{att}->{$att}= $val;
6164 |  |  |  |  | if( $att eq $ID) { $elt->_set_id( $val); }
6165 |  |  |  |  | }
6166 |  |  |  |  | return $elt;
6167 |  |  |  |  | }
6168 |  |  |  |  |
6169 | 674081 | 1.19s |  |  | # spent 278ms within XML::Twig::Elt::att which was called 674081 times, avg 412ns/call: # 202907 times (100ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 358 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 493ns/call # 202907 times (73.0ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 407 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 360ns/call # 202907 times (68.3ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 373 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 336ns/call # 18180 times (12.4ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:302] at line 292 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 684ns/call # 15608 times (12.8ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 350 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 820ns/call # 15608 times (5.77ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 353 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 369ns/call # 15608 times (5.46ms+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 354 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 350ns/call # 90 times (35µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 913 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 389ns/call # 49 times (15µs+0s) by Spreadsheet::ParseXLSX::_color at line 1132 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 314ns/call # 19 times (6µs+0s) by Spreadsheet::ParseXLSX::_color at line 1131 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 289ns/call # 15 times (5µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 916 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 353ns/call # 15 times (5µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 917 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 347ns/call # 15 times (5µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 920 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 320ns/call # 15 times (5µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 922 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 313ns/call # 15 times (4µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 919 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 293ns/call # 15 times (4µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 921 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 260ns/call # 12 times (7µs+0s) by Spreadsheet::ParseXLSX::_parse_themes at line 672 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 600ns/call # 12 times (4µs+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:268] at line 264 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 367ns/call # 11 times (3µs+0s) by Spreadsheet::ParseXLSX::_color at line 1150 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 245ns/call # 10 times (7µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 821 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 720ns/call # 5 times (3µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 830 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 600ns/call # 5 times (2µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 927 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 320ns/call # 5 times (1µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 926 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 260ns/call # 5 times (1µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 928 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 260ns/call # 5 times (1µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 925 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 240ns/call # 5 times (1µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 929 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 240ns/call # 5 times (1µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 930 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 240ns/call # 3 times (2µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 860 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 767ns/call # 3 times (2µs+0s) by Spreadsheet::ParseXLSX::_parse_workbook at line 139 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 700ns/call # 3 times (2µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 862 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 533ns/call # 2 times (2µs+0s) by Spreadsheet::ParseXLSX::_extract_files at line 985 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 750ns/call # 2 times (2µs+0s) by Spreadsheet::ParseXLSX::_extract_files at line 1010 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 750ns/call # 2 times (1µs+0s) by Spreadsheet::ParseXLSX::_parse_styles at line 827 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 600ns/call # 2 times (900ns+0s) by Spreadsheet::ParseXLSX::_color at line 1142 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 450ns/call # once (2µs+0s) by Spreadsheet::ParseXLSX::_parse_workbook at line 205 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (2µs+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:246] at line 238 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (2µs+0s) by Spreadsheet::ParseXLSX::_extract_files at line 966 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (1µs+0s) by Spreadsheet::ParseXLSX::_extract_files at line 981 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (1µs+0s) by Spreadsheet::ParseXLSX::_extract_files at line 993 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (1µs+0s) by Spreadsheet::ParseXLSX::_parse_workbook at line 177 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (800ns+0s) by Spreadsheet::ParseXLSX::_extract_files at line 983 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (800ns+0s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:338] at line 330 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (600ns+0s) by Spreadsheet::ParseXLSX::_parse_workbook at line 184 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (500ns+0s) by Spreadsheet::ParseXLSX::_parse_workbook at line 179 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm # once (400ns+0s) by Spreadsheet::ParseXLSX::_parse_workbook at line 148 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm sub att { $_[0]->{att}->{$_[1]}; }
6170 |  |  |  |  | # lvalue version of att. separate from class to avoid problem like RT#
6171 |  |  |  |  | sub latt
6172 |  |  |  |  | :lvalue # > perl 5.5
6173 |  |  |  |  | { $_[0]->{att}->{$_[1]}; }
6174 |  |  |  |  |
6175 |  |  |  |  | sub del_att
6176 |  |  |  |  | { my $elt= shift;
6177 |  |  |  |  | while( @_) { delete $elt->{'att'}->{shift()}; }
6178 |  |  |  |  | return $elt;
6179 |  |  |  |  | }
6180 |  |  |  |  |
6181 |  |  |  |  | sub att_exists { return exists $_[0]->{att}->{$_[1]}; }
6182 |  |  |  |  |
6183 |  |  |  |  | # delete an attribute from all descendants of an element
6184 |  |  |  |  | sub strip_att
6185 |  |  |  |  | { my( $elt, $att)= @_;
6186 |  |  |  |  | $_->del_att( $att) foreach ($elt->descendants_or_self( qq{*[\@$att]}));
6187 |  |  |  |  | return $elt;
6188 |  |  |  |  | }
6189 |  |  |  |  |
6190 |  |  |  |  | sub change_att_name
6191 |  |  |  |  | { my( $elt, $old_name, $new_name)= @_;
6192 |  |  |  |  | my $value= $elt->{'att'}->{$old_name};
6193 |  |  |  |  | return $elt unless( defined $value);
6194 |  |  |  |  | $elt->del_att( $old_name)
6195 |  |  |  |  | ->set_att( $new_name => $value);
6196 |  |  |  |  | return $elt;
6197 |  |  |  |  | }
6198 |  |  |  |  |
6199 |  |  |  |  | sub lc_attnames
6200 |  |  |  |  | { my $elt= shift;
6201 |  |  |  |  | foreach my $att ($elt->att_names)
6202 |  |  |  |  | { if( $att ne lc $att) { $elt->change_att_name( $att, lc $att); } }
6203 |  |  |  |  | return $elt;
6204 |  |  |  |  | }
6205 |  |  |  |  |
6206 |  |  |  |  | sub set_twig_current { $_[0]->{twig_current}=1; }
6207 |  |  |  |  | sub del_twig_current { delete $_[0]->{twig_current}; }
6208 |  |  |  |  |
6209 |  |  |  |  |
6210 |  |  |  |  | # get or set the id attribute
6211 |  |  |  |  | sub set_id
6212 |  |  |  |  | { my( $elt, $id)= @_;
6213 |  |  |  |  | $elt->del_id() if( exists $elt->{att}->{$ID});
6214 |  |  |  |  | $elt->set_att($ID, $id);
6215 |  |  |  |  | $elt->_set_id( $id);
6216 |  |  |  |  | return $elt;
6217 |  |  |  |  | }
6218 |  |  |  |  |
6219 |  |  |  |  | # only set id, does not update the attribute value
6220 |  |  |  |  | sub _set_id
6221 |  |  |  |  | { my( $elt, $id)= @_;
6222 |  |  |  |  | my $t= $elt->twig || $elt;
6223 |  |  |  |  | $t->{twig_id_list}->{$id}= $elt;
6224 |  |  |  |  | if( $XML::Twig::weakrefs) { weaken( $t->{twig_id_list}->{$id}); }
6225 |  |  |  |  | return $elt;
6226 |  |  |  |  | }
6227 |  |  |  |  |
6228 |  |  |  |  | sub id { return $_[0]->{att}->{$ID}; }
6229 |  |  |  |  |
6230 |  |  |  |  | # methods used to add ids to elements that don't have one
6231 |  |  |  |  | BEGIN
6232 | 1 | 300ns |  |  | # spent 3µs within XML::Twig::Elt::BEGIN@6232 which was called: # once (3µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 6248 { my $id_nb = "0001";
6233 | 1 | 4µs |  |  | my $id_seed = "twig_id_";
6234 |  |  |  |  |
6235 |  |  |  |  | sub set_id_seed ## no critic (Subroutines::ProhibitNestedSubs);
6236 |  |  |  |  | { $id_seed= $_[1]; $id_nb=1; }
6237 |  |  |  |  |
6238 |  |  |  |  | sub add_id ## no critic (Subroutines::ProhibitNestedSubs);
6239 |  |  |  |  | { my $elt= shift;
6240 |  |  |  |  | if( defined $elt->{'att'}->{$ID})
6241 |  |  |  |  | { return $elt->{'att'}->{$ID}; }
6242 |  |  |  |  | else
6243 |  |  |  |  | { my $id= $_[0] && ref( $_[0]) && isa( $_[0], 'CODE') ? $_[0]->( $elt) : $id_seed . $id_nb++;
6244 |  |  |  |  | $elt->set_id( $id);
6245 |  |  |  |  | return $id;
6246 |  |  |  |  | }
6247 |  |  |  |  | }
6248 | 1 | 2.61ms | 1 | 3µs | } # spent 3µs making 1 call to XML::Twig::Elt::BEGIN@6232
6249 |  |  |  |  |
- - |  |  |  |  |
6252 |  |  |  |  | # delete the id attribute and remove the element from the id list
6253 |  |  |  |  | sub del_id
6254 |  |  |  |  | { my $elt= shift;
6255 |  |  |  |  | if( ! exists $elt->{att}->{$ID}) { return $elt };
6256 |  |  |  |  | my $id= $elt->{att}->{$ID};
6257 |  |  |  |  |
6258 |  |  |  |  | delete $elt->{att}->{$ID};
6259 |  |  |  |  |
6260 |  |  |  |  | my $t= shift || $elt->twig;
6261 |  |  |  |  | unless( $t) { return $elt; }
6262 |  |  |  |  | if( exists $t->{twig_id_list}->{$id}) { delete $t->{twig_id_list}->{$id}; }
6263 |  |  |  |  |
6264 |  |  |  |  | return $elt;
6265 |  |  |  |  | }
6266 |  |  |  |  |
6267 |  |  |  |  | # return the list of children
6268 |  |  |  |  | sub children
6269 | 15651 | 1.60ms |  |  | # spent 1.57s (500ms+1.07) within XML::Twig::Elt::children which was called 15651 times, avg 101µs/call: # 15608 times (500ms+1.07s) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 357 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 101µs/call # 15 times (47µs+18µs) by Spreadsheet::ParseXLSX::_get_text_and_rich_font_by_cell at line 582 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 4µs/call # 13 times (44µs+15µs) by XML::Twig::Elt::__ANON__[(eval 68)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 68)[XML/Twig.pm:7113], avg 4µs/call # 11 times (34µs+238µs) by XML::Twig::Elt::__ANON__[(eval 70)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 70)[XML/Twig.pm:7113], avg 25µs/call # once (16µs+116µs) by XML::Twig::Elt::__ANON__[(eval 97)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 97)[XML/Twig.pm:7113] # once (4µs+104µs) by XML::Twig::Elt::__ANON__[(eval 76)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 76)[XML/Twig.pm:7113] # once (6µs+100µs) by XML::Twig::Elt::__ANON__[(eval 87)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 87)[XML/Twig.pm:7113] # once (4µs+88µs) by XML::Twig::Elt::__ANON__[(eval 103)[/home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/XML/Twig.pm:7113]:1] at line 1 of (eval 103)[XML/Twig.pm:7113] { my $elt= shift;
6270 | 15651 | 1.67ms |  |  | my @children;
6271 | 15651 | 11.9ms | 15651 | 116ms | my $child= $elt->first_child( @_); # spent 116ms making 15651 calls to XML::Twig::Elt::first_child, avg 7µs/call
6272 | 15651 | 11.2ms |  |  | while( $child)
6273 | 202986 | 17.0ms |  |  | { push @children, $child;
6274 | 202986 | 104ms | 202986 | 958ms | $child= $child->next_sibling( @_); # spent 958ms making 202986 calls to XML::Twig::Elt::next_sibling, avg 5µs/call
6275 |  |  |  |  | }
6276 | 15651 | 32.0ms |  |  | return @children;
6277 |  |  |  |  | }
6278 |  |  |  |  |
6279 |  |  |  |  | sub _children
6280 |  |  |  |  | { my $elt= shift;
6281 |  |  |  |  | my @children=();
6282 |  |  |  |  | my $child= $elt->{first_child};
6283 |  |  |  |  | while( $child)
6284 |  |  |  |  | { push @children, $child;
6285 |  |  |  |  | $child= $child->{next_sibling};
6286 |  |  |  |  | }
6287 |  |  |  |  | return @children;
6288 |  |  |  |  | }
6289 |  |  |  |  |
6290 |  |  |  |  | sub children_copy
6291 |  |  |  |  | { my $elt= shift;
6292 |  |  |  |  | my @children;
6293 |  |  |  |  | my $child= $elt->first_child( @_);
6294 |  |  |  |  | while( $child)
6295 |  |  |  |  | { push @children, $child->copy;
6296 |  |  |  |  | $child= $child->next_sibling( @_);
6297 |  |  |  |  | }
6298 |  |  |  |  | return @children;
6299 |  |  |  |  | }
6300 |  |  |  |  |
6301 |  |  |  |  |
6302 |  |  |  |  | sub children_count
6303 |  |  |  |  | { my $elt= shift;
6304 |  |  |  |  | my $cond= shift;
6305 |  |  |  |  | my $count=0;
6306 |  |  |  |  | my $child= $elt->{first_child};
6307 |  |  |  |  | while( $child)
6308 |  |  |  |  | { $count++ if( $child->passes( $cond));
6309 |  |  |  |  | $child= $child->{next_sibling};
6310 |  |  |  |  | }
6311 |  |  |  |  | return $count;
6312 |  |  |  |  | }
6313 |  |  |  |  |
6314 |  |  |  |  | sub children_text
6315 |  |  |  |  | { my $elt= shift;
6316 |  |  |  |  | return wantarray() ? map { $_->text} $elt->children( @_)
6317 |  |  |  |  | : join( '', map { $_->text} $elt->children( @_) )
6318 |  |  |  |  | ;
6319 |  |  |  |  | }
6320 |  |  |  |  |
6321 |  |  |  |  | sub children_trimmed_text
6322 |  |  |  |  | { my $elt= shift;
6323 |  |  |  |  | return wantarray() ? map { $_->trimmed_text} $elt->children( @_)
6324 |  |  |  |  | : join( '', map { $_->trimmed_text} $elt->children( @_) )
6325 |  |  |  |  | ;
6326 |  |  |  |  | }
6327 |  |  |  |  |
6328 |  |  |  |  | sub all_children_are
6329 |  |  |  |  | { my( $parent, $cond)= @_;
6330 |  |  |  |  | foreach my $child ($parent->_children)
6331 |  |  |  |  | { return 0 unless( $child->passes( $cond)); }
6332 |  |  |  |  | return $parent;
6333 |  |  |  |  | }
6334 |  |  |  |  |
6335 |  |  |  |  |
6336 |  |  |  |  | sub ancestors
6337 | 154 | 18µs |  |  | # spent 649µs (527+121) within XML::Twig::Elt::ancestors which was called 154 times, avg 4µs/call: # 77 times (265µs+60µs) by XML::Twig::Elt::cmp at line 9725, avg 4µs/call # 77 times (262µs+62µs) by XML::Twig::Elt::cmp at line 9726, avg 4µs/call { my( $elt, $cond)= @_;
6338 | 154 | 8µs |  |  | my @ancestors;
6339 | 154 | 25µs |  |  | while( $elt->{parent})
6340 | 442 | 39µs |  |  | { $elt= $elt->{parent};
6341 | 442 | 228µs | 442 | 122µs | push @ancestors, $elt if( $elt->passes( $cond)); # spent 122µs making 442 calls to XML::Twig::Elt::passes, avg 275ns/call
6342 |  |  |  |  | }
6343 | 154 | 96µs |  |  | return @ancestors;
6344 |  |  |  |  | }
6345 |  |  |  |  |
6346 |  |  |  |  | sub ancestors_or_self
6347 |  |  |  |  | { my( $elt, $cond)= @_;
6348 |  |  |  |  | my @ancestors;
6349 |  |  |  |  | while( $elt)
6350 |  |  |  |  | { push @ancestors, $elt if( $elt->passes( $cond));
6351 |  |  |  |  | $elt= $elt->{parent};
6352 |  |  |  |  | }
6353 |  |  |  |  | return @ancestors;
6354 |  |  |  |  | }
6355 |  |  |  |  |
6356 |  |  |  |  |
6357 |  |  |  |  | sub _ancestors
6358 |  |  |  |  | { my( $elt, $include_self)= @_;
6359 |  |  |  |  | my @ancestors= $include_self ? ($elt) : ();
6360 |  |  |  |  | while( $elt= $elt->{parent}) { push @ancestors, $elt; }
6361 |  |  |  |  | return @ancestors;
6362 |  |  |  |  | }
6363 |  |  |  |  |
6364 |  |  |  |  |
6365 |  |  |  |  | sub inherit_att
6366 |  |  |  |  | { my $elt= shift;
6367 |  |  |  |  | my $att= shift;
6368 |  |  |  |  | my %tags= map { ($_, 1) } @_;
6369 |  |  |  |  |
6370 |  |  |  |  | do
6371 |  |  |  |  | { if( (defined $elt->{'att'}->{$att})
6372 |  |  |  |  | && ( !%tags || $tags{$XML::Twig::index2gi[$elt->{'gi'}]})
6373 |  |  |  |  | )
6374 |  |  |  |  | { return $elt->{'att'}->{$att}; }
6375 |  |  |  |  | } while( $elt= $elt->{parent});
6376 |  |  |  |  | return undef;
6377 |  |  |  |  | }
6378 |  |  |  |  |
6379 |  |  |  |  | sub _inherit_att_through_cut
6380 |  |  |  |  | { my $elt= shift;
6381 |  |  |  |  | my $att= shift;
6382 |  |  |  |  | my %tags= map { ($_, 1) } @_;
6383 |  |  |  |  |
6384 |  |  |  |  | do
6385 |  |  |  |  | { if( (defined $elt->{'att'}->{$att})
6386 |  |  |  |  | && ( !%tags || $tags{$XML::Twig::index2gi[$elt->{'gi'}]})
6387 |  |  |  |  | )
6388 |  |  |  |  | { return $elt->{'att'}->{$att}; }
6389 |  |  |  |  | } while( $elt= $elt->{parent} || ($elt->{former} && $elt->{former}->{parent}));
6390 |  |  |  |  | return undef;
6391 |  |  |  |  | }
6392 |  |  |  |  |
6393 |  |  |  |  |
6394 |  |  |  |  | sub current_ns_prefixes
6395 |  |  |  |  | { my $elt= shift;
6396 |  |  |  |  | my %prefix;
6397 |  |  |  |  | $prefix{''}=1 if( $elt->namespace( ''));
6398 |  |  |  |  | while( $elt)
6399 |  |  |  |  | { my @ns= grep { !m{^xml} } map { m{^([^:]+):} } ($XML::Twig::index2gi[$elt->{'gi'}], $elt->att_names);
6400 |  |  |  |  | $prefix{$_}=1 foreach (@ns);
6401 |  |  |  |  | $elt= $elt->{parent};
6402 |  |  |  |  | }
6403 |  |  |  |  |
6404 |  |  |  |  | return (sort keys %prefix);
6405 |  |  |  |  | }
6406 |  |  |  |  |
6407 |  |  |  |  | # kinda counter-intuitive actually:
6408 |  |  |  |  | # the next element is found by looking for the next open tag after from the
6409 |  |  |  |  | # current one, which is the first child, if it exists, or the next sibling
6410 |  |  |  |  | # or the first next sibling of an ancestor
6411 |  |  |  |  | # optional arguments are:
6412 |  |  |  |  | # - $subtree_root: a reference to an element, when the next element is not
6413 |  |  |  |  | # within $subtree_root anymore then next_elt returns undef
6414 |  |  |  |  | # - $cond: a condition, next_elt returns the next element matching the condition
6415 |  |  |  |  |
6416 |  |  |  |  | sub next_elt
6417 | 1 | 300ns |  |  | # spent 252µs (136+117) within XML::Twig::Elt::next_elt which was called: # once (136µs+117µs) by XML::Twig::Elt::descendants at line 6875 { my $elt= shift;
6418 | 1 | 300ns |  |  | my $subtree_root= 0;
6419 | 1 | 4µs | 1 | 800ns | $subtree_root= shift if( ref( $_[0]) && isa( $_[0], 'XML::Twig::Elt')); # spent 800ns making 1 call to UNIVERSAL::isa
6420 | 1 | 200ns |  |  | my $cond= shift;
6421 | 1 | 300ns |  |  | my $next_elt;
6422 |  |  |  |  |
6423 |  |  |  |  | my $ind; # optimization
6424 |  |  |  |  | my $test_cond;
6425 | 1 | 1µs |  |  | if( $cond) # optimization
6426 |  |  |  |  | { unless( defined( $ind= $XML::Twig::gi2index{$cond}) ) # optimization
6427 |  |  |  |  | { $test_cond= ($cond_cache{$cond} ||= _install_cond( $cond)); } # optimization
6428 |  |  |  |  | } # optimization
6429 |  |  |  |  |
6430 |  |  |  |  | do
6431 | 103 | 19µs |  |  | { if( $next_elt= $elt->{first_child})
6432 |  |  |  |  | { # simplest case: the elt has a child
6433 |  |  |  |  | }
6434 |  |  |  |  | elsif( $next_elt= $elt->{next_sibling})
6435 |  |  |  |  | { # no child but a next sibling (just check we stay within the subtree)
6436 |  |  |  |  |
6437 |  |  |  |  | # case where elt is subtree_root, is empty and has a sibling
6438 |  |  |  |  | return undef if( $subtree_root && ($elt == $subtree_root));
6439 |  |  |  |  |
6440 |  |  |  |  | }
6441 |  |  |  |  | else
6442 |  |  |  |  | { # case where the element has no child and no next sibling:
6443 |  |  |  |  | # get the first next sibling of an ancestor, checking subtree_root
6444 |  |  |  |  |
6445 |  |  |  |  | # case where elt is subtree_root, is empty and has no sibling
6446 | 24 | 3µs |  |  | return undef if( $subtree_root && ($elt == $subtree_root));
6447 |  |  |  |  |
6448 | 24 | 3µs |  |  | $next_elt= $elt->{parent} || return undef;
6449 |  |  |  |  |
6450 | 24 | 4µs |  |  | until( $next_elt->{next_sibling})
6451 | 16 | 4µs |  |  | { return undef if( $subtree_root && ($subtree_root == $next_elt));
6452 | 15 | 3µs |  |  | $next_elt= $next_elt->{parent} || return undef;
6453 |  |  |  |  | }
6454 | 23 | 3µs |  |  | return undef if( $subtree_root && ($subtree_root == $next_elt));
6455 | 23 | 3µs |  |  | $next_elt= $next_elt->{next_sibling};
6456 |  |  |  |  | }
6457 | 102 | 6µs |  |  | $elt= $next_elt; # just in case we need to loop
6458 |  |  |  |  | } until( ! defined $elt
6459 |  |  |  |  | || ! defined $cond
6460 | 1 | 43µs | 102 | 116µs | || (defined $ind && ($elt->{gi} eq $ind)) # optimization # spent 116µs making 102 calls to XML::Twig::Elt::__ANON__[(eval 86)[XML/Twig.pm:5871]:1], avg 1µs/call
6461 |  |  |  |  | || (defined $test_cond && ($test_cond->( $elt)))
6462 |  |  |  |  | );
6463 |  |  |  |  |
6464 |  |  |  |  | return $elt;
6465 |  |  |  |  | }
6466 |  |  |  |  |
6467 |  |  |  |  | # return the next_elt within the element
6468 |  |  |  |  | # just call next_elt with the element as first and second argument
6469 |  |  |  |  | sub first_descendant { return $_[0]->next_elt( @_); }
6470 |  |  |  |  |
6471 |  |  |  |  | # get the last descendant, # then return the element found or call prev_elt with the condition
6472 |  |  |  |  | sub last_descendant
6473 |  |  |  |  | { my( $elt, $cond)= @_;
6474 |  |  |  |  | my $last_descendant= $elt->_last_descendant;
6475 |  |  |  |  | if( !$cond || $last_descendant->matches( $cond))
6476 |  |  |  |  | { return $last_descendant; }
6477 |  |  |  |  | else
6478 |  |  |  |  | { return $last_descendant->prev_elt( $elt, $cond); }
6479 |  |  |  |  | }
6480 |  |  |  |  |
6481 |  |  |  |  | # no argument allowed here, just go down the last_child recursively
6482 |  |  |  |  | sub _last_descendant
6483 |  |  |  |  | { my $elt= shift;
6484 |  |  |  |  | while( my $child= $elt->{last_child}) { $elt= $child; }
6485 |  |  |  |  | return $elt;
6486 |  |  |  |  | }
6487 |  |  |  |  |
6488 |  |  |  |  | # counter-intuitive too:
6489 |  |  |  |  | # the previous element is found by looking
6490 |  |  |  |  | # for the first open tag backwards from the current one
6491 |  |  |  |  | # it's the last descendant of the previous sibling
6492 |  |  |  |  | # if it exists, otherwise it's simply the parent
6493 |  |  |  |  | sub prev_elt
6494 |  |  |  |  | { my $elt= shift;
6495 |  |  |  |  | my $subtree_root= 0;
6496 |  |  |  |  | if( defined $_[0] and (ref( $_[0]) && isa( $_[0], 'XML::Twig::Elt')))
6497 |  |  |  |  | { $subtree_root= shift ;
6498 |  |  |  |  | return undef if( $elt == $subtree_root);
6499 |  |  |  |  | }
6500 |  |  |  |  | my $cond= shift;
6501 |  |  |  |  | # get prev elt
6502 |  |  |  |  | my $prev_elt;
6503 |  |  |  |  | do
6504 |  |  |  |  | { return undef if( $elt == $subtree_root);
6505 |  |  |  |  | if( $prev_elt= $elt->{prev_sibling})
6506 |  |  |  |  | { while( $prev_elt->{last_child})
6507 |  |  |  |  | { $prev_elt= $prev_elt->{last_child}; }
6508 |  |  |  |  | }
6509 |  |  |  |  | else
6510 |  |  |  |  | { $prev_elt= $elt->{parent} || return undef; }
6511 |  |  |  |  | $elt= $prev_elt; # in case we need to loop
6512 |  |  |  |  | } until( $elt->passes( $cond));
6513 |  |  |  |  |
6514 |  |  |  |  | return $elt;
6515 |  |  |  |  | }
6516 |  |  |  |  |
6517 |  |  |  |  | sub _following_elt
6518 |  |  |  |  | { my( $elt)= @_;
6519 |  |  |  |  | while( $elt && !$elt->{next_sibling})
6520 |  |  |  |  | { $elt= $elt->{parent}; }
6521 |  |  |  |  | return $elt ? $elt->{next_sibling} : undef;
6522 |  |  |  |  | }
6523 |  |  |  |  |
6524 |  |  |  |  | sub following_elt
6525 |  |  |  |  | { my( $elt, $cond)= @_;
6526 |  |  |  |  | $elt= $elt->_following_elt || return undef;
6527 |  |  |  |  | return $elt if( !$cond || $elt->matches( $cond));
6528 |  |  |  |  | return $elt->next_elt( $cond);
6529 |  |  |  |  | }
6530 |  |  |  |  |
6531 |  |  |  |  | sub following_elts
6532 |  |  |  |  | { my( $elt, $cond)= @_;
6533 |  |  |  |  | if( !$cond) { undef $cond; }
6534 |  |  |  |  | my $following= $elt->following_elt( $cond);
6535 |  |  |  |  | if( $following)
6536 |  |  |  |  | { my @followings= $following;
6537 |  |  |  |  | while( $following= $following->next_elt( $cond))
6538 |  |  |  |  | { push @followings, $following; }
6539 |  |  |  |  | return( @followings);
6540 |  |  |  |  | }
6541 |  |  |  |  | else
6542 |  |  |  |  | { return (); }
6543 |  |  |  |  | }
6544 |  |  |  |  |
6545 |  |  |  |  | sub _preceding_elt
6546 |  |  |  |  | { my( $elt)= @_;
6547 |  |  |  |  | while( $elt && !$elt->{prev_sibling})
6548 |  |  |  |  | { $elt= $elt->{parent}; }
6549 |  |  |  |  | return $elt ? $elt->{prev_sibling}->_last_descendant : undef;
6550 |  |  |  |  | }
6551 |  |  |  |  |
6552 |  |  |  |  | sub preceding_elt
6553 |  |  |  |  | { my( $elt, $cond)= @_;
6554 |  |  |  |  | $elt= $elt->_preceding_elt || return undef;
6555 |  |  |  |  | return $elt if( !$cond || $elt->matches( $cond));
6556 |  |  |  |  | return $elt->prev_elt( $cond);
6557 |  |  |  |  | }
6558 |  |  |  |  |
6559 |  |  |  |  | sub preceding_elts
6560 |  |  |  |  | { my( $elt, $cond)= @_;
6561 |  |  |  |  | if( !$cond) { undef $cond; }
6562 |  |  |  |  | my $preceding= $elt->preceding_elt( $cond);
6563 |  |  |  |  | if( $preceding)
6564 |  |  |  |  | { my @precedings= $preceding;
6565 |  |  |  |  | while( $preceding= $preceding->prev_elt( $cond))
6566 |  |  |  |  | { push @precedings, $preceding; }
6567 |  |  |  |  | return( @precedings);
6568 |  |  |  |  | }
6569 |  |  |  |  | else
6570 |  |  |  |  | { return (); }
6571 |  |  |  |  | }
6572 |  |  |  |  |
6573 |  |  |  |  | # used in get_xpath
6574 |  |  |  |  | sub _self
6575 |  |  |  |  | { my( $elt, $cond)= @_;
6576 |  |  |  |  | return $cond ? $elt->matches( $cond) : $elt;
6577 |  |  |  |  | }
6578 |  |  |  |  |
6579 |  |  |  |  | sub next_n_elt
6580 |  |  |  |  | { my $elt= shift;
6581 |  |  |  |  | my $offset= shift || return undef;
6582 |  |  |  |  | foreach (1..$offset)
6583 |  |  |  |  | { $elt= $elt->next_elt( @_) || return undef; }
6584 |  |  |  |  | return $elt;
6585 |  |  |  |  | }
6586 |  |  |  |  |
6587 |  |  |  |  | # checks whether $elt is included in $ancestor, returns 1 in that case
6588 |  |  |  |  | sub in
6589 | 67768 | 9.70ms |  |  | # spent 203ms (177+26.7) within XML::Twig::Elt::in which was called 67768 times, avg 3µs/call: # 67614 times (176ms+26.7ms) by XML::Twig::purge at line 3546, avg 3µs/call # 77 times (148µs+14µs) by XML::Twig::Elt::cmp at line 9721, avg 2µs/call # 77 times (119µs+8µs) by XML::Twig::Elt::cmp at line 9722, avg 2µs/call { my ($elt, $ancestor)= @_;
6590 | 67768 | 144ms | 67768 | 26.7ms | if( ref( $ancestor) && isa( $ancestor, 'XML::Twig::Elt')) # spent 26.7ms making 67768 calls to UNIVERSAL::isa, avg 395ns/call
6591 |  |  |  |  | { # element
6592 | 68056 | 78.0ms |  |  | while( $elt= $elt->{parent}) { return $elt if( $elt == $ancestor); }
6593 |  |  |  |  | }
6594 |  |  |  |  | else
6595 |  |  |  |  | { # condition
6596 |  |  |  |  | while( $elt= $elt->{parent}) { return $elt if( $elt->matches( $ancestor)); }
6597 |  |  |  |  | }
6598 | 33961 | 59.9ms |  |  | return 0;
6599 |  |  |  |  | }
6600 |  |  |  |  |
6601 |  |  |  |  | sub first_child_text
6602 |  |  |  |  | { my $elt= shift;
6603 |  |  |  |  | my $dest=$elt->first_child(@_) or return '';
6604 |  |  |  |  | return $dest->text;
6605 |  |  |  |  | }
6606 |  |  |  |  |
6607 |  |  |  |  | sub fields
6608 |  |  |  |  | { my $elt= shift;
6609 |  |  |  |  | return map { $elt->field( $_) } @_;
6610 |  |  |  |  | }
6611 |  |  |  |  |
6612 |  |  |  |  | sub first_child_trimmed_text
6613 |  |  |  |  | { my $elt= shift;
6614 |  |  |  |  | my $dest=$elt->first_child(@_) or return '';
6615 |  |  |  |  | return $dest->trimmed_text;
6616 |  |  |  |  | }
6617 |  |  |  |  |
6618 |  |  |  |  | sub first_child_matches
6619 |  |  |  |  | { my $elt= shift;
6620 |  |  |  |  | my $dest= $elt->{first_child} or return undef;
6621 |  |  |  |  | return $dest->passes( @_);
6622 |  |  |  |  | }
6623 |  |  |  |  |
6624 |  |  |  |  | sub last_child_text
6625 |  |  |  |  | { my $elt= shift;
6626 |  |  |  |  | my $dest=$elt->last_child(@_) or return '';
6627 |  |  |  |  | return $dest->text;
6628 |  |  |  |  | }
6629 |  |  |  |  |
6630 |  |  |  |  | sub last_child_trimmed_text
6631 |  |  |  |  | { my $elt= shift;
6632 |  |  |  |  | my $dest=$elt->last_child(@_) or return '';
6633 |  |  |  |  | return $dest->trimmed_text;
6634 |  |  |  |  | }
6635 |  |  |  |  |
6636 |  |  |  |  | sub last_child_matches
6637 |  |  |  |  | { my $elt= shift;
6638 |  |  |  |  | my $dest= $elt->{last_child} or return undef;
6639 |  |  |  |  | return $dest->passes( @_);
6640 |  |  |  |  | }
6641 |  |  |  |  |
6642 |  |  |  |  | sub child_text
6643 |  |  |  |  | { my $elt= shift;
6644 |  |  |  |  | my $dest=$elt->child(@_) or return '';
6645 |  |  |  |  | return $dest->text;
6646 |  |  |  |  | }
6647 |  |  |  |  |
6648 |  |  |  |  | sub child_trimmed_text
6649 |  |  |  |  | { my $elt= shift;
6650 |  |  |  |  | my $dest=$elt->child(@_) or return '';
6651 |  |  |  |  | return $dest->trimmed_text;
6652 |  |  |  |  | }
6653 |  |  |  |  |
6654 |  |  |  |  | sub child_matches
6655 |  |  |  |  | { my $elt= shift;
6656 |  |  |  |  | my $nb= shift;
6657 |  |  |  |  | my $dest= $elt->child( $nb) or return undef;
6658 |  |  |  |  | return $dest->passes( @_);
6659 |  |  |  |  | }
6660 |  |  |  |  |
6661 |  |  |  |  | sub prev_sibling_text
6662 |  |  |  |  | { my $elt= shift;
6663 |  |  |  |  | my $dest= $elt->_prev_sibling(@_) or return '';
6664 |  |  |  |  | return $dest->text;
6665 |  |  |  |  | }
6666 |  |  |  |  |
6667 |  |  |  |  | sub prev_sibling_trimmed_text
6668 |  |  |  |  | { my $elt= shift;
6669 |  |  |  |  | my $dest= $elt->_prev_sibling(@_) or return '';
6670 |  |  |  |  | return $dest->trimmed_text;
6671 |  |  |  |  | }
6672 |  |  |  |  |
6673 |  |  |  |  | sub prev_sibling_matches
6674 |  |  |  |  | { my $elt= shift;
6675 |  |  |  |  | my $dest= $elt->{prev_sibling} or return undef;
6676 |  |  |  |  | return $dest->passes( @_);
6677 |  |  |  |  | }
6678 |  |  |  |  |
6679 |  |  |  |  | sub next_sibling_text
6680 |  |  |  |  | { my $elt= shift;
6681 |  |  |  |  | my $dest= $elt->next_sibling(@_) or return '';
6682 |  |  |  |  | return $dest->text;
6683 |  |  |  |  | }
6684 |  |  |  |  |
6685 |  |  |  |  | sub next_sibling_trimmed_text
6686 |  |  |  |  | { my $elt= shift;
6687 |  |  |  |  | my $dest= $elt->next_sibling(@_) or return '';
6688 |  |  |  |  | return $dest->trimmed_text;
6689 |  |  |  |  | }
6690 |  |  |  |  |
6691 |  |  |  |  | sub next_sibling_matches
6692 |  |  |  |  | { my $elt= shift;
6693 |  |  |  |  | my $dest= $elt->{next_sibling} or return undef;
6694 |  |  |  |  | return $dest->passes( @_);
6695 |  |  |  |  | }
6696 |  |  |  |  |
6697 |  |  |  |  | sub prev_elt_text
6698 |  |  |  |  | { my $elt= shift;
6699 |  |  |  |  | my $dest= $elt->prev_elt(@_) or return '';
6700 |  |  |  |  | return $dest->text;
6701 |  |  |  |  | }
6702 |  |  |  |  |
6703 |  |  |  |  | sub prev_elt_trimmed_text
6704 |  |  |  |  | { my $elt= shift;
6705 |  |  |  |  | my $dest= $elt->prev_elt(@_) or return '';
6706 |  |  |  |  | return $dest->trimmed_text;
6707 |  |  |  |  | }
6708 |  |  |  |  |
6709 |  |  |  |  | sub prev_elt_matches
6710 |  |  |  |  | { my $elt= shift;
6711 |  |  |  |  | my $dest= $elt->prev_elt or return undef;
6712 |  |  |  |  | return $dest->passes( @_);
6713 |  |  |  |  | }
6714 |  |  |  |  |
6715 |  |  |  |  | sub next_elt_text
6716 |  |  |  |  | { my $elt= shift;
6717 |  |  |  |  | my $dest= $elt->next_elt(@_) or return '';
6718 |  |  |  |  | return $dest->text;
6719 |  |  |  |  | }
6720 |  |  |  |  |
6721 |  |  |  |  | sub next_elt_trimmed_text
6722 |  |  |  |  | { my $elt= shift;
6723 |  |  |  |  | my $dest= $elt->next_elt(@_) or return '';
6724 |  |  |  |  | return $dest->trimmed_text;
6725 |  |  |  |  | }
6726 |  |  |  |  |
6727 |  |  |  |  | sub next_elt_matches
6728 |  |  |  |  | { my $elt= shift;
6729 |  |  |  |  | my $dest= $elt->next_elt or return undef;
6730 |  |  |  |  | return $dest->passes( @_);
6731 |  |  |  |  | }
6732 |  |  |  |  |
6733 |  |  |  |  | sub parent_text
6734 |  |  |  |  | { my $elt= shift;
6735 |  |  |  |  | my $dest= $elt->parent(@_) or return '';
6736 |  |  |  |  | return $dest->text;
6737 |  |  |  |  | }
6738 |  |  |  |  |
6739 |  |  |  |  | sub parent_trimmed_text
6740 |  |  |  |  | { my $elt= shift;
6741 |  |  |  |  | my $dest= $elt->parent(@_) or return '';
6742 |  |  |  |  | return $dest->trimmed_text;
6743 |  |  |  |  | }
6744 |  |  |  |  |
6745 |  |  |  |  | sub parent_matches
6746 |  |  |  |  | { my $elt= shift;
6747 |  |  |  |  | my $dest= $elt->{parent} or return undef;
6748 |  |  |  |  | return $dest->passes( @_);
6749 |  |  |  |  | }
6750 |  |  |  |  |
6751 |  |  |  |  | sub is_first_child
6752 |  |  |  |  | { my $elt= shift;
6753 |  |  |  |  | my $parent= $elt->{parent} or return 0;
6754 |  |  |  |  | my $first_child= $parent->first_child( @_) or return 0;
6755 |  |  |  |  | return ($first_child == $elt) ? $elt : 0;
6756 |  |  |  |  | }
6757 |  |  |  |  |
6758 |  |  |  |  | sub is_last_child
6759 |  |  |  |  | { my $elt= shift;
6760 |  |  |  |  | my $parent= $elt->{parent} or return 0;
6761 |  |  |  |  | my $last_child= $parent->last_child( @_) or return 0;
6762 |  |  |  |  | return ($last_child == $elt) ? $elt : 0;
6763 |  |  |  |  | }
6764 |  |  |  |  |
6765 |  |  |  |  | # returns the depth level of the element
6766 |  |  |  |  | # if 2 parameter are used then counts the 2cd element name in the
6767 |  |  |  |  | # ancestors list
6768 |  |  |  |  | sub level
6769 |  |  |  |  | { my( $elt, $cond)= @_;
6770 |  |  |  |  | my $level=0;
6771 |  |  |  |  | my $name=shift || '';
6772 |  |  |  |  | while( $elt= $elt->{parent}) { $level++ if( !$cond || $elt->matches( $cond)); }
6773 |  |  |  |  | return $level;
6774 |  |  |  |  | }
6775 |  |  |  |  |
6776 |  |  |  |  | # checks whether $elt has an ancestor that satisfies $cond, returns the ancestor
6777 |  |  |  |  | sub in_context
6778 |  |  |  |  | { my ($elt, $cond, $level)= @_;
6779 |  |  |  |  | $level= -1 unless( $level) ; # $level-- will never hit 0
6780 |  |  |  |  |
6781 |  |  |  |  | while( $level)
6782 |  |  |  |  | { $elt= $elt->{parent} or return 0;
6783 |  |  |  |  | if( $elt->matches( $cond)) { return $elt; }
6784 |  |  |  |  | $level--;
6785 |  |  |  |  | }
6786 |  |  |  |  | return 0;
6787 |  |  |  |  | }
6788 |  |  |  |  |
6789 |  |  |  |  | sub _descendants
6790 |  |  |  |  | { my( $subtree_root, $include_self)= @_;
6791 |  |  |  |  | my @descendants= $include_self ? ($subtree_root) : ();
6792 |  |  |  |  |
6793 |  |  |  |  | my $elt= $subtree_root;
6794 |  |  |  |  | my $next_elt;
6795 |  |  |  |  |
6796 |  |  |  |  | MAIN: while( 1)
6797 |  |  |  |  | { if( $next_elt= $elt->{first_child})
6798 |  |  |  |  | { # simplest case: the elt has a child
6799 |  |  |  |  | }
6800 |  |  |  |  | elsif( $next_elt= $elt->{next_sibling})
6801 |  |  |  |  | { # no child but a next sibling (just check we stay within the subtree)
6802 |  |  |  |  |
6803 |  |  |  |  | # case where elt is subtree_root, is empty and has a sibling
6804 |  |  |  |  | last MAIN if( $elt == $subtree_root);
6805 |  |  |  |  | }
6806 |  |  |  |  | else
6807 |  |  |  |  | { # case where the element has no child and no next sibling:
6808 |  |  |  |  | # get the first next sibling of an ancestor, checking subtree_root
6809 |  |  |  |  |
6810 |  |  |  |  | # case where elt is subtree_root, is empty and has no sibling
6811 |  |  |  |  | last MAIN if( $elt == $subtree_root);
6812 |  |  |  |  |
6813 |  |  |  |  | # backtrack until we find a parent with a next sibling
6814 |  |  |  |  | $next_elt= $elt->{parent} || last;
6815 |  |  |  |  | until( $next_elt->{next_sibling})
6816 |  |  |  |  | { last MAIN if( $subtree_root == $next_elt);
6817 |  |  |  |  | $next_elt= $next_elt->{parent} || last MAIN;
6818 |  |  |  |  | }
6819 |  |  |  |  | last MAIN if( $subtree_root == $next_elt);
6820 |  |  |  |  | $next_elt= $next_elt->{next_sibling};
6821 |  |  |  |  | }
6822 |  |  |  |  | $elt= $next_elt || last MAIN;
6823 |  |  |  |  | push @descendants, $elt;
6824 |  |  |  |  | }
6825 |  |  |  |  | return @descendants;
6826 |  |  |  |  | }
6827 |  |  |  |  |
6828 |  |  |  |  |
6829 |  |  |  |  | sub descendants
6830 | 16 | 5µs |  |  | # spent 870µs (618+252) within XML::Twig::Elt::descendants which was called 16 times, avg 54µs/call: # 16 times (618µs+252µs) by XML::Twig::descendants at line 3762, avg 54µs/call { my( $subtree_root, $cond)= @_;
6831 | 16 | 5µs |  |  | my @descendants=();
6832 | 16 | 2µs |  |  | my $elt= $subtree_root;
6833 |  |  |  |  |
6834 |  |  |  |  | # this branch is pure optimization for speed: if $cond is a gi replace it
6835 |  |  |  |  | # by the index of the gi and loop here
6836 |  |  |  |  | # start optimization
6837 | 16 | 2µs |  |  | my $ind;
6838 | 16 | 11µs |  |  | if( !$cond || ( defined ( $ind= $XML::Twig::gi2index{$cond})) )
6839 |  |  |  |  | {
6840 | 15 | 900ns |  |  | my $next_elt;
6841 |  |  |  |  |
6842 | 15 | 2µs |  |  | while( 1)
6843 | 737 | 153µs |  |  | { if( $next_elt= $elt->{first_child})
6844 |  |  |  |  | { # simplest case: the elt has a child
6845 |  |  |  |  | }
6846 |  |  |  |  | elsif( $next_elt= $elt->{next_sibling})
6847 |  |  |  |  | { # no child but a next sibling (just check we stay within the subtree)
6848 |  |  |  |  |
6849 |  |  |  |  | # case where elt is subtree_root, is empty and has a sibling
6850 | 301 | 35µs |  |  | last if( $subtree_root && ($elt == $subtree_root));
6851 |  |  |  |  | }
6852 |  |  |  |  | else
6853 |  |  |  |  | { # case where the element has no child and no next sibling:
6854 |  |  |  |  | # get the first next sibling of an ancestor, checking subtree_root
6855 |  |  |  |  |
6856 |  |  |  |  | # case where elt is subtree_root, is empty and has no sibling
6857 | 166 | 25µs |  |  | last if( $subtree_root && ($elt == $subtree_root));
6858 |  |  |  |  |
6859 |  |  |  |  | # backtrack until we find a parent with a next sibling
6860 | 166 | 21µs |  |  | $next_elt= $elt->{parent} || last undef;
6861 | 166 | 27µs |  |  | until( $next_elt->{next_sibling})
6862 | 119 | 15µs |  |  | { last if( $subtree_root && ($subtree_root == $next_elt));
6863 | 104 | 24µs |  |  | $next_elt= $next_elt->{parent} || last;
6864 |  |  |  |  | }
6865 | 166 | 20µs |  |  | last if( $subtree_root && ($subtree_root == $next_elt));
6866 | 151 | 16µs |  |  | $next_elt= $next_elt->{next_sibling};
6867 |  |  |  |  | }
6868 | 722 | 46µs |  |  | $elt= $next_elt || last;
6869 | 722 | 191µs |  |  | push @descendants, $elt if( !$cond || ($elt->{gi} eq $ind));
6870 |  |  |  |  | }
6871 |  |  |  |  | }
6872 |  |  |  |  | else
6873 |  |  |  |  | { # branch for a complex condition: use the regular (slow but simple) way
6874 |  |  |  |  |
6875 | 1 | 2µs | 1 | 252µs | while( $elt= $elt->next_elt( $subtree_root, $cond)) # spent 252µs making 1 call to XML::Twig::Elt::next_elt
6876 |  |  |  |  | { push @descendants, $elt; }
6877 |  |  |  |  | }
6878 | 16 | 22µs |  |  | return @descendants;
6879 |  |  |  |  | }
6880 |  |  |  |  |
6881 |  |  |  |  |
6882 |  |  |  |  | sub descendants_or_self
6883 |  |  |  |  | { my( $elt, $cond)= @_;
6884 |  |  |  |  | my @descendants= $elt->passes( $cond) ? ($elt) : ();
6885 |  |  |  |  | push @descendants, $elt->descendants( $cond);
6886 |  |  |  |  | return @descendants;
6887 |  |  |  |  | }
6888 |  |  |  |  |
6889 |  |  |  |  | sub sibling
6890 |  |  |  |  | { my $elt= shift;
6891 |  |  |  |  | my $nb= shift;
6892 |  |  |  |  | if( $nb > 0)
6893 |  |  |  |  | { foreach( 1..$nb)
6894 |  |  |  |  | { $elt= $elt->next_sibling( @_) or return undef; }
6895 |  |  |  |  | }
6896 |  |  |  |  | elsif( $nb < 0)
6897 |  |  |  |  | { foreach( 1..(-$nb))
6898 |  |  |  |  | { $elt= $elt->prev_sibling( @_) or return undef; }
6899 |  |  |  |  | }
6900 |  |  |  |  | else # $nb == 0
6901 |  |  |  |  | { return $elt->passes( $_[0]); }
6902 |  |  |  |  | return $elt;
6903 |  |  |  |  | }
6904 |  |  |  |  |
6905 |  |  |  |  | sub sibling_text
6906 |  |  |  |  | { my $elt= sibling( @_);
6907 |  |  |  |  | return $elt ? $elt->text : undef;
6908 |  |  |  |  | }
6909 |  |  |  |  |
6910 |  |  |  |  |
6911 |  |  |  |  | sub child
6912 |  |  |  |  | { my $elt= shift;
6913 |  |  |  |  | my $nb= shift;
6914 |  |  |  |  | if( $nb >= 0)
6915 |  |  |  |  | { $elt= $elt->first_child( @_) or return undef;
6916 |  |  |  |  | foreach( 1..$nb)
6917 |  |  |  |  | { $elt= $elt->next_sibling( @_) or return undef; }
6918 |  |  |  |  | }
6919 |  |  |  |  | else
6920 |  |  |  |  | { $elt= $elt->last_child( @_) or return undef;
6921 |  |  |  |  | foreach( 2..(-$nb))
6922 |  |  |  |  | { $elt= $elt->prev_sibling( @_) or return undef; }
6923 |  |  |  |  | }
6924 |  |  |  |  | return $elt;
6925 |  |  |  |  | }
6926 |  |  |  |  |
6927 |  |  |  |  | sub prev_siblings
6928 |  |  |  |  | { my $elt= shift;
6929 |  |  |  |  | my @siblings=();
6930 |  |  |  |  | while( $elt= $elt->prev_sibling( @_))
6931 |  |  |  |  | { unshift @siblings, $elt; }
6932 |  |  |  |  | return @siblings;
6933 |  |  |  |  | }
6934 |  |  |  |  |
6935 |  |  |  |  | sub siblings
6936 |  |  |  |  | { my $elt= shift;
6937 |  |  |  |  | return grep { $_ ne $elt } $elt->{parent}->children( @_);
6938 |  |  |  |  | }
6939 |  |  |  |  |
6940 |  |  |  |  | sub pos
6941 |  |  |  |  | { my $elt= shift;
6942 |  |  |  |  | return 0 if ($_[0] && !$elt->matches( @_));
6943 |  |  |  |  | my $pos=1;
6944 |  |  |  |  | $pos++ while( $elt= $elt->prev_sibling( @_));
6945 |  |  |  |  | return $pos;
6946 |  |  |  |  | }
6947 |  |  |  |  |
6948 |  |  |  |  |
6949 |  |  |  |  | sub next_siblings
6950 |  |  |  |  | { my $elt= shift;
6951 |  |  |  |  | my @siblings=();
6952 |  |  |  |  | while( $elt= $elt->next_sibling( @_))
6953 |  |  |  |  | { push @siblings, $elt; }
6954 |  |  |  |  | return @siblings;
6955 |  |  |  |  | }
6956 |  |  |  |  |
6957 |  |  |  |  |
6958 |  |  |  |  | # used by get_xpath: parses the xpath expression and generates a sub that performs the
6959 |  |  |  |  | # search
6960 | 1 | 100ns |  |  | { my %axis2method;
6961 | 1 | 9µs |  |  | # spent 6µs within XML::Twig::Elt::BEGIN@6961 which was called: # once (6µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 6973 BEGIN { %axis2method= ( child => 'children',
6962 |  |  |  |  | descendant => 'descendants',
6963 |  |  |  |  | 'descendant-or-self' => 'descendants_or_self',
6964 |  |  |  |  | parent => 'parent_is',
6965 |  |  |  |  | ancestor => 'ancestors',
6966 |  |  |  |  | 'ancestor-or-self' => 'ancestors_or_self',
6967 |  |  |  |  | 'following-sibling' => 'next_siblings',
6968 |  |  |  |  | 'preceding-sibling' => 'prev_siblings',
6969 |  |  |  |  | following => 'following_elts',
6970 |  |  |  |  | preceding => 'preceding_elts',
6971 |  |  |  |  | self => '_self',
6972 |  |  |  |  | );
6973 | 1 | 2.60ms | 1 | 6µs | } # spent 6µs making 1 call to XML::Twig::Elt::BEGIN@6961
6974 |  |  |  |  |
6975 |  |  |  |  | sub _install_xpath
6976 | 15 | 4µs |  |  | # spent 3.48ms (1.98+1.50) within XML::Twig::Elt::_install_xpath which was called 15 times, avg 232µs/call: # 15 times (1.98ms+1.50ms) by XML::Twig::Elt::get_xpath at line 7140, avg 232µs/call { my( $xpath_exp, $type)= @_;
6977 | 15 | 3µs |  |  | my $original_exp= $xpath_exp;
6978 | 15 | 3µs |  |  | my $sub= 'my $elt= shift; my @results;';
6979 |  |  |  |  |
6980 |  |  |  |  | # grab the root if expression starts with a /
6981 | 15 | 41µs | 15 | 20µs | if( $xpath_exp=~ s{^/}{}) # spent 20µs making 15 calls to CORE::subst, avg 1µs/call
6982 |  |  |  |  | { $sub .= '@results= ($elt->twig) || croak "cannot use an XPath query starting with a / on a node not attached to a whole twig";'; }
6983 |  |  |  |  | elsif( $xpath_exp=~ s{^\./}{})
6984 |  |  |  |  | { $sub .= '@results= ($elt);'; }
6985 |  |  |  |  | else
6986 |  |  |  |  | { $sub .= '@results= ($elt);'; }
6987 |  |  |  |  |
6988 |  |  |  |  |
6989 |  |  |  |  | #warn "xpath_exp= '$xpath_exp'\n";
6990 |  |  |  |  |
6991 | 15 | 660µs | 16 | 633µs | while( $xpath_exp && # spent 509µs making 1 call to CORE::regcomp # spent 124µs making 15 calls to CORE::subst, avg 8µs/call
6992 |  |  |  |  | $xpath_exp=~s{^\s*(/?)
6993 |  |  |  |  | # the xxx=~/regexp/ is a pain as it includes /
6994 |  |  |  |  | (\s*(?:(?:($REG_AXIS)::)?(\*|$REG_TAG_PART|\.\.|\.)\s*)?($REG_PREDICATE_ALT*)
6995 |  |  |  |  | )
6996 |  |  |  |  | (/|$)}{}xo)
6997 |  |  |  |  |
6998 | 24 | 35µs |  |  | { my( $wildcard, $sub_exp, $axis, $gi, $predicates)= ($1, $2, $3, $4, $5);
6999 | 24 | 3µs |  |  | if( $axis && ! $gi)
7000 |  |  |  |  | { _croak_and_doublecheck_xpath( $original_exp, "error in xpath expression $original_exp"); }
7001 |  |  |  |  |
7002 |  |  |  |  | # grab a parent
7003 | 24 | 65µs | 33 | 25µs | if( $sub_exp eq '..') # spent 18µs making 9 calls to CORE::subst, avg 2µs/call # spent 7µs making 24 calls to CORE::match, avg 279ns/call
7004 |  |  |  |  | { _croak_and_doublecheck_xpath( $original_exp, "error in xpath expression $original_exp") if( $wildcard);
7005 |  |  |  |  | $sub .= '@results= map { $_->{parent}} @results;';
7006 |  |  |  |  | }
7007 |  |  |  |  | # test the element itself
7008 |  |  |  |  | elsif( $sub_exp=~ m{^\.(.*)$}s)
7009 |  |  |  |  | { $sub .= "\@results= grep { \$_->matches( q{$1}) } \@results;" }
7010 |  |  |  |  | # grab children
7011 |  |  |  |  | else
7012 |  |  |  |  | {
7013 | 24 | 7µs |  |  | if( !$axis)
7014 |  |  |  |  | { $axis= $wildcard ? 'descendant' : 'child'; }
7015 | 24 | 6µs |  |  | if( !$gi or $gi eq '*') { $gi=''; }
7016 | 24 | 2µs |  |  | my $function;
7017 |  |  |  |  |
7018 |  |  |  |  | # "special" predicates, that return just one element
7019 | 24 | 24µs | 10 | 9µs | if( $predicates && ($predicates =~ m{^\s*\[\s*((-\s*)?\d+)\s*\]\s*$})) # spent 9µs making 10 calls to CORE::match, avg 890ns/call
7020 |  |  |  |  | { # [<nb>]
7021 |  |  |  |  | my $offset= $1;
7022 |  |  |  |  | $offset-- if( $offset > 0);
7023 |  |  |  |  | $function= $axis eq 'descendant' ? "next_n_elt( $offset, '$gi')"
7024 |  |  |  |  | : $axis eq 'child' ? "child( $offset, '$gi')"
7025 |  |  |  |  | : _croak_and_doublecheck_xpath( $original_exp, "error [$1] not supported along axis '$axis'")
7026 |  |  |  |  | ;
7027 |  |  |  |  | $sub .= "\@results= grep { \$_ } map { \$_->$function } \@results;"
7028 |  |  |  |  | }
7029 |  |  |  |  | elsif( $predicates && ($predicates =~ m{^\s*\[\s*last\s*\(\s*\)\s*\]\s*$}) )
7030 |  |  |  |  | { # last()
7031 |  |  |  |  | _croak_and_doublecheck_xpath( $original_exp, "error in xpath expression $original_exp, usage of // and last() not supported") if( $wildcard);
7032 |  |  |  |  | $sub .= "\@results= map { \$_->last_child( '$gi') } \@results;";
7033 |  |  |  |  | }
7034 |  |  |  |  | else
7035 |  |  |  |  | { # follow the axis
7036 |  |  |  |  | #warn "axis: '$axis' - method: '$axis2method{$axis}' - gi: '$gi'\n";
7037 |  |  |  |  |
7038 | 24 | 13µs |  |  | my $follow_axis= " \$_->$axis2method{$axis}( '$gi')";
7039 | 24 | 3µs |  |  | my $step= $follow_axis;
7040 |  |  |  |  |
7041 |  |  |  |  | # now filter using the predicate
7042 | 24 | 212µs | 25 | 186µs | while( $predicates=~ s{^\s*($REG_PREDICATE_ALT)\s*}{}o) # spent 165µs making 1 call to CORE::regcomp # spent 21µs making 24 calls to CORE::subst, avg 871ns/call
7043 | 5 | 3µs |  |  | { my $pred= $1;
7044 | 5 | 8µs | 5 | 4µs | $pred=~ s{^\s*\[\s*}{}; # spent 4µs making 5 calls to CORE::subst, avg 840ns/call
7045 | 5 | 15µs | 5 | 11µs | $pred=~ s{\s*\]\s*$}{}; # spent 11µs making 5 calls to CORE::subst, avg 2µs/call
7046 | 5 | 1µs |  |  | my $test="";
7047 | 5 | 500ns |  |  | my $pos;
7048 | 5 | 14µs | 10 | 4µs | if( $pred=~ m{^(-?\s*\d+)$}) # spent 3µs making 5 calls to CORE::match, avg 660ns/call # spent 600ns making 5 calls to CORE::subst, avg 120ns/call
7049 |  |  |  |  | { my $pos= $1;
7050 |  |  |  |  | if( $step=~ m{^\s*grep(.*) (\$_->\w+\(\s*'[^']*'\s*\))})
7051 |  |  |  |  | { $step= "XML::Twig::_first_n $1 $pos, $2"; }
7052 |  |  |  |  | else
7053 |  |  |  |  | { if( $pos > 0) { $pos--; }
7054 |  |  |  |  | $step= "($step)[$pos]";
7055 |  |  |  |  | }
7056 |  |  |  |  | #warn "number predicate '$pos' - generated step '$step'\n";
7057 |  |  |  |  | }
7058 |  |  |  |  | else
7059 | 5 | 1µs |  |  | { my $syntax_error=0;
7060 |  |  |  |  | do
7061 | 10 | 68µs | 12 | 52µs | { if( $pred =~ s{^string\(\s*\)\s*=\s*($REG_STRING)\s*}{}o) # string()="string" pred # spent 50µs making 2 calls to CORE::regcomp, avg 25µs/call # spent 1µs making 10 calls to CORE::subst, avg 140ns/call
7062 |  |  |  |  | { $test .= "\$_->text eq $1"; }
7063 |  |  |  |  | elsif( $pred =~ s{^string\(\s*\)\s*!=\s*($REG_STRING)\s*}{}o) # string()!="string" pred
7064 |  |  |  |  | { $test .= "\$_->text ne $1"; }
7065 | 5 | 288µs | 35 | 261µs | if( $pred =~ s{^string\(\s*\)\s*=\s*($REG_NUMBER)\s*}{}o) # string()=<number> pred # spent 236µs making 5 calls to CORE::regcomp, avg 47µs/call # spent 25µs making 30 calls to CORE::subst, avg 820ns/call
7066 |  |  |  |  | { $test .= "\$_->text eq $1"; }
7067 |  |  |  |  | elsif( $pred =~ s{^string\(\s*\)\s*!=\s*($REG_NUMBER)\s*}{}o) # string()!=<number> pred
7068 |  |  |  |  | { $test .= "\$_->text ne $1"; }
7069 |  |  |  |  | elsif( $pred =~ s{^string\(\s*\)\s*(>|<|>=|<=)\s*($REG_NUMBER)\s*}{}o) # string()!=<number> pred
7070 |  |  |  |  | { $test .= "\$_->text $1 $2"; }
7071 |  |  |  |  |
7072 |  |  |  |  | elsif( $pred =~ s{^string\(\s*\)\s*($REG_MATCH)\s*($REG_REGEXP)\s*}{}o) # string()=~/regex/ pred
7073 |  |  |  |  | { my( $match, $regexp)= ($1, $2);
7074 |  |  |  |  | $test .= "\$_->text $match $regexp";
7075 |  |  |  |  | }
7076 |  |  |  |  | elsif( $pred =~ s{^string\(\s*\)\s*}{}o) # string() pred
7077 |  |  |  |  | { $test .= "\$_->text"; }
7078 |  |  |  |  | elsif( $pred=~ s{^@($REG_TAG_NAME)\s*($REG_OP)\s*($REG_STRING|$REG_NUMBER)}{}o) # @att="val" pred
7079 | 5 | 9µs | 5 | 10µs | { my( $att, $oper, $val)= ($1, _op( $2), $3); # spent 10µs making 5 calls to XML::Twig::Elt::_op, avg 2µs/call
7080 | 5 | 4µs |  |  | $test .= qq{((defined \$_->{'att'}->{"$att"}) && (\$_->{'att'}->{"$att"} $oper $val))};
7081 |  |  |  |  | }
7082 |  |  |  |  | elsif( $pred =~ s{^@($REG_TAG_NAME)\s*($REG_MATCH)\s*($REG_REGEXP)\s*}{}o) # @att=~/regex/ pred XXX
7083 |  |  |  |  | { my( $att, $match, $regexp)= ($1, $2, $3);
7084 |  |  |  |  | $test .= qq{((defined \$_->{'att'}->{"$att"}) && (\$_->{'att'}->{"$att"} $match $regexp))};;
7085 |  |  |  |  | }
7086 |  |  |  |  | elsif( $pred=~ s{^@($REG_TAG_NAME)\s*}{}o) # @att pred
7087 |  |  |  |  | { $test .= qq{(defined \$_->{'att'}->{"$1"})}; }
7088 |  |  |  |  | elsif( $pred=~ s{^\s*(?:not|!)\s*@($REG_TAG_NAME)\s*}{}o) # not @att pred
7089 |  |  |  |  | { $test .= qq{((\$_->is_elt) && (not defined \$_->{'att'}->{"$1"}))}; }
7090 |  |  |  |  | elsif( $pred=~ s{^\s*([()])}{}) # ( or ) (just add to the test)
7091 |  |  |  |  | { $test .= qq{$1}; }
7092 |  |  |  |  | elsif( $pred=~ s{^\s*(and|or)\s*}{})
7093 |  |  |  |  | { $test .= lc " $1 "; }
7094 |  |  |  |  | else
7095 |  |  |  |  | { $syntax_error=1; }
7096 |  |  |  |  |
7097 |  |  |  |  | } while( !$syntax_error && $pred);
7098 | 5 | 600ns |  |  | _croak_and_doublecheck_xpath( $original_exp, "error in xpath expression $original_exp at $pred") if( $pred);
7099 | 5 | 2µs |  |  | $step= " grep { $test } $step ";
7100 |  |  |  |  | }
7101 |  |  |  |  | }
7102 |  |  |  |  | #warn "step: '$step'";
7103 | 24 | 6µs |  |  | $sub .= "\@results= grep defined, map { $step } \@results;";
7104 |  |  |  |  | }
7105 |  |  |  |  | }
7106 |  |  |  |  | }
7107 |  |  |  |  |
7108 | 15 | 2µs |  |  | if( $xpath_exp)
7109 |  |  |  |  | { _croak_and_doublecheck_xpath( $original_exp, "error in xpath expression $original_exp around $xpath_exp"); }
7110 |  |  |  |  |
7111 | 15 | 2µs |  |  | $sub .= q{return XML::Twig::_unique_elts( @results); };
7112 |  |  |  |  | #warn "generated: '$sub'\n";
7113 | 15 | 467µs |  |  | my $s= eval "sub { $NO_WARNINGS; $sub }"; # spent 118µs executing statements in string eval # includes 20µs spent executing 2 calls to 2 subs defined therein. # spent 109µs executing statements in string eval # includes 28µs spent executing 3 calls to 2 subs defined therein. # spent 109µs executing statements in string eval # includes 31µs spent executing 2 calls to 2 subs defined therein. # spent 103µs executing statements in string eval # includes 18µs spent executing 2 calls to 2 subs defined therein. # spent 102µs executing statements in string eval # includes 18µs spent executing 2 calls to 2 subs defined therein. # spent 99µs executing statements in string eval # includes 30µs spent executing 2 calls to 2 subs defined therein. # spent 96µs executing statements in string eval # includes 16µs spent executing 2 calls to 2 subs defined therein. # spent 92µs executing statements in string eval # includes 16µs spent executing 2 calls to 2 subs defined therein. # spent 92µs executing statements in string eval # includes 16µs spent executing 2 calls to 2 subs defined therein. # spent 92µs executing statements in string eval # includes 21µs spent executing 2 calls to 2 subs defined therein. # spent 90µs executing statements in string eval # includes 17µs spent executing 2 calls to 2 subs defined therein. # spent 85µs executing statements in string eval # includes 17µs spent executing 2 calls to 2 subs defined therein. # spent 82µs executing statements in string eval # includes 12µs spent executing 2 calls to 2 subs defined therein. # spent 76µs executing statements in string eval # includes 15µs spent executing 2 calls to 2 subs defined therein. # spent 67µs executing statements in string eval # includes 13µs spent executing 2 calls to 2 subs defined therein.
7114 | 15 | 3µs |  |  | if( $@)
7115 |  |  |  |  | { _croak_and_doublecheck_xpath( $original_exp, "error in xpath expression $original_exp ($@);") }
7116 | 15 | 34µs |  |  | return( $s);
7117 |  |  |  |  | }
7118 |  |  |  |  | }
7119 |  |  |  |  |
7120 |  |  |  |  | sub _croak_and_doublecheck_xpath
7121 | 1 | 0s |  |  | { my $xpath_expression= shift;
7122 |  |  |  |  | my $mess= join( "\n", @_);
7123 |  |  |  |  | if( $XML::Twig::XPath::VERSION || 0)
7124 |  |  |  |  | { my $check_twig= XML::Twig::XPath->new;
7125 |  |  |  |  | if( eval { $check_twig->{twig_xp}->_parse( $xpath_expression) })
7126 |  |  |  |  | { $mess .= "\nthe expression is a valid XPath statement, and you are using XML::Twig::XPath, but"
7127 |  |  |  |  | . "\nyou are using either 'find_nodes' or 'get_xpath' where the method you likely wanted"
7128 |  |  |  |  | . "\nto use is 'findnodes', which is the only one that uses the full XPath engine\n";
7129 |  |  |  |  | }
7130 |  |  |  |  | }
7131 |  |  |  |  | croak $mess;
7132 |  |  |  |  | }
7133 |  |  |  |  |
7134 |  |  |  |  |
7135 |  |  |  |  |
7136 |  |  |  |  | { # extremely elaborate caching mechanism
7137 | 1 | 100ns |  |  | my %xpath; # xpath_expression => subroutine_code;
7138 |  |  |  |  | sub get_xpath
7139 | 16 | 6µs |  |  | # spent 12.3ms (86µs+12.2) within XML::Twig::Elt::get_xpath which was called 16 times, avg 768µs/call: # 16 times (86µs+12.2ms) by XML::Twig::get_xpath at line 3691, avg 768µs/call { my( $elt, $xpath_exp, $offset)= @_;
7140 | 16 | 22µs | 15 | 3.48ms | my $sub= ($xpath{$xpath_exp} ||= _install_xpath( $xpath_exp)); # spent 3.48ms making 15 calls to XML::Twig::Elt::_install_xpath, avg 232µs/call
7141 | 16 | 37µs | 16 | 8.72ms | return $sub->( $elt) unless( defined $offset); # spent 4.55ms making 1 call to XML::Twig::Elt::__ANON__[(eval 70)[XML/Twig.pm:7113]:1] # spent 910µs making 1 call to XML::Twig::Elt::__ANON__[(eval 68)[XML/Twig.pm:7113]:1] # spent 855µs making 1 call to XML::Twig::Elt::__ANON__[(eval 97)[XML/Twig.pm:7113]:1] # spent 499µs making 1 call to XML::Twig::Elt::__ANON__[(eval 58)[XML/Twig.pm:7113]:1] # spent 389µs making 1 call to XML::Twig::Elt::__ANON__[(eval 85)[XML/Twig.pm:7113]:1] # spent 362µs making 1 call to XML::Twig::Elt::__ANON__[(eval 87)[XML/Twig.pm:7113]:1] # spent 295µs making 1 call to XML::Twig::Elt::__ANON__[(eval 76)[XML/Twig.pm:7113]:1] # spent 224µs making 1 call to XML::Twig::Elt::__ANON__[(eval 103)[XML/Twig.pm:7113]:1] # spent 196µs making 1 call to XML::Twig::Elt::__ANON__[(eval 129)[XML/Twig.pm:7113]:1] # spent 145µs making 1 call to XML::Twig::Elt::__ANON__[(eval 64)[XML/Twig.pm:7113]:1] # spent 120µs making 1 call to XML::Twig::Elt::__ANON__[(eval 66)[XML/Twig.pm:7113]:1] # spent 80µs making 2 calls to XML::Twig::Elt::__ANON__[(eval 62)[XML/Twig.pm:7113]:1], avg 40µs/call # spent 37µs making 1 call to XML::Twig::Elt::__ANON__[(eval 60)[XML/Twig.pm:7113]:1] # spent 32µs making 1 call to XML::Twig::Elt::__ANON__[(eval 61)[XML/Twig.pm:7113]:1] # spent 31µs making 1 call to XML::Twig::Elt::__ANON__[(eval 63)[XML/Twig.pm:7113]:1]
7142 |  |  |  |  | my @res= $sub->( $elt);
7143 |  |  |  |  | return $res[$offset];
7144 |  |  |  |  | }
7145 |  |  |  |  | }
7146 |  |  |  |  |
7147 |  |  |  |  |
7148 |  |  |  |  | sub findvalues
7149 | 1 | 0s |  |  | { my $elt= shift;
7150 |  |  |  |  | return map { $_->text } $elt->get_xpath( @_);
7151 |  |  |  |  | }
7152 |  |  |  |  |
7153 |  |  |  |  | sub findvalue
7154 |  |  |  |  | { my $elt= shift;
7155 |  |  |  |  | return join '', map { $_->text } $elt->get_xpath( @_);
7156 |  |  |  |  | }
7157 |  |  |  |  |
7158 |  |  |  |  |
7159 |  |  |  |  | # XML::XPath compatibility
7160 |  |  |  |  | sub getElementById { return $_[0]->twig->elt_id( $_[1]); }
7161 |  |  |  |  | sub getChildNodes { my @children= do { my $elt= $_[0]; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; }; return wantarray ? @children : \@children; }
7162 |  |  |  |  |
7163 |  |  |  |  | sub _flushed { return $_[0]->{flushed}; }
7164 |  |  |  |  | sub _set_flushed { $_[0]->{flushed}=1; }
7165 |  |  |  |  | sub _del_flushed { delete $_[0]->{flushed}; }
7166 |  |  |  |  |
7167 |  |  |  |  | sub cut
7168 | 33813 | 3.92ms |  |  | # spent 579ms (545+33.7) within XML::Twig::Elt::cut which was called 33813 times, avg 17µs/call: # 33813 times (545ms+33.7ms) by XML::Twig::Elt::delete at line 8087, avg 17µs/call { my $elt= shift;
7169 | 33813 | 4.01ms |  |  | my( $parent, $prev_sibling, $next_sibling);
7170 | 33813 | 5.57ms |  |  | $parent= $elt->{parent};
7171 | 33813 | 6.20ms | 6 | 26µs | if( ! $parent && $elt->is_elt) # spent 26µs making 6 calls to XML::Twig::Elt::is_elt, avg 4µs/call
7172 |  |  |  |  | { # are we cutting the root?
7173 | 6 | 2µs |  |  | my $t= $elt->{twig};
7174 | 6 | 4µs |  |  | if( $t && ! $t->{twig_parsing})
7175 | 6 | 2µs |  |  | { delete $t->{twig_root};
7176 | 6 | 2µs |  |  | delete $elt->{twig};
7177 | 6 | 109µs |  |  | return $elt;
7178 |  |  |  |  | } # cutt`ing the root
7179 |  |  |  |  | else
7180 |  |  |  |  | { return; } # cutting an orphan, returning $elt would break backward compatibility
7181 |  |  |  |  | }
7182 |  |  |  |  |
7183 |  |  |  |  | # save the old links, that'll make it easier for some loops
7184 | 33807 | 10.1ms |  |  | foreach my $link ( qw(parent prev_sibling next_sibling) )
7185 | 101421 | 53.5ms |  |  | { $elt->{former}->{$link}= $elt->{$link};
7186 | 101421 | 180ms | 101421 | 23.0ms | if( $XML::Twig::weakrefs) { weaken( $elt->{former}->{$link}); } # spent 23.0ms making 101421 calls to Scalar::Util::weaken, avg 227ns/call
7187 |  |  |  |  | }
7188 |  |  |  |  |
7189 |  |  |  |  | # if we cut the current element then its parent becomes the current elt
7190 | 33807 | 5.38ms |  |  | if( $elt->{twig_current})
7191 |  |  |  |  | { my $twig_current= $elt->{parent};
7192 |  |  |  |  | $elt->twig->{twig_current}= $twig_current;
7193 |  |  |  |  | $twig_current->{'twig_current'}=1;
7194 |  |  |  |  | delete $elt->{'twig_current'};
7195 |  |  |  |  | }
7196 |  |  |  |  |
7197 | 33807 | 14.3ms |  |  | if( $parent->{first_child} && $parent->{first_child} == $elt)
7198 | 33807 | 7.78ms |  |  | { $parent->{first_child}= $elt->{next_sibling};
7199 |  |  |  |  | # cutting can make the parent empty
7200 | 33807 | 11.3ms |  |  | if( ! $parent->{first_child}) { $parent->{empty}= 1; }
7201 |  |  |  |  | }
7202 |  |  |  |  |
7203 | 33807 | 11.5ms |  |  | if( $parent->{last_child} && $parent->{last_child} == $elt)
7204 | 101421 | 89.4ms | 33807 | 3.60ms | { delete $parent->{empty}; $parent->{last_child}=$elt->{prev_sibling}; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; # spent 3.60ms making 33807 calls to Scalar::Util::weaken, avg 106ns/call
7205 |  |  |  |  | }
7206 |  |  |  |  |
7207 | 33807 | 6.42ms |  |  | if( $prev_sibling= $elt->{prev_sibling})
7208 |  |  |  |  | { $prev_sibling->{next_sibling}= $elt->{next_sibling}; }
7209 | 33807 | 4.49ms |  |  | if( $next_sibling= $elt->{next_sibling})
7210 |  |  |  |  | { $next_sibling->{prev_sibling}=$elt->{prev_sibling}; if( $XML::Twig::weakrefs) { weaken( $next_sibling->{prev_sibling});} ; }
7211 |  |  |  |  |
7212 |  |  |  |  |
7213 | 67614 | 69.7ms | 33807 | 3.58ms | $elt->{parent}=undef; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ; # spent 3.58ms making 33807 calls to Scalar::Util::weaken, avg 106ns/call
7214 | 67614 | 69.7ms | 33807 | 3.52ms | $elt->{prev_sibling}=undef; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ; # spent 3.52ms making 33807 calls to Scalar::Util::weaken, avg 104ns/call
7215 | 33807 | 5.88ms |  |  | $elt->{next_sibling}= undef;
7216 |  |  |  |  |
7217 |  |  |  |  | # merge 2 (now) consecutive text nodes if they are of the same type
7218 |  |  |  |  | # (type can be PCDATA or CDATA)
7219 | 33807 | 3.82ms |  |  | if( $prev_sibling && $next_sibling && $prev_sibling->is_text && ( $XML::Twig::index2gi[$prev_sibling->{'gi'}] eq $XML::Twig::index2gi[$next_sibling->{'gi'}]))
7220 |  |  |  |  | { $prev_sibling->merge_text( $next_sibling); }
7221 |  |  |  |  |
7222 | 33807 | 49.1ms |  |  | return $elt;
7223 |  |  |  |  | }
7224 |  |  |  |  |
7225 |  |  |  |  |
7226 |  |  |  |  | sub former_next_sibling { return $_[0]->{former}->{next_sibling}; }
7227 |  |  |  |  | sub former_prev_sibling { return $_[0]->{former}->{prev_sibling}; }
7228 |  |  |  |  | sub former_parent { return $_[0]->{former}->{parent}; }
7229 |  |  |  |  |
7230 |  |  |  |  | sub cut_children
7231 |  |  |  |  | { my( $elt, $exp)= @_;
7232 |  |  |  |  | my @children= $elt->children( $exp);
7233 |  |  |  |  | foreach (@children) { $_->cut; }
7234 |  |  |  |  | if( ! $elt->has_children) { $elt->{empty}= 1; }
7235 |  |  |  |  | return @children;
7236 |  |  |  |  | }
7237 |  |  |  |  |
7238 |  |  |  |  | sub cut_descendants
7239 |  |  |  |  | { my( $elt, $exp)= @_;
7240 |  |  |  |  | my @descendants= $elt->descendants( $exp);
7241 |  |  |  |  | foreach ($elt->descendants( $exp)) { $_->cut; }
7242 |  |  |  |  | if( ! $elt->has_children) { $elt->{empty}= 1; }
7243 |  |  |  |  | return @descendants;
7244 |  |  |  |  | }
7245 |  |  |  |  |
7246 |  |  |  |  |
7247 |  |  |  |  | sub erase
7248 |  |  |  |  | { my $elt= shift;
7249 |  |  |  |  | #you cannot erase the current element
7250 |  |  |  |  | if( $elt->{twig_current})
7251 |  |  |  |  | { croak "trying to erase an element before it has been completely parsed"; }
7252 |  |  |  |  | if( my $parent= $elt->{parent})
7253 |  |  |  |  | { # normal case
7254 |  |  |  |  | $elt->_move_extra_data_after_erase;
7255 |  |  |  |  | my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
7256 |  |  |  |  | if( @children)
7257 |  |  |  |  | {
7258 |  |  |  |  | # elt has children, move them up
7259 |  |  |  |  |
7260 |  |  |  |  | # the first child may need to be merged with a previous text
7261 |  |  |  |  | my $first_child= shift @children;
7262 |  |  |  |  | $first_child->move( before => $elt);
7263 |  |  |  |  | my $prev= $first_child->{prev_sibling};
7264 |  |  |  |  | if( $prev && $prev->is_text && ($XML::Twig::index2gi[$first_child->{'gi'}] eq $XML::Twig::index2gi[$prev->{'gi'}]) )
7265 |  |  |  |  | { $prev->merge_text( $first_child); }
7266 |  |  |  |  |
7267 |  |  |  |  | # move the rest of the children
7268 |  |  |  |  | foreach my $child (@children)
7269 |  |  |  |  | { $child->move( before => $elt); }
7270 |  |  |  |  |
7271 |  |  |  |  | # now the elt had no child, delete it
7272 |  |  |  |  | $elt->delete;
7273 |  |  |  |  |
7274 |  |  |  |  | # now see if we need to merge the last child with the next element
7275 |  |  |  |  | my $last_child= $children[-1] || $first_child; # if no last child, then it's also the first child
7276 |  |  |  |  | my $next= $last_child->{next_sibling};
7277 |  |  |  |  | if( $next && $next->is_text && ($XML::Twig::index2gi[$last_child->{'gi'}] eq $XML::Twig::index2gi[$next->{'gi'}]) )
7278 |  |  |  |  | { $last_child->merge_text( $next); }
7279 |  |  |  |  |
7280 |  |  |  |  | # if parsing and have now a PCDATA text, mark so we can normalize later on if need be
7281 |  |  |  |  | if( $parent->{twig_current} && $last_child->is_text) { $parent->{twig_to_be_normalized}=1; }
7282 |  |  |  |  | }
7283 |  |  |  |  | else
7284 |  |  |  |  | { # no children, just cut the elt
7285 |  |  |  |  | $elt->delete;
7286 |  |  |  |  | }
7287 |  |  |  |  | }
7288 |  |  |  |  | else
7289 |  |  |  |  | { # trying to erase the root (of a twig or of a cut/new element)
7290 |  |  |  |  | my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
7291 |  |  |  |  | unless( @children == 1)
7292 |  |  |  |  | { croak "can only erase an element with no parent if it has a single child"; }
7293 |  |  |  |  | $elt->_move_extra_data_after_erase;
7294 |  |  |  |  | my $child= shift @children;
7295 |  |  |  |  | $child->{parent}=undef; if( $XML::Twig::weakrefs) { weaken( $child->{parent});} ;
7296 |  |  |  |  | my $twig= $elt->twig;
7297 |  |  |  |  | $twig->set_root( $child);
7298 |  |  |  |  | }
7299 |  |  |  |  |
7300 |  |  |  |  | return $elt;
7301 |  |  |  |  |
7302 |  |  |  |  | }
7303 |  |  |  |  |
7304 |  |  |  |  | sub _move_extra_data_after_erase
7305 |  |  |  |  | { my( $elt)= @_;
7306 |  |  |  |  | # extra_data
7307 |  |  |  |  | if( my $extra_data= $elt->{extra_data})
7308 |  |  |  |  | { my $target= $elt->{first_child} || $elt->{next_sibling};
7309 |  |  |  |  | if( $target)
7310 |  |  |  |  | {
7311 |  |  |  |  | if( $target->is( $ELT))
7312 |  |  |  |  | { $target->set_extra_data( $extra_data . ($target->extra_data || '')); }
7313 |  |  |  |  | elsif( $target->is( $TEXT))
7314 |  |  |  |  | { $target->_unshift_extra_data_in_pcdata( $extra_data, 0); } # TO CHECK
7315 |  |  |  |  | }
7316 |  |  |  |  | else
7317 |  |  |  |  | { my $parent= $elt->{parent}; # always exists or the erase cannot be performed
7318 |  |  |  |  | $parent->_prefix_extra_data_before_end_tag( $extra_data);
7319 |  |  |  |  | }
7320 |  |  |  |  | }
7321 |  |  |  |  |
7322 |  |  |  |  | # extra_data_before_end_tag
7323 |  |  |  |  | if( my $extra_data= $elt->{extra_data_before_end_tag})
7324 |  |  |  |  | { if( my $target= $elt->{next_sibling})
7325 |  |  |  |  | { if( $target->is( $ELT))
7326 |  |  |  |  | { $target->set_extra_data( $extra_data . ($target->extra_data || '')); }
7327 |  |  |  |  | elsif( $target->is( $TEXT))
7328 |  |  |  |  | {
7329 |  |  |  |  | $target->_unshift_extra_data_in_pcdata( $extra_data, 0);
7330 |  |  |  |  | }
7331 |  |  |  |  | }
7332 |  |  |  |  | elsif( my $parent= $elt->{parent})
7333 |  |  |  |  | { $parent->_prefix_extra_data_before_end_tag( $extra_data); }
7334 |  |  |  |  | }
7335 |  |  |  |  |
7336 |  |  |  |  | return $elt;
7337 |  |  |  |  |
7338 |  |  |  |  | }
7339 |  |  |  |  | BEGIN
7340 | 1 | 6µs |  |  | # spent 4µs within XML::Twig::Elt::BEGIN@7340 which was called: # once (4µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 7498 { my %method= ( before => \&paste_before,
7341 |  |  |  |  | after => \&paste_after,
7342 |  |  |  |  | first_child => \&paste_first_child,
7343 |  |  |  |  | last_child => \&paste_last_child,
7344 |  |  |  |  | within => \&paste_within,
7345 |  |  |  |  | );
7346 |  |  |  |  |
7347 |  |  |  |  | # paste elt somewhere around ref
7348 |  |  |  |  | # pos can be first_child (default), last_child, before, after or within
7349 |  |  |  |  | sub paste ## no critic (Subroutines::ProhibitNestedSubs);
7350 |  |  |  |  | { my $elt= shift;
7351 |  |  |  |  | if( $elt->{parent})
7352 |  |  |  |  | { croak "cannot paste an element that belongs to a tree"; }
7353 |  |  |  |  | my $pos;
7354 |  |  |  |  | my $ref;
7355 |  |  |  |  | if( ref $_[0])
7356 |  |  |  |  | { $pos= 'first_child';
7357 |  |  |  |  | croak "wrong argument order in paste, should be $_[1] first" if($_[1]);
7358 |  |  |  |  | }
7359 |  |  |  |  | else
7360 |  |  |  |  | { $pos= shift; }
7361 |  |  |  |  |
7362 |  |  |  |  | if( my $method= $method{$pos})
7363 |  |  |  |  | {
7364 |  |  |  |  | unless( ref( $_[0]) && isa( $_[0], 'XML::Twig::Elt'))
7365 |  |  |  |  | { if( ! defined( $_[0]))
7366 |  |  |  |  | { croak "missing target in paste"; }
7367 |  |  |  |  | elsif( ! ref( $_[0]))
7368 |  |  |  |  | { croak "wrong target type in paste (not a reference), should be XML::Twig::Elt or a subclass"; }
7369 |  |  |  |  | else
7370 |  |  |  |  | { my $ref= ref $_[0];
7371 |  |  |  |  | croak "wrong target type in paste: '$ref', should be XML::Twig::Elt or a subclass";
7372 |  |  |  |  | }
7373 |  |  |  |  | }
7374 |  |  |  |  | $ref= $_[0];
7375 |  |  |  |  | # check here so error message lists the caller file/line
7376 |  |  |  |  | if( !$ref->{parent} && ($pos=~ m{^(before|after)$}) && !(exists $elt->{'target'}) && !(exists $elt->{'comment'}))
7377 |  |  |  |  | { croak "cannot paste $1 root"; }
7378 |  |  |  |  | $elt->$method( @_);
7379 |  |  |  |  | }
7380 |  |  |  |  | else
7381 |  |  |  |  | { croak "tried to paste in wrong position '$pos', allowed positions " .
7382 |  |  |  |  | " are 'first_child', 'last_child', 'before', 'after' and " .
7383 |  |  |  |  | "'within'";
7384 |  |  |  |  | }
7385 |  |  |  |  | if( (my $ids= $elt->{twig_id_list}) && (my $t= $ref->twig) )
7386 |  |  |  |  | { $t->{twig_id_list}||={};
7387 |  |  |  |  | foreach my $id (keys %$ids)
7388 |  |  |  |  | { $t->{twig_id_list}->{$id}= $ids->{$id};
7389 |  |  |  |  | if( $XML::Twig::weakrefs) { weaken( $t->{twig_id_list}->{$id}); }
7390 |  |  |  |  | }
7391 |  |  |  |  | }
7392 |  |  |  |  | return $elt;
7393 |  |  |  |  | }
7394 |  |  |  |  |
7395 |  |  |  |  |
7396 |  |  |  |  | sub paste_before
7397 |  |  |  |  | { my( $elt, $ref)= @_;
7398 |  |  |  |  | my( $parent, $prev_sibling, $next_sibling );
7399 |  |  |  |  |
7400 |  |  |  |  | # trying to paste before an orphan (root or detached wlt)
7401 |  |  |  |  | unless( $ref->{parent})
7402 |  |  |  |  | { if( my $t= $ref->twig)
7403 |  |  |  |  | { if( (exists $elt->{'comment'}) || (exists $elt->{'target'})) # we can still do this
7404 |  |  |  |  | { $t->_add_cpi_outside_of_root( leading_cpi => $elt); return; }
7405 |  |  |  |  | else
7406 |  |  |  |  | { croak "cannot paste before root"; }
7407 |  |  |  |  | }
7408 |  |  |  |  | else
7409 |  |  |  |  | { croak "cannot paste before an orphan element"; }
7410 |  |  |  |  | }
7411 |  |  |  |  | $parent= $ref->{parent};
7412 |  |  |  |  | $prev_sibling= $ref->{prev_sibling};
7413 |  |  |  |  | $next_sibling= $ref;
7414 |  |  |  |  |
7415 |  |  |  |  | $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ;
7416 |  |  |  |  | if( $parent->{first_child} == $ref) { $parent->{first_child}= $elt; }
7417 |  |  |  |  |
7418 |  |  |  |  | if( $prev_sibling) { $prev_sibling->{next_sibling}= $elt; }
7419 |  |  |  |  | $elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
7420 |  |  |  |  |
7421 |  |  |  |  | $next_sibling->{prev_sibling}=$elt; if( $XML::Twig::weakrefs) { weaken( $next_sibling->{prev_sibling});} ;
7422 |  |  |  |  | $elt->{next_sibling}= $ref;
7423 |  |  |  |  | return $elt;
7424 |  |  |  |  | }
7425 |  |  |  |  |
7426 |  |  |  |  | sub paste_after
7427 |  |  |  |  | { my( $elt, $ref)= @_;
7428 |  |  |  |  | my( $parent, $prev_sibling, $next_sibling );
7429 |  |  |  |  |
7430 |  |  |  |  | # trying to paste after an orphan (root or detached wlt)
7431 |  |  |  |  | unless( $ref->{parent})
7432 |  |  |  |  | { if( my $t= $ref->twig)
7433 |  |  |  |  | { if( (exists $elt->{'comment'}) || (exists $elt->{'target'})) # we can still do this
7434 |  |  |  |  | { $t->_add_cpi_outside_of_root( trailing_cpi => $elt); return; }
7435 |  |  |  |  | else
7436 |  |  |  |  | { croak "cannot paste after root"; }
7437 |  |  |  |  | }
7438 |  |  |  |  | else
7439 |  |  |  |  | { croak "cannot paste after an orphan element"; }
7440 |  |  |  |  | }
7441 |  |  |  |  | $parent= $ref->{parent};
7442 |  |  |  |  | $prev_sibling= $ref;
7443 |  |  |  |  | $next_sibling= $ref->{next_sibling};
7444 |  |  |  |  |
7445 |  |  |  |  | $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ;
7446 |  |  |  |  | if( $parent->{last_child}== $ref) { delete $parent->{empty}; $parent->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; }
7447 |  |  |  |  |
7448 |  |  |  |  | $prev_sibling->{next_sibling}= $elt;
7449 |  |  |  |  | $elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
7450 |  |  |  |  |
7451 |  |  |  |  | if( $next_sibling) { $next_sibling->{prev_sibling}=$elt; if( $XML::Twig::weakrefs) { weaken( $next_sibling->{prev_sibling});} ; }
7452 |  |  |  |  | $elt->{next_sibling}= $next_sibling;
7453 |  |  |  |  | return $elt;
7454 |  |  |  |  |
7455 |  |  |  |  | }
7456 |  |  |  |  |
7457 |  |  |  |  | sub paste_first_child
7458 |  |  |  |  | { my( $elt, $ref)= @_;
7459 |  |  |  |  | my( $parent, $prev_sibling, $next_sibling );
7460 |  |  |  |  | $parent= $ref;
7461 |  |  |  |  | $next_sibling= $ref->{first_child};
7462 |  |  |  |  |
7463 |  |  |  |  | $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ;
7464 |  |  |  |  | $parent->{first_child}= $elt;
7465 |  |  |  |  | unless( $parent->{last_child}) { delete $parent->{empty}; $parent->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; }
7466 |  |  |  |  |
7467 |  |  |  |  | $elt->{prev_sibling}=undef; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
7468 |  |  |  |  |
7469 |  |  |  |  | if( $next_sibling) { $next_sibling->{prev_sibling}=$elt; if( $XML::Twig::weakrefs) { weaken( $next_sibling->{prev_sibling});} ; }
7470 |  |  |  |  | $elt->{next_sibling}= $next_sibling;
7471 |  |  |  |  | return $elt;
7472 |  |  |  |  | }
7473 |  |  |  |  |
7474 |  |  |  |  | sub paste_last_child
7475 |  |  |  |  | { my( $elt, $ref)= @_;
7476 |  |  |  |  | my( $parent, $prev_sibling, $next_sibling );
7477 |  |  |  |  | $parent= $ref;
7478 |  |  |  |  | $prev_sibling= $ref->{last_child};
7479 |  |  |  |  |
7480 |  |  |  |  | $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ;
7481 |  |  |  |  | delete $parent->{empty}; $parent->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ;
7482 |  |  |  |  | unless( $parent->{first_child}) { $parent->{first_child}= $elt; }
7483 |  |  |  |  |
7484 |  |  |  |  | $elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
7485 |  |  |  |  | if( $prev_sibling) { $prev_sibling->{next_sibling}= $elt; }
7486 |  |  |  |  |
7487 |  |  |  |  | $elt->{next_sibling}= undef;
7488 |  |  |  |  | return $elt;
7489 |  |  |  |  | }
7490 |  |  |  |  |
7491 |  |  |  |  | sub paste_within
7492 |  |  |  |  | { my( $elt, $ref, $offset)= @_;
7493 |  |  |  |  | my $text= $ref->is_text ? $ref : $ref->next_elt( $TEXT, $ref);
7494 |  |  |  |  | my $new= $text->split_at( $offset);
7495 |  |  |  |  | $elt->paste_before( $new);
7496 |  |  |  |  | return $elt;
7497 |  |  |  |  | }
7498 | 1 | 1.74ms | 1 | 4µs | } # spent 4µs making 1 call to XML::Twig::Elt::BEGIN@7340
7499 |  |  |  |  |
7500 |  |  |  |  | # load an element into a structure similar to XML::Simple's
7501 |  |  |  |  | sub simplify
7502 |  |  |  |  | { my $elt= shift;
7503 |  |  |  |  |
7504 |  |  |  |  | # normalize option names
7505 |  |  |  |  | my %options= @_;
7506 |  |  |  |  | %options= map { my ($key, $val)= ($_, $options{$_});
7507 |  |  |  |  | $key=~ s{(\w)([A-Z])}{$1_\L$2}g;
7508 |  |  |  |  | $key => $val
7509 |  |  |  |  | } keys %options;
7510 |  |  |  |  |
7511 |  |  |  |  | # check options
7512 |  |  |  |  | my @allowed_options= qw( keyattr forcearray noattr content_key
7513 |  |  |  |  | var var_regexp variables var_attr
7514 |  |  |  |  | group_tags forcecontent
7515 |  |  |  |  | normalise_space normalize_space
7516 |  |  |  |  | );
7517 |  |  |  |  | my %allowed_options= map { $_ => 1 } @allowed_options;
7518 |  |  |  |  | foreach my $option (keys %options)
7519 |  |  |  |  | { carp "invalid option $option\n" unless( $allowed_options{$option}); }
7520 |  |  |  |  |
7521 |  |  |  |  | $options{normalise_space} ||= $options{normalize_space} || 0;
7522 |  |  |  |  |
7523 |  |  |  |  | $options{content_key} ||= 'content';
7524 |  |  |  |  | if( $options{content_key}=~ m{^-})
7525 |  |  |  |  | { # need to remove the - and to activate extra folding
7526 |  |  |  |  | $options{content_key}=~ s{^-}{};
7527 |  |  |  |  | $options{extra_folding}= 1;
7528 |  |  |  |  | }
7529 |  |  |  |  | else
7530 |  |  |  |  | { $options{extra_folding}= 0; }
7531 |  |  |  |  |
7532 |  |  |  |  | $options{forcearray} ||=0;
7533 |  |  |  |  | if( isa( $options{forcearray}, 'ARRAY'))
7534 |  |  |  |  | { my %forcearray_tags= map { $_ => 1 } @{$options{forcearray}};
7535 |  |  |  |  | $options{forcearray_tags}= \%forcearray_tags;
7536 |  |  |  |  | $options{forcearray}= 0;
7537 |  |  |  |  | }
7538 |  |  |  |  |
7539 |  |  |  |  | $options{keyattr} ||= ['name', 'key', 'id'];
7540 |  |  |  |  | if( ref $options{keyattr} eq 'ARRAY')
7541 |  |  |  |  | { foreach my $keyattr (@{$options{keyattr}})
7542 |  |  |  |  | { my( $prefix, $att)= ($keyattr=~ m{^([+-])?(.*)});
7543 |  |  |  |  | $prefix ||= '';
7544 |  |  |  |  | $options{key_for_all}->{$att}= 1;
7545 |  |  |  |  | $options{remove_key_for_all}->{$att}=1 unless( $prefix eq '+');
7546 |  |  |  |  | $options{prefix_key_for_all}->{$att}=1 if( $prefix eq '-');
7547 |  |  |  |  | }
7548 |  |  |  |  | }
7549 |  |  |  |  | elsif( ref $options{keyattr} eq 'HASH')
7550 |  |  |  |  | { while( my( $elt, $keyattr)= each %{$options{keyattr}})
7551 |  |  |  |  | { my( $prefix, $att)= ($keyattr=~ m{^([+-])?(.*)});
7552 |  |  |  |  | $prefix ||='';
7553 |  |  |  |  | $options{key_for_elt}->{$elt}= $att;
7554 |  |  |  |  | $options{remove_key_for_elt}->{"$elt#$att"}=1 unless( $prefix);
7555 |  |  |  |  | $options{prefix_key_for_elt}->{"$elt#$att"}=1 if( $prefix eq '-');
7556 |  |  |  |  | }
7557 |  |  |  |  | }
7558 |  |  |  |  |
7559 |  |  |  |  |
7560 |  |  |  |  | $options{var}||= $options{var_attr}; # for compat with XML::Simple
7561 |  |  |  |  | if( $options{var}) { $options{var_values}= {}; }
7562 |  |  |  |  | else { $options{var}=''; }
7563 |  |  |  |  |
7564 |  |  |  |  | if( $options{variables})
7565 |  |  |  |  | { $options{var}||= 1;
7566 |  |  |  |  | $options{var_values}= $options{variables};
7567 |  |  |  |  | }
7568 |  |  |  |  |
7569 |  |  |  |  | if( $options{var_regexp} and !$options{var})
7570 |  |  |  |  | { warn "var option not used, var_regexp option ignored\n"; }
7571 |  |  |  |  | $options{var_regexp} ||= '\$\{?(\w+)\}?';
7572 |  |  |  |  |
7573 |  |  |  |  | $elt->_simplify( \%options);
7574 |  |  |  |  |
7575 |  |  |  |  | }
7576 |  |  |  |  |
7577 |  |  |  |  | sub _simplify
7578 |  |  |  |  | { my( $elt, $options)= @_;
7579 |  |  |  |  |
7580 |  |  |  |  | my $data;
7581 |  |  |  |  |
7582 |  |  |  |  | my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
7583 |  |  |  |  | my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
7584 |  |  |  |  | my %atts= $options->{noattr} || !$elt->{att} ? () : %{$elt->{att}};
7585 |  |  |  |  | my $nb_atts= keys %atts;
7586 |  |  |  |  | my $nb_children= $elt->children_count + $nb_atts;
7587 |  |  |  |  |
7588 |  |  |  |  | my %nb_children;
7589 |  |  |  |  | foreach (@children) { $nb_children{$_->tag}++; }
7590 |  |  |  |  | foreach (keys %atts) { $nb_children{$_}++; }
7591 |  |  |  |  |
7592 |  |  |  |  | my $arrays; # tag => array where elements are stored
7593 |  |  |  |  |
7594 |  |  |  |  |
7595 |  |  |  |  | # store children
7596 |  |  |  |  | foreach my $child (@children)
7597 |  |  |  |  | { if( $child->is_text)
7598 |  |  |  |  | { # generate with a content key
7599 |  |  |  |  | my $text= $elt->_text_with_vars( $options);
7600 |  |  |  |  | if( $options->{normalise_space} >= 2) { $text= _normalize_space( $text); }
7601 |  |  |  |  | if( $options->{force_content}
7602 |  |  |  |  | || $nb_atts
7603 |  |  |  |  | || (scalar @children > 1)
7604 |  |  |  |  | )
7605 |  |  |  |  | { $data->{$options->{content_key}}= $text; }
7606 |  |  |  |  | else
7607 |  |  |  |  | { $data= $text; }
7608 |  |  |  |  | }
7609 |  |  |  |  | else
7610 |  |  |  |  | { # element with sub-elements
7611 |  |  |  |  | my $child_gi= $XML::Twig::index2gi[$child->{'gi'}];
7612 |  |  |  |  |
7613 |  |  |  |  | my $child_data= $child->_simplify( $options);
7614 |  |  |  |  |
7615 |  |  |  |  | # first see if we need to simplify further the child data
7616 |  |  |  |  | # simplify because of grouped tags
7617 |  |  |  |  | if( my $grouped_tag= $options->{group_tags}->{$child_gi})
7618 |  |  |  |  | { # check that the child data is a hash with a single field
7619 |  |  |  |  | unless( (ref( $child_data) eq 'HASH')
7620 |  |  |  |  | && (keys %$child_data == 1)
7621 |  |  |  |  | && defined ( my $grouped_child_data= $child_data->{$grouped_tag})
7622 |  |  |  |  | )
7623 |  |  |  |  | { croak "error in grouped tag $child_gi"; }
7624 |  |  |  |  | else
7625 |  |  |  |  | { $child_data= $grouped_child_data; }
7626 |  |  |  |  | }
7627 |  |  |  |  | # simplify because of extra folding
7628 |  |  |  |  | if( $options->{extra_folding})
7629 |  |  |  |  | { if( (ref( $child_data) eq 'HASH')
7630 |  |  |  |  | && (keys %$child_data == 1)
7631 |  |  |  |  | && defined( my $content= $child_data->{$options->{content_key}})
7632 |  |  |  |  | )
7633 |  |  |  |  | { $child_data= $content; }
7634 |  |  |  |  | }
7635 |  |  |  |  |
7636 |  |  |  |  | if( my $keyatt= $child->_key_attr( $options))
7637 |  |  |  |  | { # simplify element with key
7638 |  |  |  |  | my $key= $child->{'att'}->{$keyatt};
7639 |  |  |  |  | if( $options->{normalise_space} >= 1) { $key= _normalize_space( $key); }
7640 |  |  |  |  | $data->{$child_gi}->{$key}= $child_data;
7641 |  |  |  |  | }
7642 |  |  |  |  | elsif( $options->{forcearray}
7643 |  |  |  |  | || $options->{forcearray_tags}->{$child_gi}
7644 |  |  |  |  | || ( $nb_children{$child_gi} > 1)
7645 |  |  |  |  | )
7646 |  |  |  |  | { # simplify element to store in an array
7647 |  |  |  |  | if( defined $child_data && $child_data ne "" )
7648 |  |  |  |  | { $data->{$child_gi} ||= [];
7649 |  |  |  |  | push @{$data->{$child_gi}}, $child_data;
7650 |  |  |  |  | }
7651 |  |  |  |  | else
7652 |  |  |  |  | { $data->{$child_gi}= [{}]; }
7653 |  |  |  |  | }
7654 |  |  |  |  | else
7655 |  |  |  |  | { # simplify element to store as a hash field
7656 |  |  |  |  | $data->{$child_gi}=$child_data;
7657 |  |  |  |  | $data->{$child_gi}= defined $child_data && $child_data ne "" ? $child_data : {};
7658 |  |  |  |  | }
7659 |  |  |  |  | }
7660 |  |  |  |  | }
7661 |  |  |  |  |
7662 |  |  |  |  | # store atts
7663 |  |  |  |  | # TODO: deal with att that already have an element by that name
7664 |  |  |  |  | foreach my $att (keys %atts)
7665 |  |  |  |  | { # do not store if the att is a key that needs to be removed
7666 |  |  |  |  | if( $options->{remove_key_for_all}->{$att}
7667 |  |  |  |  | || $options->{remove_key_for_elt}->{"$gi#$att"}
7668 |  |  |  |  | )
7669 |  |  |  |  | { next; }
7670 |  |  |  |  |
7671 |  |  |  |  | my $att_text= $options->{var} ? _replace_vars_in_text( $atts{$att}, $options) : $atts{$att} ;
7672 |  |  |  |  | if( $options->{normalise_space} >= 2) { $att_text= _normalize_space( $att_text); }
7673 |  |  |  |  |
7674 |  |  |  |  | if( $options->{prefix_key_for_all}->{$att}
7675 |  |  |  |  | || $options->{prefix_key_for_elt}->{"$gi#$att"}
7676 |  |  |  |  | )
7677 |  |  |  |  | { # prefix the att
7678 |  |  |  |  | $data->{"-$att"}= $att_text;
7679 |  |  |  |  | }
7680 |  |  |  |  | else
7681 |  |  |  |  | { # normal case
7682 |  |  |  |  | $data->{$att}= $att_text;
7683 |  |  |  |  | }
7684 |  |  |  |  | }
7685 |  |  |  |  |
7686 |  |  |  |  | return $data;
7687 |  |  |  |  | }
7688 |  |  |  |  |
7689 |  |  |  |  | sub _key_attr
7690 |  |  |  |  | { my( $elt, $options)=@_;
7691 |  |  |  |  | return if( $options->{noattr});
7692 |  |  |  |  | if( $options->{key_for_all})
7693 |  |  |  |  | { foreach my $att ($elt->att_names)
7694 |  |  |  |  | { if( $options->{key_for_all}->{$att})
7695 |  |  |  |  | { return $att; }
7696 |  |  |  |  | }
7697 |  |  |  |  | }
7698 |  |  |  |  | elsif( $options->{key_for_elt})
7699 |  |  |  |  | { if( my $key_for_elt= $options->{key_for_elt}->{$XML::Twig::index2gi[$elt->{'gi'}]} )
7700 |  |  |  |  | { return $key_for_elt if( defined( $elt->{'att'}->{$key_for_elt})); }
7701 |  |  |  |  | }
7702 |  |  |  |  | return;
7703 |  |  |  |  | }
7704 |  |  |  |  |
7705 |  |  |  |  | sub _text_with_vars
7706 |  |  |  |  | { my( $elt, $options)= @_;
7707 |  |  |  |  | my $text;
7708 |  |  |  |  | if( $options->{var})
7709 |  |  |  |  | { $text= _replace_vars_in_text( $elt->text, $options);
7710 |  |  |  |  | $elt->_store_var( $options);
7711 |  |  |  |  | }
7712 |  |  |  |  | else
7713 |  |  |  |  | { $text= $elt->text; }
7714 |  |  |  |  | return $text;
7715 |  |  |  |  | }
7716 |  |  |  |  |
7717 |  |  |  |  |
7718 |  |  |  |  | sub _normalize_space
7719 |  |  |  |  | { my $text= shift;
7720 |  |  |  |  | $text=~ s{\s+}{ }sg;
7721 |  |  |  |  | $text=~ s{^\s}{};
7722 |  |  |  |  | $text=~ s{\s$}{};
7723 |  |  |  |  | return $text;
7724 |  |  |  |  | }
7725 |  |  |  |  |
7726 |  |  |  |  |
7727 |  |  |  |  | sub att_nb
7728 |  |  |  |  | { return 0 unless( my $atts= $_[0]->{att});
7729 |  |  |  |  | return scalar keys %$atts;
7730 |  |  |  |  | }
7731 |  |  |  |  |
7732 |  |  |  |  | sub has_no_atts
7733 |  |  |  |  | { return 1 unless( my $atts= $_[0]->{att});
7734 |  |  |  |  | return scalar keys %$atts ? 0 : 1;
7735 |  |  |  |  | }
7736 |  |  |  |  |
7737 |  |  |  |  | sub _replace_vars_in_text
7738 |  |  |  |  | { my( $text, $options)= @_;
7739 |  |  |  |  |
7740 |  |  |  |  | $text=~ s{($options->{var_regexp})}
7741 |  |  |  |  | { if( defined( my $value= $options->{var_values}->{$2}))
7742 |  |  |  |  | { $value }
7743 |  |  |  |  | else
7744 |  |  |  |  | { warn "unknown variable $2\n";
7745 |  |  |  |  | $1
7746 |  |  |  |  | }
7747 |  |  |  |  | }gex;
7748 |  |  |  |  | return $text;
7749 |  |  |  |  | }
7750 |  |  |  |  |
7751 |  |  |  |  | sub _store_var
7752 |  |  |  |  | { my( $elt, $options)= @_;
7753 |  |  |  |  | if( defined (my $var_name= $elt->{'att'}->{$options->{var}}))
7754 |  |  |  |  | { $options->{var_values}->{$var_name}= $elt->text;
7755 |  |  |  |  | }
7756 |  |  |  |  | }
7757 |  |  |  |  |
7758 |  |  |  |  |
7759 |  |  |  |  | # split a text element at a given offset
7760 |  |  |  |  | sub split_at
7761 |  |  |  |  | { my( $elt, $offset)= @_;
7762 |  |  |  |  | my $text_elt= $elt->is_text ? $elt : $elt->first_child( $TEXT) || return '';
7763 |  |  |  |  | my $string= $text_elt->text;
7764 |  |  |  |  | my $left_string= substr( $string, 0, $offset);
7765 |  |  |  |  | my $right_string= substr( $string, $offset);
7766 |  |  |  |  | $text_elt->{pcdata}= (delete $text_elt->{empty} || 1) && $left_string;
7767 |  |  |  |  | my $new_elt= $elt->new( $XML::Twig::index2gi[$elt->{'gi'}], $right_string);
7768 |  |  |  |  | $new_elt->paste( after => $elt);
7769 |  |  |  |  | return $new_elt;
7770 |  |  |  |  | }
7771 |  |  |  |  |
7772 |  |  |  |  |
7773 |  |  |  |  | # split an element or its text descendants into several, in place
7774 |  |  |  |  | # all elements (new and untouched) are returned
7775 |  |  |  |  | sub split
7776 |  |  |  |  | { my $elt= shift;
7777 |  |  |  |  | my @text_chunks;
7778 |  |  |  |  | my @result;
7779 |  |  |  |  | if( $elt->is_text) { @text_chunks= ($elt); }
7780 |  |  |  |  | else { @text_chunks= $elt->descendants( $TEXT); }
7781 |  |  |  |  | foreach my $text_chunk (@text_chunks)
7782 |  |  |  |  | { push @result, $text_chunk->_split( 1, @_); }
7783 |  |  |  |  | return @result;
7784 |  |  |  |  | }
7785 |  |  |  |  |
7786 |  |  |  |  | # split an element or its text descendants into several, in place
7787 |  |  |  |  | # created elements (those which match the regexp) are returned
7788 |  |  |  |  | sub mark
7789 |  |  |  |  | { my $elt= shift;
7790 |  |  |  |  | my @text_chunks;
7791 |  |  |  |  | my @result;
7792 |  |  |  |  | if( $elt->is_text) { @text_chunks= ($elt); }
7793 |  |  |  |  | else { @text_chunks= $elt->descendants( $TEXT); }
7794 |  |  |  |  | foreach my $text_chunk (@text_chunks)
7795 |  |  |  |  | { push @result, $text_chunk->_split( 0, @_); }
7796 |  |  |  |  | return @result;
7797 |  |  |  |  | }
7798 |  |  |  |  |
7799 |  |  |  |  | # split a single text element
7800 |  |  |  |  | # return_all defines what is returned: if it is true
7801 |  |  |  |  | # only returns the elements created by matches in the split regexp
7802 |  |  |  |  | # otherwise all elements (new and untouched) are returned
7803 |  |  |  |  |
7804 |  |  |  |  |
7805 |  |  |  |  | {
7806 |  |  |  |  |
7807 |  |  |  |  | sub _split
7808 |  |  |  |  | { my $elt= shift;
7809 |  |  |  |  | my $return_all= shift;
7810 |  |  |  |  | my $regexp= shift;
7811 |  |  |  |  | my @tags;
7812 |  |  |  |  |
7813 |  |  |  |  | while( @_)
7814 |  |  |  |  | { my $tag= shift();
7815 |  |  |  |  | if( ref $_[0])
7816 |  |  |  |  | { push @tags, { tag => $tag, atts => shift }; }
7817 |  |  |  |  | else
7818 |  |  |  |  | { push @tags, { tag => $tag }; }
7819 |  |  |  |  | }
7820 |  |  |  |  |
7821 |  |  |  |  | unless( @tags) { @tags= { tag => $elt->{parent}->gi }; }
7822 |  |  |  |  |
7823 |  |  |  |  | my @result; # the returned list of elements
7824 |  |  |  |  | my $text= $elt->text;
7825 |  |  |  |  | my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
7826 |  |  |  |  |
7827 |  |  |  |  | # 2 uses: if split matches then the first substring reuses $elt
7828 |  |  |  |  | # once a split has occurred then the last match needs to be put in
7829 |  |  |  |  | # a new element
7830 |  |  |  |  | my $previous_match= 0;
7831 |  |  |  |  |
7832 |  |  |  |  | while( my( $pre_match, @matches)= $text=~ /^(.*?)$regexp(.*)$/gcs)
7833 |  |  |  |  | { $text= pop @matches;
7834 |  |  |  |  | if( $previous_match)
7835 |  |  |  |  | { # match, not the first one, create a new text ($gi) element
7836 |  |  |  |  | _utf8_ify( $pre_match) if( $] < 5.010);
7837 |  |  |  |  | $elt= $elt->insert_new_elt( after => $gi, $pre_match);
7838 |  |  |  |  | push @result, $elt if( $return_all);
7839 |  |  |  |  | }
7840 |  |  |  |  | else
7841 |  |  |  |  | { # first match in $elt, re-use $elt for the first sub-string
7842 |  |  |  |  | _utf8_ify( $pre_match) if( $] < 5.010);
7843 |  |  |  |  | $elt->set_text( $pre_match);
7844 |  |  |  |  | $previous_match++; # store the fact that there was a match
7845 |  |  |  |  | push @result, $elt if( $return_all);
7846 |  |  |  |  | }
7847 |  |  |  |  |
7848 |  |  |  |  | # now deal with matches captured in the regexp
7849 |  |  |  |  | if( @matches)
7850 |  |  |  |  | { # match, with capture
7851 |  |  |  |  | my $i=0;
7852 |  |  |  |  | foreach my $match (@matches)
7853 |  |  |  |  | { # create new element, text is the match
7854 |  |  |  |  | _utf8_ify( $match) if( $] < 5.010);
7855 |  |  |  |  | my $tag = _repl_match( $tags[$i]->{tag}, @matches) || '#PCDATA';
7856 |  |  |  |  | my $atts = \%{$tags[$i]->{atts}} || {};
7857 |  |  |  |  | my %atts= map { _repl_match( $_, @matches) => _repl_match( $atts->{$_}, @matches) } keys %$atts;
7858 |  |  |  |  | $elt= $elt->insert_new_elt( after => $tag, \%atts, $match);
7859 |  |  |  |  | push @result, $elt;
7860 |  |  |  |  | $i= ($i + 1) % @tags;
7861 |  |  |  |  | }
7862 |  |  |  |  | }
7863 |  |  |  |  | else
7864 |  |  |  |  | { # match, no captures
7865 |  |  |  |  | my $tag = $tags[0]->{tag};
7866 |  |  |  |  | my $atts = \%{$tags[0]->{atts}} || {};
7867 |  |  |  |  | $elt= $elt->insert_new_elt( after => $tag, $atts);
7868 |  |  |  |  | push @result, $elt;
7869 |  |  |  |  | }
7870 |  |  |  |  | }
7871 |  |  |  |  | if( $previous_match && $text)
7872 |  |  |  |  | { # there was at least 1 match, and there is text left after the match
7873 |  |  |  |  | $elt= $elt->insert_new_elt( after => $gi, $text);
7874 |  |  |  |  | }
7875 |  |  |  |  |
7876 |  |  |  |  | push @result, $elt if( $return_all);
7877 |  |  |  |  |
7878 |  |  |  |  | return @result; # return all elements
7879 |  |  |  |  | }
7880 |  |  |  |  |
7881 |  |  |  |  | sub _repl_match
7882 |  |  |  |  | { my( $val, @matches)= @_;
7883 |  |  |  |  | $val=~ s{\$(\d+)}{$matches[$1-1]}g;
7884 |  |  |  |  | return $val;
7885 |  |  |  |  | }
7886 |  |  |  |  |
7887 |  |  |  |  | # evil hack needed as sometimes
7888 | 1 | 200ns |  |  | my $encode_is_loaded=0; # so we only load Encode once
7889 |  |  |  |  | sub _utf8_ify
7890 |  |  |  |  | {
7891 |  |  |  |  | if( $perl_version >= 5.008 and $perl_version < 5.010 and !_keep_encoding())
7892 |  |  |  |  | { unless( $encode_is_loaded) { require Encode; import Encode; $encode_is_loaded++; }
7893 |  |  |  |  | Encode::_utf8_on( $_[0]); # the flag should be set but is not
7894 |  |  |  |  | }
7895 |  |  |  |  | }
7896 |  |  |  |  |
7897 |  |  |  |  |
7898 |  |  |  |  | }
7899 |  |  |  |  |
7900 | 2 | 200ns |  |  | { my %replace_sub; # cache for complex expressions (expression => sub)
7901 |  |  |  |  |
7902 |  |  |  |  | sub subs_text
7903 |  |  |  |  | { my( $elt, $regexp, $replace)= @_;
7904 |  |  |  |  |
7905 |  |  |  |  | my $replacement_string;
7906 |  |  |  |  | my $is_string= _is_string( $replace);
7907 |  |  |  |  |
7908 |  |  |  |  | my @parents;
7909 |  |  |  |  |
7910 |  |  |  |  | foreach my $text_elt ($elt->descendants_or_self( $TEXT))
7911 |  |  |  |  | {
7912 |  |  |  |  | if( $is_string)
7913 |  |  |  |  | { my $text= $text_elt->text;
7914 |  |  |  |  | $text=~ s{$regexp}{ _replace_var( $replace, $1, $2, $3, $4, $5, $6, $7, $8, $9)}egx;
7915 |  |  |  |  | $text_elt->set_text( $text);
7916 |  |  |  |  | }
7917 |  |  |  |  | else
7918 |  |  |  |  | {
7919 | 2 | 995µs | 2 | 10µs | # spent 9µs (7+2) within XML::Twig::Elt::BEGIN@7919 which was called: # once (7µs+2µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 7919 no utf8; # = perl 5.6 # spent 9µs making 1 call to XML::Twig::Elt::BEGIN@7919 # spent 2µs making 1 call to utf8::unimport
7920 |  |  |  |  | my $replace_sub= ( $replace_sub{$replace} ||= _install_replace_sub( $replace));
7921 |  |  |  |  | my $text= $text_elt->text;
7922 |  |  |  |  | my $pos=0; # used to skip text that was previously matched
7923 |  |  |  |  | my $found_hit;
7924 |  |  |  |  | while( my( $pre_match_string, $match_string, @var)= ($text=~ m{(.*?)($regexp)}sg))
7925 |  |  |  |  | { $found_hit=1;
7926 |  |  |  |  | my $match_start = length( $pre_match_string);
7927 |  |  |  |  | my $match = $match_start ? $text_elt->split_at( $match_start + $pos) : $text_elt;
7928 |  |  |  |  | my $match_length = length( $match_string);
7929 |  |  |  |  | my $post_match = $match->split_at( $match_length);
7930 |  |  |  |  | $replace_sub->( $match, @var);
7931 |  |  |  |  |
7932 |  |  |  |  | # go to next
7933 |  |  |  |  | $text_elt= $post_match;
7934 |  |  |  |  | $text= $post_match->text;
7935 |  |  |  |  |
7936 |  |  |  |  | if( $found_hit) { push @parents, $text_elt->{parent} unless $parents[-1] && $parents[-1]== $text_elt->{parent}; }
7937 |  |  |  |  |
7938 |  |  |  |  | }
7939 |  |  |  |  | }
7940 |  |  |  |  | }
7941 |  |  |  |  |
7942 |  |  |  |  | foreach my $parent (@parents) { $parent->normalize; }
7943 |  |  |  |  |
7944 |  |  |  |  | return $elt;
7945 |  |  |  |  | }
7946 |  |  |  |  |
7947 |  |  |  |  |
7948 |  |  |  |  | sub _is_string
7949 |  |  |  |  | { return ($_[0]=~ m{&e[ln]t}) ? 0: 1 }
7950 |  |  |  |  |
7951 |  |  |  |  | sub _replace_var
7952 |  |  |  |  | { my( $string, @var)= @_;
7953 |  |  |  |  | unshift @var, undef;
7954 |  |  |  |  | $string=~ s{\$(\d)}{$var[$1]}g;
7955 |  |  |  |  | return $string;
7956 |  |  |  |  | }
7957 |  |  |  |  |
7958 |  |  |  |  | sub _install_replace_sub
7959 |  |  |  |  | { my $replace_exp= shift;
7960 |  |  |  |  | my @item= split m{(&e[ln]t\s*\([^)]*\))}, $replace_exp;
7961 |  |  |  |  | my $sub= q{ my( $match, @var)= @_; my $new; my $last_inserted=$match;};
7962 |  |  |  |  | my( $gi, $exp);
7963 |  |  |  |  | foreach my $item (@item)
7964 |  |  |  |  | { next if ! length $item;
7965 |  |  |  |  | if( $item=~ m{^&elt\s*\(([^)]*)\)})
7966 |  |  |  |  | { $exp= $1; }
7967 |  |  |  |  | elsif( $item=~ m{^&ent\s*\(\s*([^\s)]*)\s*\)})
7968 |  |  |  |  | { $exp= " '#ENT' => $1"; }
7969 |  |  |  |  | else
7970 |  |  |  |  | { $exp= qq{ '#PCDATA' => "$item"}; }
7971 |  |  |  |  | $exp=~ s{\$(\d)}{my $i= $1-1; "\$var[$i]"}eg; # replace references to matches
7972 |  |  |  |  | $sub.= qq{ \$new= \$match->new( $exp); };
7973 |  |  |  |  | $sub .= q{ $new->paste( after => $last_inserted); $last_inserted=$new;};
7974 |  |  |  |  | }
7975 |  |  |  |  | $sub .= q{ $match->delete; };
7976 |  |  |  |  | #$sub=~ s/;/;\n/g; warn "subs: $sub";
7977 |  |  |  |  | my $coderef= eval "sub { $NO_WARNINGS; $sub }";
7978 |  |  |  |  | if( $@) { croak( "invalid replacement expression $replace_exp: ",$@); }
7979 |  |  |  |  | return $coderef;
7980 |  |  |  |  | }
7981 |  |  |  |  |
7982 |  |  |  |  | }
7983 |  |  |  |  |
7984 |  |  |  |  |
7985 |  |  |  |  | sub merge_text
7986 | 1 | 100ns |  |  | { my( $e1, $e2)= @_;
7987 |  |  |  |  | croak "invalid merge: can only merge 2 elements"
7988 |  |  |  |  | unless( isa( $e2, 'XML::Twig::Elt'));
7989 |  |  |  |  | croak "invalid merge: can only merge 2 text elements"
7990 |  |  |  |  | unless( $e1->is_text && $e2->is_text && ($e1->gi eq $e2->gi));
7991 |  |  |  |  |
7992 |  |  |  |  | my $t1_length= length( $e1->text);
7993 |  |  |  |  |
7994 |  |  |  |  | $e1->set_text( $e1->text . $e2->text);
7995 |  |  |  |  |
7996 |  |  |  |  | if( my $extra_data_in_pcdata= $e2->_extra_data_in_pcdata)
7997 |  |  |  |  | { foreach my $data (@$extra_data_in_pcdata) { $e1->_push_extra_data_in_pcdata( $data->{text}, $data->{offset} + $t1_length); } }
7998 |  |  |  |  |
7999 |  |  |  |  | $e2->delete;
8000 |  |  |  |  |
8001 |  |  |  |  | return $e1;
8002 |  |  |  |  | }
8003 |  |  |  |  |
8004 |  |  |  |  | sub merge
8005 |  |  |  |  | { my( $e1, $e2)= @_;
8006 |  |  |  |  | my @e2_children= $e2->_children;
8007 |  |  |  |  | if( $e1->_last_child && $e1->_last_child->is_pcdata
8008 |  |  |  |  | && @e2_children && $e2_children[0]->is_pcdata
8009 |  |  |  |  | )
8010 |  |  |  |  | { my $t1_length= length( $e1->_last_child->{pcdata});
8011 |  |  |  |  | my $child1= $e1->_last_child;
8012 |  |  |  |  | my $child2= shift @e2_children;
8013 |  |  |  |  | $child1->{pcdata} .= $child2->{pcdata};
8014 |  |  |  |  |
8015 |  |  |  |  | my $extra_data= $e1->_extra_data_before_end_tag . $e2->extra_data;
8016 |  |  |  |  |
8017 |  |  |  |  | if( $extra_data)
8018 |  |  |  |  | { $e1->_del_extra_data_before_end_tag;
8019 |  |  |  |  | $child1->_push_extra_data_in_pcdata( $extra_data, $t1_length);
8020 |  |  |  |  | }
8021 |  |  |  |  |
8022 |  |  |  |  | if( my $extra_data_in_pcdata= $child2->_extra_data_in_pcdata)
8023 |  |  |  |  | { foreach my $data (@$extra_data_in_pcdata) { $child1->_push_extra_data_in_pcdata( $data->{text}, $data->{offset} + $t1_length); } }
8024 |  |  |  |  |
8025 |  |  |  |  | if( my $extra_data_before_end_tag= $e2->_extra_data_before_end_tag)
8026 |  |  |  |  | { $e1->_set_extra_data_before_end_tag( $extra_data_before_end_tag); }
8027 |  |  |  |  | }
8028 |  |  |  |  |
8029 |  |  |  |  | foreach my $e (@e2_children) { $e->move( last_child => $e1); }
8030 |  |  |  |  |
8031 |  |  |  |  | $e2->delete;
8032 |  |  |  |  | return $e1;
8033 |  |  |  |  | }
8034 |  |  |  |  |
8035 |  |  |  |  |
8036 |  |  |  |  | # recursively copy an element and returns the copy (can be huge and long)
8037 |  |  |  |  | sub copy
8038 |  |  |  |  | { my $elt= shift;
8039 |  |  |  |  | my $copy= $elt->new( $XML::Twig::index2gi[$elt->{'gi'}]);
8040 |  |  |  |  |
8041 |  |  |  |  | if( $elt->extra_data) { $copy->set_extra_data( $elt->extra_data); }
8042 |  |  |  |  | if( $elt->{extra_data_before_end_tag}) { $copy->_set_extra_data_before_end_tag( $elt->{extra_data_before_end_tag}); }
8043 |  |  |  |  |
8044 |  |  |  |  | if( $elt->is_asis) { $copy->set_asis; }
8045 |  |  |  |  |
8046 |  |  |  |  | if( (exists $elt->{'pcdata'}))
8047 |  |  |  |  | { $copy->{pcdata}= (delete $copy->{empty} || 1) && $elt->{pcdata};
8048 |  |  |  |  | if( $elt->{extra_data_in_pcdata}) { $copy->_set_extra_data_in_pcdata( $elt->{extra_data_in_pcdata}); }
8049 |  |  |  |  | }
8050 |  |  |  |  | elsif( (exists $elt->{'cdata'}))
8051 |  |  |  |  | { $copy->{cdata}= $elt->{cdata};
8052 |  |  |  |  | if( $elt->{extra_data_in_pcdata}) { $copy->_set_extra_data_in_pcdata( $elt->{extra_data_in_pcdata}); }
8053 |  |  |  |  | }
8054 |  |  |  |  | elsif( (exists $elt->{'target'}))
8055 |  |  |  |  | { $copy->_set_pi( $elt->{target}, $elt->{data}); }
8056 |  |  |  |  | elsif( (exists $elt->{'comment'}))
8057 |  |  |  |  | { $copy->{comment}= $elt->{comment}; }
8058 |  |  |  |  | elsif( (exists $elt->{'ent'}))
8059 |  |  |  |  | { $copy->{ent}= $elt->{ent}; }
8060 |  |  |  |  | else
8061 |  |  |  |  | { my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
8062 |  |  |  |  | if( my $atts= $elt->{att})
8063 |  |  |  |  | { my %atts;
8064 |  |  |  |  | tie %atts, 'Tie::IxHash' if (keep_atts_order());
8065 |  |  |  |  | %atts= %{$atts}; # we want to do a real copy of the attributes
8066 |  |  |  |  | $copy->set_atts( \%atts);
8067 |  |  |  |  | }
8068 |  |  |  |  | foreach my $child (@children)
8069 |  |  |  |  | { my $child_copy= $child->copy;
8070 |  |  |  |  | $child_copy->paste( 'last_child', $copy);
8071 |  |  |  |  | }
8072 |  |  |  |  | }
8073 |  |  |  |  | # save links to the original location, which can be convenient and is used for namespace resolution
8074 |  |  |  |  | foreach my $link ( qw(parent prev_sibling next_sibling) )
8075 |  |  |  |  | { $copy->{former}->{$link}= $elt->{$link};
8076 |  |  |  |  | if( $XML::Twig::weakrefs) { weaken( $copy->{former}->{$link}); }
8077 |  |  |  |  | }
8078 |  |  |  |  |
8079 |  |  |  |  | $copy->{empty}= $elt->{'empty'};
8080 |  |  |  |  |
8081 |  |  |  |  | return $copy;
8082 |  |  |  |  | }
8083 |  |  |  |  |
8084 |  |  |  |  |
8085 |  |  |  |  | sub delete
8086 | 33813 | 4.26ms |  |  | # spent 653ms (74.1+579) within XML::Twig::Elt::delete which was called 33813 times, avg 19µs/call: # 33807 times (73.7ms+579ms) by XML::Twig::purge at line 3553, avg 19µs/call # 6 times (401µs+55µs) by XML::Twig::DESTROY at line 3963, avg 76µs/call { my $elt= shift;
8087 | 33813 | 18.7ms | 33813 | 579ms | $elt->cut; # spent 579ms making 33813 calls to XML::Twig::Elt::cut, avg 17µs/call
8088 | 33813 | 4.01ms |  |  | $elt->DESTROY unless $XML::Twig::weakrefs;
8089 | 33813 | 62.4ms |  |  | return undef;
8090 |  |  |  |  | }
8091 |  |  |  |  |
8092 |  |  |  |  | sub __destroy
8093 |  |  |  |  | { my $elt= shift;
8094 |  |  |  |  | return if( $XML::Twig::weakrefs);
8095 |  |  |  |  | my $t= shift || $elt->twig; # optional argument, passed in recursive calls
8096 |  |  |  |  |
8097 |  |  |  |  | foreach( @{[$elt->_children]}) { $_->DESTROY( $t); }
8098 |  |  |  |  |
8099 |  |  |  |  | # the id reference needs to be destroyed
8100 |  |  |  |  | # lots of tests to avoid warnings during the cleanup phase
8101 |  |  |  |  | $elt->del_id( $t) if( $ID && $t && defined( $elt->{att}) && exists( $elt->{att}->{$ID}));
8102 |  |  |  |  | if( $elt->{former}) { foreach (keys %{$elt->{former}}) { delete $elt->{former}->{$_}; } delete $elt->{former}; }
8103 |  |  |  |  | foreach (qw( keys %$elt)) { delete $elt->{$_}; }
8104 |  |  |  |  | undef $elt;
8105 |  |  |  |  | }
8106 |  |  |  |  |
8107 |  |  |  |  | BEGIN
8108 | 1 | 7µs |  |  | # spent 10µs (9+1) within XML::Twig::Elt::BEGIN@8108 which was called: # once (9µs+1µs) by Spreadsheet::ParseXLSX::BEGIN@15 at line 8110 # spent 1µs within XML::Twig::Elt::set_destroy which was called: # once (1µs+0s) by XML::Twig::Elt::BEGIN@8108 at line 8109 { sub set_destroy { if( $XML::Twig::weakrefs) { undef *DESTROY } else { *DESTROY= *__destroy; } }
8109 | 1 | 2µs | 1 | 1µs | set_destroy(); # spent 1µs making 1 call to XML::Twig::Elt::set_destroy
8110 | 1 | 1.15ms | 1 | 10µs | } # spent 10µs making 1 call to XML::Twig::Elt::BEGIN@8108
8111 |  |  |  |  |
8112 |  |  |  |  | # ignores the element
8113 |  |  |  |  | sub ignore
8114 |  |  |  |  | { my $elt= shift;
8115 |  |  |  |  | my $t= $elt->twig;
8116 |  |  |  |  | $t->ignore( $elt, @_);
8117 |  |  |  |  | }
8118 |  |  |  |  |
8119 |  |  |  |  | # spent 16µs within XML::Twig::Elt::BEGIN@8119 which was called: # once (16µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 9065 BEGIN {
8120 | 1 | 200ns |  |  | my $pretty = 0;
8121 | 1 | 200ns |  |  | my $quote = '"';
8122 | 1 | 100ns |  |  | my $INDENT = ' ';
8123 | 1 | 100ns |  |  | my $empty_tag_style = 0;
8124 | 1 | 0s |  |  | my $remove_cdata = 0;
8125 | 1 | 0s |  |  | my $keep_encoding = 0;
8126 | 1 | 0s |  |  | my $expand_external_entities = 0;
8127 | 1 | 0s |  |  | my $keep_atts_order = 0;
8128 | 1 | 0s |  |  | my $do_not_escape_amp_in_atts = 0;
8129 | 1 | 100ns |  |  | my $WRAP = '80';
8130 | 1 | 100ns |  |  | my $REPLACED_ENTS = qq{&<};
8131 |  |  |  |  |
8132 | 1 | 800ns |  |  | my ($NSGMLS, $NICE, $INDENTED, $INDENTEDCT, $INDENTEDC, $WRAPPED, $RECORD1, $RECORD2, $INDENTEDA)= (1..9);
8133 | 1 | 3µs |  |  | my %KEEP_TEXT_TAG_ON_ONE_LINE= map { $_ => 1 } ( $INDENTED, $INDENTEDCT, $INDENTEDC, $INDENTEDA, $WRAPPED);
8134 | 1 | 1µs |  |  | my %WRAPPED = map { $_ => 1 } ( $WRAPPED, $INDENTEDA, $INDENTEDC);
8135 |  |  |  |  |
8136 | 1 | 4µs |  |  | my %pretty_print_style=
8137 |  |  |  |  | ( none => 0, # no added \n
8138 |  |  |  |  | nsgmls => $NSGMLS, # nsgmls-style, \n in tags
8139 |  |  |  |  | # below this line styles are UNSAFE (the generated XML can be well-formed but invalid)
8140 |  |  |  |  | nice => $NICE, # \n after open/close tags except when the
8141 |  |  |  |  | # element starts with text
8142 |  |  |  |  | indented => $INDENTED, # nice plus idented
8143 |  |  |  |  | indented_close_tag => $INDENTEDCT, # nice plus idented
8144 |  |  |  |  | indented_c => $INDENTEDC, # slightly more compact than indented (closing
8145 |  |  |  |  | # tags are on the same line)
8146 |  |  |  |  | wrapped => $WRAPPED, # text is wrapped at column
8147 |  |  |  |  | record_c => $RECORD1, # for record-like data (compact)
8148 |  |  |  |  | record => $RECORD2, # for record-like data (not so compact)
8149 |  |  |  |  | indented_a => $INDENTEDA, # nice, indented, and with attributes on separate
8150 |  |  |  |  | # lines as the nsgmls style, as well as wrapped
8151 |  |  |  |  | # lines - to make the xml friendly to line-oriented tools
8152 |  |  |  |  | cvs => $INDENTEDA, # alias for indented_a
8153 |  |  |  |  | );
8154 |  |  |  |  |
8155 | 1 | 300ns |  |  | my ($HTML, $EXPAND)= (1..2);
8156 | 1 | 800ns |  |  | my %empty_tag_style=
8157 |  |  |  |  | ( normal => 0, # <tag/>
8158 |  |  |  |  | html => $HTML, # <tag />
8159 |  |  |  |  | xhtml => $HTML, # <tag />
8160 |  |  |  |  | expand => $EXPAND, # <tag></tag>
8161 |  |  |  |  | );
8162 |  |  |  |  |
8163 | 1 | 600ns |  |  | my %quote_style=
8164 |  |  |  |  | ( double => '"',
8165 |  |  |  |  | single => "'",
8166 |  |  |  |  | # smart => "smart",
8167 |  |  |  |  | );
8168 |  |  |  |  |
8169 | 1 | 100ns |  |  | my $xml_space_preserve; # set when an element includes xml:space="preserve"
8170 |  |  |  |  |
8171 |  |  |  |  | my $output_filter; # filters the entire output (including < and >)
8172 |  |  |  |  | my $output_text_filter; # filters only the text part (tag names, attributes, pcdata)
8173 |  |  |  |  |
8174 | 1 | 100ns |  |  | my $replaced_ents= $REPLACED_ENTS;
8175 |  |  |  |  |
8176 |  |  |  |  |
8177 |  |  |  |  | # returns those pesky "global" variables so you can switch between twigs
8178 |  |  |  |  | sub global_state ## no critic (Subroutines::ProhibitNestedSubs);
8179 |  |  |  |  | { return
8180 |  |  |  |  | { pretty => $pretty,
8181 |  |  |  |  | quote => $quote,
8182 |  |  |  |  | indent => $INDENT,
8183 |  |  |  |  | empty_tag_style => $empty_tag_style,
8184 |  |  |  |  | remove_cdata => $remove_cdata,
8185 |  |  |  |  | keep_encoding => $keep_encoding,
8186 |  |  |  |  | expand_external_entities => $expand_external_entities,
8187 |  |  |  |  | output_filter => $output_filter,
8188 |  |  |  |  | output_text_filter => $output_text_filter,
8189 |  |  |  |  | keep_atts_order => $keep_atts_order,
8190 |  |  |  |  | do_not_escape_amp_in_atts => $do_not_escape_amp_in_atts,
8191 |  |  |  |  | wrap => $WRAP,
8192 |  |  |  |  | replaced_ents => $replaced_ents,
8193 |  |  |  |  | };
8194 |  |  |  |  | }
8195 |  |  |  |  |
8196 |  |  |  |  | # restores the global variables
8197 |  |  |  |  | sub set_global_state
8198 |  |  |  |  | { my $state= shift;
8199 |  |  |  |  | $pretty = $state->{pretty};
8200 |  |  |  |  | $quote = $state->{quote};
8201 |  |  |  |  | $INDENT = $state->{indent};
8202 |  |  |  |  | $empty_tag_style = $state->{empty_tag_style};
8203 |  |  |  |  | $remove_cdata = $state->{remove_cdata};
8204 |  |  |  |  | $keep_encoding = $state->{keep_encoding};
8205 |  |  |  |  | $expand_external_entities = $state->{expand_external_entities};
8206 |  |  |  |  | $output_filter = $state->{output_filter};
8207 |  |  |  |  | $output_text_filter = $state->{output_text_filter};
8208 |  |  |  |  | $keep_atts_order = $state->{keep_atts_order};
8209 |  |  |  |  | $do_not_escape_amp_in_atts = $state->{do_not_escape_amp_in_atts};
8210 |  |  |  |  | $WRAP = $state->{wrap};
8211 |  |  |  |  | $replaced_ents = $state->{replaced_ents},
8212 |  |  |  |  | }
8213 |  |  |  |  |
8214 |  |  |  |  | # sets global state to defaults
8215 |  |  |  |  | sub init_global_state
8216 |  |  |  |  | { set_global_state(
8217 |  |  |  |  | { pretty => 0,
8218 |  |  |  |  | quote => '"',
8219 |  |  |  |  | indent => $INDENT,
8220 |  |  |  |  | empty_tag_style => 0,
8221 |  |  |  |  | remove_cdata => 0,
8222 |  |  |  |  | keep_encoding => 0,
8223 |  |  |  |  | expand_external_entities => 0,
8224 |  |  |  |  | output_filter => undef,
8225 |  |  |  |  | output_text_filter => undef,
8226 |  |  |  |  | keep_atts_order => undef,
8227 |  |  |  |  | do_not_escape_amp_in_atts => 0,
8228 |  |  |  |  | wrap => $WRAP,
8229 |  |  |  |  | replaced_ents => $REPLACED_ENTS,
8230 |  |  |  |  | });
8231 |  |  |  |  | }
8232 |  |  |  |  |
8233 |  |  |  |  |
8234 |  |  |  |  | # set the pretty_print style (in $pretty) and returns the old one
8235 |  |  |  |  | # can be called from outside the package with 2 arguments (elt, style)
8236 |  |  |  |  | # or from inside with only one argument (style)
8237 |  |  |  |  | # the style can be either a string (one of the keys of %pretty_print_style
8238 |  |  |  |  | # or a number (presumably an old value saved)
8239 |  |  |  |  | sub set_pretty_print
8240 |  |  |  |  | { my $style= lc( defined $_[1] ? $_[1] : $_[0]); # so we cover both cases
8241 |  |  |  |  | my $old_pretty= $pretty;
8242 |  |  |  |  | if( $style=~ /^\d+$/)
8243 |  |  |  |  | { croak "invalid pretty print style $style" unless( $style < keys %pretty_print_style);
8244 |  |  |  |  | $pretty= $style;
8245 |  |  |  |  | }
8246 |  |  |  |  | else
8247 |  |  |  |  | { croak "invalid pretty print style '$style'" unless( exists $pretty_print_style{$style});
8248 |  |  |  |  | $pretty= $pretty_print_style{$style};
8249 |  |  |  |  | }
8250 |  |  |  |  | if( $WRAPPED{$pretty} )
8251 |  |  |  |  | { XML::Twig::_use( 'Text::Wrap') or croak( "Text::Wrap not available, cannot use style $style"); }
8252 |  |  |  |  | return $old_pretty;
8253 |  |  |  |  | }
8254 |  |  |  |  |
8255 |  |  |  |  | sub _pretty_print { return $pretty; }
8256 |  |  |  |  |
8257 |  |  |  |  | # set the empty tag style (in $empty_tag_style) and returns the old one
8258 |  |  |  |  | # can be called from outside the package with 2 arguments (elt, style)
8259 |  |  |  |  | # or from inside with only one argument (style)
8260 |  |  |  |  | # the style can be either a string (one of the keys of %empty_tag_style
8261 |  |  |  |  | # or a number (presumably an old value saved)
8262 |  |  |  |  | sub set_empty_tag_style
8263 |  |  |  |  | { my $style= lc( defined $_[1] ? $_[1] : $_[0]); # so we cover both cases
8264 |  |  |  |  | my $old_style= $empty_tag_style;
8265 |  |  |  |  | if( $style=~ /^\d+$/)
8266 |  |  |  |  | { croak "invalid empty tag style $style"
8267 |  |  |  |  | unless( $style < keys %empty_tag_style);
8268 |  |  |  |  | $empty_tag_style= $style;
8269 |  |  |  |  | }
8270 |  |  |  |  | else
8271 |  |  |  |  | { croak "invalid empty tag style '$style'"
8272 |  |  |  |  | unless( exists $empty_tag_style{$style});
8273 |  |  |  |  | $empty_tag_style= $empty_tag_style{$style};
8274 |  |  |  |  | }
8275 |  |  |  |  | return $old_style;
8276 |  |  |  |  | }
8277 |  |  |  |  |
8278 |  |  |  |  | sub _pretty_print_styles
8279 |  |  |  |  | { return (sort { $pretty_print_style{$a} <=> $pretty_print_style{$b} || $a cmp $b } keys %pretty_print_style); }
8280 |  |  |  |  |
8281 |  |  |  |  | sub set_quote
8282 | 7 | 2µs |  |  | # spent 11µs within XML::Twig::Elt::set_quote which was called 7 times, avg 2µs/call: # 7 times (11µs+0s) by XML::Twig::set_quote at line 3922, avg 2µs/call { my $style= $_[1] || $_[0];
8283 | 7 | 1µs |  |  | my $old_quote= $quote;
8284 | 7 | 3µs |  |  | croak "invalid quote '$style'" unless( exists $quote_style{$style});
8285 | 7 | 2µs |  |  | $quote= $quote_style{$style};
8286 | 7 | 7µs |  |  | return $old_quote;
8287 |  |  |  |  | }
8288 |  |  |  |  |
8289 |  |  |  |  | sub set_remove_cdata
8290 | 7 | 1µs |  |  | # spent 5µs within XML::Twig::Elt::set_remove_cdata which was called 7 times, avg 729ns/call: # 7 times (5µs+0s) by XML::Twig::set_remove_cdata at line 3892, avg 729ns/call { my $new_value= defined $_[1] ? $_[1] : $_[0];
8291 | 7 | 900ns |  |  | my $old_value= $remove_cdata;
8292 | 7 | 400ns |  |  | $remove_cdata= $new_value;
8293 | 7 | 7µs |  |  | return $old_value;
8294 |  |  |  |  | }
8295 |  |  |  |  |
8296 |  |  |  |  |
8297 |  |  |  |  | sub set_indent
8298 |  |  |  |  | { my $new_value= defined $_[1] ? $_[1] : $_[0];
8299 |  |  |  |  | my $old_value= $INDENT;
8300 |  |  |  |  | $INDENT= $new_value;
8301 |  |  |  |  | return $old_value;
8302 |  |  |  |  | }
8303 |  |  |  |  |
8304 |  |  |  |  | sub set_wrap
8305 |  |  |  |  | { my $new_value= defined $_[1] ? $_[1] : $_[0];
8306 |  |  |  |  | my $old_value= $WRAP;
8307 |  |  |  |  | $WRAP= $new_value;
8308 |  |  |  |  | return $old_value;
8309 |  |  |  |  | }
8310 |  |  |  |  |
8311 |  |  |  |  |
8312 |  |  |  |  | sub set_keep_encoding
8313 | 7 | 2µs |  |  | # spent 8µs within XML::Twig::Elt::set_keep_encoding which was called 7 times, avg 1µs/call: # 7 times (8µs+0s) by XML::Twig::set_keep_encoding at line 3774, avg 1µs/call { my $new_value= defined $_[1] ? $_[1] : $_[0];
8314 | 7 | 1µs |  |  | my $old_value= $keep_encoding;
8315 | 7 | 1µs |  |  | $keep_encoding= $new_value;
8316 | 7 | 8µs |  |  | return $old_value;
8317 |  |  |  |  | }
8318 |  |  |  |  |
8319 |  |  |  |  | sub set_replaced_ents
8320 |  |  |  |  | { my $new_value= defined $_[1] ? $_[1] : $_[0];
8321 |  |  |  |  | my $old_value= $replaced_ents;
8322 |  |  |  |  | $replaced_ents= $new_value;
8323 |  |  |  |  | return $old_value;
8324 |  |  |  |  | }
8325 |  |  |  |  |
8326 |  |  |  |  | sub do_not_escape_gt
8327 |  |  |  |  | { my $old_value= $replaced_ents;
8328 |  |  |  |  | $replaced_ents= q{&<}; # & needs to be first
8329 |  |  |  |  | return $old_value;
8330 |  |  |  |  | }
8331 |  |  |  |  |
8332 |  |  |  |  | sub escape_gt
8333 |  |  |  |  | { my $old_value= $replaced_ents;
8334 |  |  |  |  | $replaced_ents= qq{&<>}; # & needs to be first
8335 |  |  |  |  | return $old_value;
8336 |  |  |  |  | }
8337 |  |  |  |  |
8338 |  |  |  |  | sub _keep_encoding { return $keep_encoding; } # so I can use elsewhere in the module
8339 |  |  |  |  |
8340 |  |  |  |  | sub set_do_not_escape_amp_in_atts
8341 | 7 | 2µs |  |  | # spent 7µs within XML::Twig::Elt::set_do_not_escape_amp_in_atts which was called 7 times, avg 943ns/call: # 7 times (7µs+0s) by XML::Twig::set_do_not_escape_amp_in_atts at line 3934, avg 943ns/call { my $new_value= defined $_[1] ? $_[1] : $_[0];
8342 | 7 | 1µs |  |  | my $old_value= $do_not_escape_amp_in_atts;
8343 | 7 | 400ns |  |  | $do_not_escape_amp_in_atts= $new_value;
8344 | 7 | 7µs |  |  | return $old_value;
8345 |  |  |  |  | }
8346 |  |  |  |  |
8347 |  |  |  |  | sub output_filter { return $output_filter; }
8348 |  |  |  |  | sub output_text_filter { return $output_text_filter; }
8349 |  |  |  |  |
8350 |  |  |  |  | sub set_output_filter
8351 | 7 | 1µs |  |  | # spent 25µs (21+4) within XML::Twig::Elt::set_output_filter which was called 7 times, avg 4µs/call: # 7 times (21µs+4µs) by XML::Twig::set_output_filter at line 3895, avg 4µs/call { my $new_value= defined $_[1] ? $_[1] : $_[0]; # can be called in object/non-object mode
8352 |  |  |  |  | # if called in object mode with no argument, the filter is undefined
8353 | 7 | 17µs | 14 | 4µs | if( isa( $new_value, 'XML::Twig::Elt') || isa( $new_value, 'XML::Twig')) { undef $new_value; } # spent 4µs making 14 calls to UNIVERSAL::isa, avg 271ns/call
8354 | 7 | 1µs |  |  | my $old_value= $output_filter;
8355 | 7 | 2µs |  |  | if( !$new_value || isa( $new_value, 'CODE') )
8356 |  |  |  |  | { $output_filter= $new_value; }
8357 |  |  |  |  | elsif( $new_value eq 'latin1')
8358 |  |  |  |  | { $output_filter= XML::Twig::latin1();
8359 |  |  |  |  | }
8360 |  |  |  |  | elsif( $XML::Twig::filter{$new_value})
8361 |  |  |  |  | { $output_filter= $XML::Twig::filter{$new_value}; }
8362 |  |  |  |  | else
8363 |  |  |  |  | { croak "invalid output filter '$new_value'"; }
8364 |  |  |  |  |
8365 | 7 | 6µs |  |  | return $old_value;
8366 |  |  |  |  | }
8367 |  |  |  |  |
8368 |  |  |  |  | sub set_output_text_filter
8369 | 7 | 1µs |  |  | # spent 20µs (18+1) within XML::Twig::Elt::set_output_text_filter which was called 7 times, avg 3µs/call: # 7 times (18µs+1µs) by XML::Twig::set_output_text_filter at line 3898, avg 3µs/call { my $new_value= defined $_[1] ? $_[1] : $_[0]; # can be called in object/non-object mode
8370 |  |  |  |  | # if called in object mode with no argument, the filter is undefined
8371 | 7 | 13µs | 14 | 1µs | if( isa( $new_value, 'XML::Twig::Elt') || isa( $new_value, 'XML::Twig')) { undef $new_value; } # spent 1µs making 14 calls to UNIVERSAL::isa, avg 100ns/call
8372 | 7 | 700ns |  |  | my $old_value= $output_text_filter;
8373 | 7 | 1µs |  |  | if( !$new_value || isa( $new_value, 'CODE') )
8374 |  |  |  |  | { $output_text_filter= $new_value; }
8375 |  |  |  |  | elsif( $new_value eq 'latin1')
8376 |  |  |  |  | { $output_text_filter= XML::Twig::latin1();
8377 |  |  |  |  | }
8378 |  |  |  |  | elsif( $XML::Twig::filter{$new_value})
8379 |  |  |  |  | { $output_text_filter= $XML::Twig::filter{$new_value}; }
8380 |  |  |  |  | else
8381 |  |  |  |  | { croak "invalid output text filter '$new_value'"; }
8382 |  |  |  |  |
8383 | 7 | 6µs |  |  | return $old_value;
8384 |  |  |  |  | }
8385 |  |  |  |  |
8386 |  |  |  |  | sub set_expand_external_entities
8387 | 7 | 2µs |  |  | # spent 8µs within XML::Twig::Elt::set_expand_external_entities which was called 7 times, avg 1µs/call: # 7 times (8µs+0s) by XML::Twig::set_expand_external_entities at line 3778, avg 1µs/call { my $new_value= defined $_[1] ? $_[1] : $_[0];
8388 | 7 | 1µs |  |  | my $old_value= $expand_external_entities;
8389 | 7 | 900ns |  |  | $expand_external_entities= $new_value;
8390 | 7 | 8µs |  |  | return $old_value;
8391 |  |  |  |  | }
8392 |  |  |  |  |
8393 |  |  |  |  | sub set_keep_atts_order
8394 | 7 | 2µs |  |  | # spent 7µs within XML::Twig::Elt::set_keep_atts_order which was called 7 times, avg 971ns/call: # 7 times (7µs+0s) by XML::Twig::set_keep_atts_order at line 3928, avg 971ns/call { my $new_value= defined $_[1] ? $_[1] : $_[0];
8395 | 7 | 1µs |  |  | my $old_value= $keep_atts_order;
8396 | 7 | 600ns |  |  | $keep_atts_order= $new_value;
8397 | 7 | 7µs |  |  | return $old_value;
8398 |  |  |  |  |
8399 |  |  |  |  | }
8400 |  |  |  |  |
8401 | 364369 | 792ms |  |  | # spent 128ms within XML::Twig::Elt::keep_atts_order which was called 364369 times, avg 352ns/call: # 364369 times (128ms+0s) by XML::Twig::Elt::set_atts at line 6138, avg 352ns/call sub keep_atts_order { return $keep_atts_order; } # so I can use elsewhere in the module
8402 |  |  |  |  |
8403 | 1 | 300ns |  |  | my %html_empty_elt;
8404 | 1 | 2.45ms | 1 | 7µs | # spent 7µs within XML::Twig::Elt::BEGIN@8404 which was called: # once (7µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 8404 BEGIN { %html_empty_elt= map { $_ => 1} qw( base meta link hr br param img area input col); } # spent 7µs making 1 call to XML::Twig::Elt::BEGIN@8404
8405 |  |  |  |  |
8406 |  |  |  |  | sub start_tag
8407 |  |  |  |  | { my( $elt, $option)= @_;
8408 |  |  |  |  |
8409 |  |  |  |  |
8410 |  |  |  |  | return if( $elt->{gi} < $XML::Twig::SPECIAL_GI);
8411 |  |  |  |  |
8412 |  |  |  |  | my $extra_data= $elt->{extra_data} || '';
8413 |  |  |  |  |
8414 |  |  |  |  | my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
8415 |  |  |  |  | my $att= $elt->{att}; # should be $elt->{att}, optimized into a pure hash look-up
8416 |  |  |  |  |
8417 |  |  |  |  | my $ns_map= $att ? $att->{'#original_gi'} : '';
8418 |  |  |  |  | if( $ns_map) { $gi= _restore_original_prefix( $ns_map, $gi); }
8419 |  |  |  |  | $gi=~ s{^#default:}{}; # remove default prefix
8420 |  |  |  |  |
8421 |  |  |  |  | if( $output_text_filter) { $gi= $output_text_filter->( $gi); }
8422 |  |  |  |  |
8423 |  |  |  |  | # get the attribute and their values
8424 |  |  |  |  | my $att_sep = $pretty==$NSGMLS ? "\n"
8425 |  |  |  |  | : $pretty==$INDENTEDA ? "\n" . $INDENT x ($elt->level+1) . ' '
8426 |  |  |  |  | : ' '
8427 |  |  |  |  | ;
8428 |  |  |  |  |
8429 |  |  |  |  | my $replace_in_att_value= $replaced_ents . "$quote\t\r\n";
8430 |  |  |  |  | if( $option->{escape_gt} && $replaced_ents !~ m{>}) { $replace_in_att_value.= '>'; }
8431 |  |  |  |  |
8432 |  |  |  |  | my $tag;
8433 |  |  |  |  | my @att_names= grep { !( $_=~ m{^#(?!default:)} ) } $keep_atts_order ? keys %{$att} : sort keys %{$att};
8434 |  |  |  |  | if( @att_names)
8435 |  |  |  |  | { my $atts= join $att_sep, map { my $output_att_name= $ns_map ? _restore_original_prefix( $ns_map, $_) : $_;
8436 |  |  |  |  | if( $output_text_filter)
8437 |  |  |  |  | { $output_att_name= $output_text_filter->( $output_att_name); }
8438 |  |  |  |  | $output_att_name . '=' . $quote . _att_xml_string( $att->{$_}, $replace_in_att_value) . $quote
8439 |  |  |  |  |
8440 |  |  |  |  | }
8441 |  |  |  |  | @att_names
8442 |  |  |  |  | ;
8443 |  |  |  |  | if( $pretty==$INDENTEDA && @att_names == 1) { $att_sep= ' '; }
8444 |  |  |  |  | $tag= "<$gi$att_sep$atts";
8445 |  |  |  |  | }
8446 |  |  |  |  | else
8447 |  |  |  |  | { $tag= "<$gi"; }
8448 |  |  |  |  |
8449 |  |  |  |  | $tag .= "\n" if($pretty==$NSGMLS);
8450 |  |  |  |  |
8451 |  |  |  |  |
8452 |  |  |  |  | # force empty if suitable HTML tag, otherwise use the value from the input tree
8453 |  |  |  |  | if( ($empty_tag_style eq $HTML) && !$elt->{first_child} && !$elt->{extra_data_before_end_tag} && $html_empty_elt{$gi})
8454 |  |  |  |  | { $elt->{empty}= 1; }
8455 |  |  |  |  | my $empty= defined $elt->{empty} ? $elt->{empty}
8456 |  |  |  |  | : $elt->{first_child} ? 0
8457 |  |  |  |  | : 1;
8458 |  |  |  |  |
8459 |  |  |  |  | $tag .= (!$elt->{empty} || $elt->{extra_data_before_end_tag}) ? '>' # element has content
8460 |  |  |  |  | : (($empty_tag_style eq $HTML) && $html_empty_elt{$gi}) ? ' />' # html empty element
8461 |  |  |  |  | # cvs-friendly format
8462 |  |  |  |  | : ( $pretty == $INDENTEDA && @att_names > 1) ? "\n" . $INDENT x $elt->level . "/>"
8463 |  |  |  |  | : ( $pretty == $INDENTEDA && @att_names == 1) ? " />"
8464 |  |  |  |  | : $empty_tag_style ? "></" . $XML::Twig::index2gi[$elt->{'gi'}] . ">" # $empty_tag_style is $HTML or $EXPAND
8465 |  |  |  |  | : '/>'
8466 |  |  |  |  | ;
8467 |  |  |  |  |
8468 |  |  |  |  | if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') )) { $tag= ''; }
8469 |  |  |  |  |
8470 |  |  |  |  | #warn "TRACE: ", $tag,": ", Encode::is_utf8( $tag) ? "has flag" : "FLAG NOT SET";
8471 |  |  |  |  |
8472 |  |  |  |  | unless( $pretty) { return defined( $extra_data) ? $extra_data . $tag : $tag; }
8473 |  |  |  |  |
8474 |  |  |  |  | my $prefix='';
8475 |  |  |  |  | my $return=''; # '' or \n is to be printed before the tag
8476 |  |  |  |  | my $indent=0; # number of indents before the tag
8477 |  |  |  |  |
8478 |  |  |  |  | if( $pretty==$RECORD1)
8479 |  |  |  |  | { my $level= $elt->level;
8480 |  |  |  |  | $return= "\n" if( $level < 2);
8481 |  |  |  |  | $indent= 1 if( $level == 1);
8482 |  |  |  |  | }
8483 |  |  |  |  |
8484 |  |  |  |  | elsif( $pretty==$RECORD2)
8485 |  |  |  |  | { $return= "\n";
8486 |  |  |  |  | $indent= $elt->level;
8487 |  |  |  |  | }
8488 |  |  |  |  |
8489 |  |  |  |  | elsif( $pretty==$NICE)
8490 |  |  |  |  | { my $parent= $elt->{parent};
8491 |  |  |  |  | unless( !$parent || $parent->{contains_text})
8492 |  |  |  |  | { $return= "\n"; }
8493 |  |  |  |  | $elt->{contains_text}= 1 if( ($parent && $parent->{contains_text})
8494 |  |  |  |  | || $elt->contains_text);
8495 |  |  |  |  | }
8496 |  |  |  |  |
8497 |  |  |  |  | elsif( $KEEP_TEXT_TAG_ON_ONE_LINE{$pretty})
8498 |  |  |  |  | { my $parent= $elt->{parent};
8499 |  |  |  |  | unless( !$parent || $parent->{contains_text})
8500 |  |  |  |  | { $return= "\n";
8501 |  |  |  |  | $indent= $elt->level;
8502 |  |  |  |  | }
8503 |  |  |  |  | $elt->{contains_text}= 1 if( ($parent && $parent->{contains_text})
8504 |  |  |  |  | || $elt->contains_text);
8505 |  |  |  |  | }
8506 |  |  |  |  |
8507 |  |  |  |  | if( $return || $indent)
8508 |  |  |  |  | { # check for elements in which spaces should be kept
8509 |  |  |  |  | my $t= $elt->twig;
8510 |  |  |  |  | return $extra_data . $tag if( $xml_space_preserve);
8511 |  |  |  |  | if( $t && $t->{twig_keep_spaces_in})
8512 |  |  |  |  | { foreach my $ancestor ($elt->ancestors)
8513 |  |  |  |  | { return $extra_data . $tag if( $t->{twig_keep_spaces_in}->{$XML::Twig::index2gi[$ancestor->{'gi'}]}) }
8514 |  |  |  |  | }
8515 |  |  |  |  |
8516 |  |  |  |  | $prefix= $INDENT x $indent;
8517 |  |  |  |  | if( $extra_data)
8518 |  |  |  |  | { $extra_data=~ s{\s+$}{};
8519 |  |  |  |  | $extra_data=~ s{^\s+}{};
8520 |  |  |  |  | $extra_data= $prefix . $extra_data . $return;
8521 |  |  |  |  | }
8522 |  |  |  |  | }
8523 |  |  |  |  |
8524 |  |  |  |  |
8525 |  |  |  |  | return $return . $extra_data . $prefix . $tag;
8526 |  |  |  |  | }
8527 |  |  |  |  |
8528 |  |  |  |  | sub end_tag
8529 |  |  |  |  | { my $elt= shift;
8530 |  |  |  |  | return '' if( ($elt->{gi}<$XML::Twig::SPECIAL_GI)
8531 |  |  |  |  | || ($elt->{'empty'} && !$elt->{extra_data_before_end_tag})
8532 |  |  |  |  | );
8533 |  |  |  |  | my $tag= "<";
8534 |  |  |  |  | my $gi= $XML::Twig::index2gi[$elt->{'gi'}];
8535 |  |  |  |  |
8536 |  |  |  |  | if( my $map= $elt->{'att'}->{'#original_gi'}) { $gi= _restore_original_prefix( $map, $gi); }
8537 |  |  |  |  | $gi=~ s{^#default:}{}; # remove default prefix
8538 |  |  |  |  |
8539 |  |  |  |  | if( $output_text_filter) { $gi= $output_text_filter->( $XML::Twig::index2gi[$elt->{'gi'}]); }
8540 |  |  |  |  | $tag .= "/$gi>";
8541 |  |  |  |  |
8542 |  |  |  |  | $tag = ($elt->{extra_data_before_end_tag} || '') . $tag;
8543 |  |  |  |  |
8544 |  |  |  |  | if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') )) { $tag= ''; }
8545 |  |  |  |  |
8546 |  |  |  |  | return $tag unless $pretty;
8547 |  |  |  |  |
8548 |  |  |  |  | my $prefix='';
8549 |  |  |  |  | my $return=0; # 1 if a \n is to be printed before the tag
8550 |  |  |  |  | my $indent=0; # number of indents before the tag
8551 |  |  |  |  |
8552 |  |  |  |  | if( $pretty==$RECORD1)
8553 |  |  |  |  | { $return= 1 if( $elt->level == 0);
8554 |  |  |  |  | }
8555 |  |  |  |  |
8556 |  |  |  |  | elsif( $pretty==$RECORD2)
8557 |  |  |  |  | { unless( $elt->contains_text)
8558 |  |  |  |  | { $return= 1 ;
8559 |  |  |  |  | $indent= $elt->level;
8560 |  |  |  |  | }
8561 |  |  |  |  | }
8562 |  |  |  |  |
8563 |  |  |  |  | elsif( $pretty==$NICE)
8564 |  |  |  |  | { my $parent= $elt->{parent};
8565 |  |  |  |  | if( ( ($parent && !$parent->{contains_text}) || !$parent )
8566 |  |  |  |  | && ( !$elt->{contains_text}
8567 |  |  |  |  | && ($elt->{has_flushed_child} || $elt->{first_child})
8568 |  |  |  |  | )
8569 |  |  |  |  | )
8570 |  |  |  |  | { $return= 1; }
8571 |  |  |  |  | }
8572 |  |  |  |  |
8573 |  |  |  |  | elsif( $KEEP_TEXT_TAG_ON_ONE_LINE{$pretty})
8574 |  |  |  |  | { my $parent= $elt->{parent};
8575 |  |  |  |  | if( ( ($parent && !$parent->{contains_text}) || !$parent )
8576 |  |  |  |  | && ( !$elt->{contains_text}
8577 |  |  |  |  | && ($elt->{has_flushed_child} || $elt->{first_child})
8578 |  |  |  |  | )
8579 |  |  |  |  | )
8580 |  |  |  |  | { $return= 1;
8581 |  |  |  |  | $indent= $elt->level;
8582 |  |  |  |  | }
8583 |  |  |  |  | }
8584 |  |  |  |  |
8585 |  |  |  |  | if( $return || $indent)
8586 |  |  |  |  | { # check for elements in which spaces should be kept
8587 |  |  |  |  | my $t= $elt->twig;
8588 |  |  |  |  | return $tag if( $xml_space_preserve);
8589 |  |  |  |  | if( $t && $t->{twig_keep_spaces_in})
8590 |  |  |  |  | { foreach my $ancestor ($elt, $elt->ancestors)
8591 |  |  |  |  | { return $tag if( $t->{twig_keep_spaces_in}->{$XML::Twig::index2gi[$ancestor->{'gi'}]}) }
8592 |  |  |  |  | }
8593 |  |  |  |  |
8594 |  |  |  |  | if( $return) { $prefix= ($pretty== $INDENTEDCT) ? "\n$INDENT" : "\n"; }
8595 |  |  |  |  | $prefix.= $INDENT x $indent;
8596 |  |  |  |  | }
8597 |  |  |  |  |
8598 |  |  |  |  | # add a \n at the end of the document (after the root element)
8599 |  |  |  |  | $tag .= "\n" unless( $elt->{parent});
8600 |  |  |  |  |
8601 |  |  |  |  | return $prefix . $tag;
8602 |  |  |  |  | }
8603 |  |  |  |  |
8604 |  |  |  |  | sub _restore_original_prefix
8605 |  |  |  |  | { my( $map, $name)= @_;
8606 |  |  |  |  | my $prefix= _ns_prefix( $name);
8607 |  |  |  |  | if( my $original_prefix= $map->{$prefix})
8608 |  |  |  |  | { if( $original_prefix eq '#default')
8609 |  |  |  |  | { $name=~ s{^$prefix:}{}; }
8610 |  |  |  |  | else
8611 |  |  |  |  | { $name=~ s{^$prefix(?=:)}{$original_prefix}; }
8612 |  |  |  |  | }
8613 |  |  |  |  | return $name;
8614 |  |  |  |  | }
8615 |  |  |  |  |
8616 |  |  |  |  | # buffer used to hold the text to print/sprint, to avoid passing it back and forth between methods
8617 |  |  |  |  | my @sprint;
8618 |  |  |  |  |
8619 |  |  |  |  | # $elt is an element to print
8620 |  |  |  |  | # $fh is an optional filehandle to print to
8621 |  |  |  |  | # $pretty is an optional value, if true a \n is printed after the < of the
8622 |  |  |  |  | # opening tag
8623 |  |  |  |  | sub print
8624 |  |  |  |  | { my $elt= shift;
8625 |  |  |  |  |
8626 |  |  |  |  | my $fh= isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar') ? shift : undef;
8627 |  |  |  |  | my $old_select= defined $fh ? select $fh : undef;
8628 |  |  |  |  | print $elt->sprint( @_);
8629 |  |  |  |  | select $old_select if( defined $old_select);
8630 |  |  |  |  | }
8631 |  |  |  |  |
8632 |  |  |  |  |
8633 |  |  |  |  | # those next 2 methods need to be refactored, they are copies of the same methods in XML::Twig
8634 |  |  |  |  | sub print_to_file
8635 |  |  |  |  | { my( $elt, $filename)= (shift, shift);
8636 |  |  |  |  | my $out_fh;
8637 |  |  |  |  | # open( $out_fh, ">$filename") or _croak( "cannot create file $filename: $!"); # < perl 5.8
8638 |  |  |  |  | my $mode= $keep_encoding ? '>' : '>:utf8'; # >= perl 5.8
8639 |  |  |  |  | open( $out_fh, $mode, $filename) or _croak( "cannot create file $filename: $!"); # >= perl 5.8
8640 |  |  |  |  | $elt->print( $out_fh, @_);
8641 |  |  |  |  | close $out_fh;
8642 |  |  |  |  | return $elt;
8643 |  |  |  |  | }
8644 |  |  |  |  |
8645 |  |  |  |  | # probably only works on *nix (at least the chmod bit)
8646 |  |  |  |  | # first print to a temporary file, then rename that file to the desired file name, then change permissions
8647 |  |  |  |  | # to the original file permissions (or to the current umask)
8648 |  |  |  |  | sub safe_print_to_file
8649 |  |  |  |  | { my( $elt, $filename)= (shift, shift);
8650 |  |  |  |  | my $perm= -f $filename ? (stat $filename)[2] & 07777 : ~umask() ;
8651 |  |  |  |  | XML::Twig::_use( 'File::Temp') || croak "need File::Temp to use safe_print_to_file\n";
8652 |  |  |  |  | XML::Twig::_use( 'File::Basename') || croak "need File::Basename to use safe_print_to_file\n";
8653 |  |  |  |  | my $tmpdir= File::Basename::dirname( $filename);
8654 |  |  |  |  | my( $fh, $tmpfilename) = File::Temp::tempfile( DIR => $tmpdir);
8655 |  |  |  |  | $elt->print_to_file( $tmpfilename, @_);
8656 |  |  |  |  | rename( $tmpfilename, $filename) or unlink $tmpfilename && _croak( "cannot move temporary file to $filename: $!");
8657 |  |  |  |  | chmod $perm, $filename;
8658 |  |  |  |  | return $elt;
8659 |  |  |  |  | }
8660 |  |  |  |  |
8661 |  |  |  |  |
8662 |  |  |  |  | # same as print but does not output the start tag if the element
8663 |  |  |  |  | # is marked as flushed
8664 |  |  |  |  | sub flush
8665 |  |  |  |  | { my $elt= shift;
8666 |  |  |  |  | my $up_to= $_[0] && isa( $_[0], 'XML::Twig::Elt') ? shift : $elt;
8667 |  |  |  |  | $elt->twig->flush_up_to( $up_to, @_);
8668 |  |  |  |  | }
8669 |  |  |  |  | sub purge
8670 |  |  |  |  | { my $elt= shift;
8671 |  |  |  |  | my $up_to= $_[0] && isa( $_[0], 'XML::Twig::Elt') ? shift : $elt;
8672 |  |  |  |  | $elt->twig->purge_up_to( $up_to, @_);
8673 |  |  |  |  | }
8674 |  |  |  |  |
8675 |  |  |  |  | sub _flush
8676 |  |  |  |  | { my $elt= shift;
8677 |  |  |  |  |
8678 |  |  |  |  | my $pretty;
8679 |  |  |  |  | my $fh= isa( $_[0], 'GLOB') || isa( $_[0], 'IO::Scalar') ? shift : undef;
8680 |  |  |  |  | my $old_select= defined $fh ? select $fh : undef;
8681 |  |  |  |  | my $old_pretty= defined ($pretty= shift) ? set_pretty_print( $pretty) : undef;
8682 |  |  |  |  |
8683 |  |  |  |  | $xml_space_preserve= 1 if( ($elt->inherit_att( 'xml:space') || '') eq 'preserve');
8684 |  |  |  |  |
8685 |  |  |  |  | $elt->__flush();
8686 |  |  |  |  |
8687 |  |  |  |  | $xml_space_preserve= 0;
8688 |  |  |  |  |
8689 |  |  |  |  | select $old_select if( defined $old_select);
8690 |  |  |  |  | set_pretty_print( $old_pretty) if( defined $old_pretty);
8691 |  |  |  |  | }
8692 |  |  |  |  |
8693 |  |  |  |  | sub __flush
8694 |  |  |  |  | { my $elt= shift;
8695 |  |  |  |  |
8696 |  |  |  |  | if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
8697 |  |  |  |  | { my $preserve= ($elt->{'att'}->{'xml:space'} || '') eq 'preserve';
8698 |  |  |  |  | $xml_space_preserve++ if $preserve;
8699 |  |  |  |  | unless( $elt->{'flushed'})
8700 |  |  |  |  | { print $elt->start_tag();
8701 |  |  |  |  | }
8702 |  |  |  |  |
8703 |  |  |  |  | # flush the children
8704 |  |  |  |  | my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
8705 |  |  |  |  | foreach my $child (@children)
8706 |  |  |  |  | { $child->_flush( $pretty);
8707 |  |  |  |  | $child->{'flushed'}=1;
8708 |  |  |  |  | }
8709 |  |  |  |  | if( ! $elt->{end_tag_flushed})
8710 |  |  |  |  | { print $elt->end_tag;
8711 |  |  |  |  | $elt->{end_tag_flushed}=1;
8712 |  |  |  |  | $elt->{'flushed'}=1;
8713 |  |  |  |  | }
8714 |  |  |  |  | $xml_space_preserve-- if $preserve;
8715 |  |  |  |  | # used for pretty printing
8716 |  |  |  |  | if( my $parent= $elt->{parent}) { $parent->{has_flushed_child}= 1; }
8717 |  |  |  |  | }
8718 |  |  |  |  | else # text or special element
8719 |  |  |  |  | { my $text;
8720 |  |  |  |  | if( (exists $elt->{'pcdata'})) { $text= $elt->pcdata_xml_string;
8721 |  |  |  |  | if( my $parent= $elt->{parent})
8722 |  |  |  |  | { $parent->{contains_text}= 1; }
8723 |  |  |  |  | }
8724 |  |  |  |  | elsif( (exists $elt->{'cdata'})) { $text= $elt->cdata_string;
8725 |  |  |  |  | if( my $parent= $elt->{parent})
8726 |  |  |  |  | { $parent->{contains_text}= 1; }
8727 |  |  |  |  | }
8728 |  |  |  |  | elsif( (exists $elt->{'target'})) { $text= $elt->pi_string; }
8729 |  |  |  |  | elsif( (exists $elt->{'comment'})) { $text= $elt->comment_string; }
8730 |  |  |  |  | elsif( (exists $elt->{'ent'})) { $text= $elt->ent_string; }
8731 |  |  |  |  |
8732 |  |  |  |  | print $output_filter ? $output_filter->( $text) : $text;
8733 |  |  |  |  | }
8734 |  |  |  |  | }
8735 |  |  |  |  |
8736 |  |  |  |  |
8737 |  |  |  |  | sub xml_text
8738 |  |  |  |  | { my( $elt, @options)= @_;
8739 |  |  |  |  |
8740 |  |  |  |  | if( @options && grep { lc( $_) eq 'no_recurse' } @options) { return $elt->xml_text_only; }
8741 |  |  |  |  |
8742 |  |  |  |  | my $string='';
8743 |  |  |  |  |
8744 |  |  |  |  | if( ($elt->{gi} >= $XML::Twig::SPECIAL_GI) )
8745 |  |  |  |  | { # sprint the children
8746 |  |  |  |  | my $child= $elt->{first_child} || '';
8747 |  |  |  |  | while( $child)
8748 |  |  |  |  | { $string.= $child->xml_text;
8749 |  |  |  |  | } continue { $child= $child->{next_sibling}; }
8750 |  |  |  |  | }
8751 |  |  |  |  | elsif( (exists $elt->{'pcdata'})) { $string .= $output_filter ? $output_filter->($elt->pcdata_xml_string)
8752 |  |  |  |  | : $elt->pcdata_xml_string;
8753 |  |  |  |  | }
8754 |  |  |  |  | elsif( (exists $elt->{'cdata'})) { $string .= $output_filter ? $output_filter->($elt->cdata_string)
8755 |  |  |  |  | : $elt->cdata_string;
8756 |  |  |  |  | }
8757 |  |  |  |  | elsif( (exists $elt->{'ent'})) { $string .= $elt->ent_string; }
8758 |  |  |  |  |
8759 |  |  |  |  | return $string;
8760 |  |  |  |  | }
8761 |  |  |  |  |
8762 |  |  |  |  | sub xml_text_only
8763 |  |  |  |  | { return join '', map { $_->xml_text if( $_->is_text || (exists $_->{'ent'})) } $_[0]->_children; }
8764 |  |  |  |  |
8765 |  |  |  |  | # same as print but except... it does not print but rather returns the string
8766 |  |  |  |  | # if the second parameter is set then only the content is returned, not the
8767 |  |  |  |  | # start and end tags of the element (but the tags of the included elements are
8768 |  |  |  |  | # returned)
8769 |  |  |  |  |
8770 |  |  |  |  | sub sprint
8771 |  |  |  |  | { my $elt= shift;
8772 |  |  |  |  | my( $old_pretty, $old_empty_tag_style);
8773 |  |  |  |  |
8774 |  |  |  |  | if( $_[0])
8775 |  |  |  |  | { if( isa( $_[0], 'HASH'))
8776 |  |  |  |  | { # "proper way, using a hashref for options
8777 |  |  |  |  | my %args= XML::Twig::_normalize_args( %{shift()});
8778 |  |  |  |  | if( defined $args{PrettyPrint}) { $old_pretty = set_pretty_print( $args{PrettyPrint}); }
8779 |  |  |  |  | if( defined $args{EmptyTags}) { $old_empty_tag_style = set_empty_tag_style( $args{EmptyTags}); }
8780 |  |  |  |  | }
8781 |  |  |  |  | else
8782 |  |  |  |  | { # "old" way, just using the option name
8783 |  |  |  |  | my @other_opt;
8784 |  |  |  |  | foreach my $opt (@_)
8785 |  |  |  |  | { if( exists $pretty_print_style{$opt}) { $old_pretty = set_pretty_print( $opt); }
8786 |  |  |  |  | elsif( exists $empty_tag_style{$opt}) { $old_empty_tag_style = set_empty_tag_style( $opt); }
8787 |  |  |  |  | else { push @other_opt, $opt; }
8788 |  |  |  |  | }
8789 |  |  |  |  | @_= @other_opt;
8790 |  |  |  |  | }
8791 |  |  |  |  | }
8792 |  |  |  |  |
8793 |  |  |  |  | $xml_space_preserve= 1 if( ($elt->inherit_att( 'xml:space') || '') eq 'preserve');
8794 |  |  |  |  |
8795 |  |  |  |  | @sprint=();
8796 |  |  |  |  | $elt->_sprint( @_);
8797 |  |  |  |  | my $sprint= join( '', @sprint);
8798 |  |  |  |  | if( $output_filter) { $sprint= $output_filter->( $sprint); }
8799 |  |  |  |  |
8800 |  |  |  |  | if( ( ($pretty== $WRAPPED) || ($pretty==$INDENTEDC)) && !$xml_space_preserve)
8801 |  |  |  |  | { $sprint= _wrap_text( $sprint); }
8802 |  |  |  |  | $xml_space_preserve= 0;
8803 |  |  |  |  |
8804 |  |  |  |  |
8805 |  |  |  |  | if( defined $old_pretty) { set_pretty_print( $old_pretty); }
8806 |  |  |  |  | if( defined $old_empty_tag_style) { set_empty_tag_style( $old_empty_tag_style); }
8807 |  |  |  |  |
8808 |  |  |  |  | return $sprint;
8809 |  |  |  |  | }
8810 |  |  |  |  |
8811 |  |  |  |  | sub _wrap_text
8812 |  |  |  |  | { my( $string)= @_;
8813 |  |  |  |  | my $wrapped;
8814 |  |  |  |  | foreach my $line (split /\n/, $string)
8815 |  |  |  |  | { my( $initial_indent)= $line=~ m{^(\s*)};
8816 |  |  |  |  | my $wrapped_line= Text::Wrap::wrap( '', $initial_indent . $INDENT, $line) . "\n";
8817 |  |  |  |  |
8818 |  |  |  |  | # fix glitch with Text::wrap when the first line is long and does not include spaces
8819 |  |  |  |  | # the first line ends up being too short by 2 chars, but we'll have to live with it!
8820 |  |  |  |  | $wrapped_line=~ s{^ +\n }{}s; # this prefix needs to be removed
8821 |  |  |  |  |
8822 |  |  |  |  | $wrapped .= $wrapped_line;
8823 |  |  |  |  | }
8824 |  |  |  |  |
8825 |  |  |  |  | return $wrapped;
8826 |  |  |  |  | }
8827 |  |  |  |  |
8828 |  |  |  |  |
8829 |  |  |  |  | sub _sprint
8830 |  |  |  |  | { my $elt= shift;
8831 |  |  |  |  | my $no_tag= shift || 0;
8832 |  |  |  |  | # in case there's some comments or PI's piggybacking
8833 |  |  |  |  |
8834 |  |  |  |  | if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
8835 |  |  |  |  | {
8836 |  |  |  |  | my $preserve= ($elt->{'att'}->{'xml:space'} || '') eq 'preserve';
8837 |  |  |  |  | $xml_space_preserve++ if $preserve;
8838 |  |  |  |  |
8839 |  |  |  |  | push @sprint, $elt->start_tag unless( $no_tag);
8840 |  |  |  |  |
8841 |  |  |  |  | # sprint the children
8842 |  |  |  |  | my $child= $elt->{first_child};
8843 |  |  |  |  | while( $child)
8844 |  |  |  |  | { $child->_sprint;
8845 |  |  |  |  | $child= $child->{next_sibling};
8846 |  |  |  |  | }
8847 |  |  |  |  | push @sprint, $elt->end_tag unless( $no_tag);
8848 |  |  |  |  | $xml_space_preserve-- if $preserve;
8849 |  |  |  |  | }
8850 |  |  |  |  | else
8851 |  |  |  |  | { push @sprint, $elt->{extra_data} if( $elt->{extra_data}) ;
8852 |  |  |  |  | if( (exists $elt->{'pcdata'})) { push @sprint, $elt->pcdata_xml_string; }
8853 |  |  |  |  | elsif( (exists $elt->{'cdata'})) { push @sprint, $elt->cdata_string; }
8854 |  |  |  |  | elsif( (exists $elt->{'target'})) { if( ($pretty >= $INDENTED) && !$elt->{parent}->{contains_text}) { push @sprint, "\n" . $INDENT x $elt->level; }
8855 |  |  |  |  | push @sprint, $elt->pi_string;
8856 |  |  |  |  | }
8857 |  |  |  |  | elsif( (exists $elt->{'comment'})) { if( ($pretty >= $INDENTED) && !$elt->{parent}->{contains_text}) { push @sprint, "\n" . $INDENT x $elt->level; }
8858 |  |  |  |  | push @sprint, $elt->comment_string;
8859 |  |  |  |  | }
8860 |  |  |  |  | elsif( (exists $elt->{'ent'})) { push @sprint, $elt->ent_string; }
8861 |  |  |  |  | }
8862 |  |  |  |  |
8863 |  |  |  |  | return;
8864 |  |  |  |  | }
8865 |  |  |  |  |
8866 |  |  |  |  | # just a shortcut to $elt->sprint( 1)
8867 |  |  |  |  | sub xml_string
8868 |  |  |  |  | { my $elt= shift;
8869 |  |  |  |  | isa( $_[0], 'HASH') ? $elt->sprint( shift(), 1) : $elt->sprint( 1);
8870 |  |  |  |  | }
8871 |  |  |  |  |
8872 |  |  |  |  | sub pcdata_xml_string
8873 |  |  |  |  | { my $elt= shift;
8874 |  |  |  |  | if( defined( my $string= $elt->{pcdata}) )
8875 |  |  |  |  | {
8876 |  |  |  |  | if( ! $elt->{extra_data_in_pcdata})
8877 |  |  |  |  | {
8878 |  |  |  |  | $string=~ s/([$replaced_ents])/$XML::Twig::base_ent{$1}/g unless( !$replaced_ents || $keep_encoding || $elt->{asis});
8879 |  |  |  |  | $string=~ s{\Q]]>}{]]&gt;}g;
8880 |  |  |  |  | }
8881 |  |  |  |  | else
8882 |  |  |  |  | { _gen_mark( $string); # used by _(un)?protect_extra_data
8883 |  |  |  |  | foreach my $data (reverse @{$elt->{extra_data_in_pcdata}})
8884 |  |  |  |  | { my $substr= substr( $string, $data->{offset});
8885 |  |  |  |  | if( $keep_encoding || $elt->{asis})
8886 |  |  |  |  | { substr( $string, $data->{offset}, 0, $data->{text}); }
8887 |  |  |  |  | else
8888 |  |  |  |  | { substr( $string, $data->{offset}, 0, _protect_extra_data( $data->{text})); }
8889 |  |  |  |  | }
8890 |  |  |  |  | unless( $keep_encoding || $elt->{asis})
8891 |  |  |  |  | {
8892 |  |  |  |  | $string=~ s{([$replaced_ents])}{$XML::Twig::base_ent{$1}}g ;
8893 |  |  |  |  | $string=~ s{\Q]]>}{]]&gt;}g;
8894 |  |  |  |  | _unprotect_extra_data( $string);
8895 |  |  |  |  | }
8896 |  |  |  |  | }
8897 |  |  |  |  | return $output_text_filter ? $output_text_filter->( $string) : $string;
8898 |  |  |  |  | }
8899 |  |  |  |  | else
8900 |  |  |  |  | { return ''; }
8901 |  |  |  |  | }
8902 |  |  |  |  |
8903 | 1 | 100ns |  |  | { my $mark;
8904 | 1 | 400ns |  |  | my( %char2ent, %ent2char);
8905 |  |  |  |  | BEGIN
8906 | 1 | 1µs |  |  | # spent 6µs within XML::Twig::Elt::BEGIN@8906 which was called: # once (6µs+0s) by Spreadsheet::ParseXLSX::BEGIN@15 at line 8908 { %char2ent= ( '<' => 'lt', '&' => 'amp', '>' => 'gt');
8907 | 1 | 8µs |  |  | %ent2char= map { $char2ent{$_} => $_ } keys %char2ent;
8908 | 1 | 957µs | 1 | 6µs | } # spent 6µs making 1 call to XML::Twig::Elt::BEGIN@8906
8909 |  |  |  |  |
8910 |  |  |  |  | # generate a unique mark (a string) not found in the string,
8911 |  |  |  |  | # used to mark < and & in the extra data
8912 |  |  |  |  | sub _gen_mark
8913 |  |  |  |  | { $mark="AAAA";
8914 |  |  |  |  | $mark++ while( index( $_[0], $mark) > -1);
8915 |  |  |  |  | return $mark;
8916 |  |  |  |  | }
8917 |  |  |  |  |
8918 |  |  |  |  | sub _protect_extra_data
8919 |  |  |  |  | { my( $extra_data)= @_;
8920 |  |  |  |  | $extra_data=~ s{([<&>])}{:$mark:$char2ent{$1}:}g;
8921 |  |  |  |  | return $extra_data;
8922 |  |  |  |  | }
8923 |  |  |  |  |
8924 |  |  |  |  | sub _unprotect_extra_data
8925 |  |  |  |  | { $_[0]=~ s{:$mark:(\w+):}{$ent2char{$1}}g; }
8926 |  |  |  |  |
8927 |  |  |  |  | }
8928 |  |  |  |  |
8929 |  |  |  |  | sub cdata_string
8930 | 1 | 6µs |  |  | { my $cdata= $_[0]->{cdata};
8931 |  |  |  |  | unless( defined $cdata) { return ''; }
8932 |  |  |  |  | if( $remove_cdata)
8933 |  |  |  |  | { $cdata=~ s/([$replaced_ents])/$XML::Twig::base_ent{$1}/g; }
8934 |  |  |  |  | else
8935 |  |  |  |  | { $cdata= $CDATA_START . $cdata . $CDATA_END; }
8936 |  |  |  |  | return $cdata;
8937 |  |  |  |  | }
8938 |  |  |  |  |
8939 |  |  |  |  | sub att_xml_string
8940 |  |  |  |  | { my $elt= shift;
8941 |  |  |  |  | my $att= shift;
8942 |  |  |  |  |
8943 |  |  |  |  | my $replace= $replaced_ents . "$quote\n\r\t";
8944 |  |  |  |  | if($_[0] && $_[0]->{escape_gt} && ($replace!~ m{>}) ) { $replace .='>'; }
8945 |  |  |  |  |
8946 |  |  |  |  | if( defined (my $string= $elt->{att}->{$att}))
8947 |  |  |  |  | { return _att_xml_string( $string, $replace); }
8948 |  |  |  |  | else
8949 |  |  |  |  | { return ''; }
8950 |  |  |  |  | }
8951 |  |  |  |  |
8952 |  |  |  |  | # escaped xml string for an attribute value
8953 |  |  |  |  | sub _att_xml_string
8954 |  |  |  |  | { my( $string, $escape)= @_;
8955 |  |  |  |  | if( !defined( $string)) { return ''; }
8956 |  |  |  |  | if( $keep_encoding)
8957 |  |  |  |  | { $string=~ s{$quote}{$XML::Twig::base_ent{$quote}}g;
8958 |  |  |  |  | }
8959 |  |  |  |  | else
8960 |  |  |  |  | {
8961 |  |  |  |  | if( $do_not_escape_amp_in_atts)
8962 |  |  |  |  | { $escape=~ s{^.}{}; # seems like the most backward compatible way to remove & from the list
8963 |  |  |  |  | $string=~ s{([$escape])}{$XML::Twig::base_ent{$1}}g;
8964 |  |  |  |  | $string=~ s{&(?!(\w+|#\d+|[xX][0-9a-fA-F]+);)}{&amp;}g; # dodgy: escape & that do not start an entity
8965 |  |  |  |  | }
8966 |  |  |  |  | else
8967 |  |  |  |  | { $string=~ s{([$escape])}{$XML::Twig::base_ent{$1}}g;
8968 |  |  |  |  | $string=~ s{\Q]]>}{]]&gt;}g;
8969 |  |  |  |  | }
8970 |  |  |  |  | }
8971 |  |  |  |  |
8972 |  |  |  |  | return $output_text_filter ? $output_text_filter->( $string) : $string;
8973 |  |  |  |  | }
8974 |  |  |  |  |
8975 |  |  |  |  | sub ent_string
8976 |  |  |  |  | { my $ent= shift;
8977 |  |  |  |  | my $ent_text= $ent->{ent};
8978 |  |  |  |  | my( $t, $el, $ent_string);
8979 |  |  |  |  | if( $expand_external_entities
8980 |  |  |  |  | && ($t= $ent->twig)
8981 |  |  |  |  | && ($el= $t->entity_list)
8982 |  |  |  |  | && ($ent_string= $el->{entities}->{$ent->ent_name}->{val})
8983 |  |  |  |  | )
8984 |  |  |  |  | { return $ent_string; }
8985 |  |  |  |  | else
8986 |  |  |  |  | { return $ent_text; }
8987 |  |  |  |  | }
8988 |  |  |  |  |
8989 |  |  |  |  | # returns just the text, no tags, for an element
8990 |  |  |  |  | sub text
8991 | 254582 | 30.4ms |  |  | # spent 678ms (678+0ns) within XML::Twig::Elt::text which was called 254582 times, avg 3µs/call: # 127291 times (145ms+-145ms) by XML::Twig::Elt::text at line 9008, avg 0s/call # 127276 times (533ms+145ms) by Spreadsheet::ParseXLSX::__ANON__[lib/Spreadsheet/ParseXLSX.pm:443] at line 380 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 5µs/call # 15 times (68µs+33µs) by Spreadsheet::ParseXLSX::_get_text_and_rich_font_by_cell at line 583 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm, avg 7µs/call { my( $elt, @options)= @_;
8992 |  |  |  |  |
8993 | 254582 | 22.8ms |  |  | if( @options && grep { lc( $_) eq 'no_recurse' } @options) { return $elt->text_only; }
8994 | 254582 | 30.6ms |  |  | my $sep = (@options && grep { lc( $_) eq 'sep' } @options) ? ' ' : '';
8995 |  |  |  |  |
8996 | 254582 | 17.4ms |  |  | my $string;
8997 |  |  |  |  |
8998 | 254582 | 309ms |  |  | if( (exists $elt->{'pcdata'})) { return $elt->{pcdata} . $sep; }
8999 |  |  |  |  | elsif( (exists $elt->{'cdata'})) { return $elt->{cdata} . $sep; }
9000 |  |  |  |  | elsif( (exists $elt->{'target'})) { return $elt->pi_string . $sep; }
9001 |  |  |  |  | elsif( (exists $elt->{'comment'})) { return $elt->{comment} . $sep; }
9002 |  |  |  |  | elsif( (exists $elt->{'ent'})) { return $elt->{ent} . $sep ; }
9003 |  |  |  |  |
9004 |  |  |  |  |
9005 | 127291 | 20.3ms |  |  | my $child= $elt->{first_child} ||'';
9006 | 127291 | 60.7ms |  |  | while( $child)
9007 |  |  |  |  | {
9008 | 127291 | 66.0ms | 127291 | 0s | my $child_text= $child->text( @options); # spent 145ms making 127291 calls to XML::Twig::Elt::text, avg 1µs/call, recursion: max depth 1, sum of overlapping time 145ms
9009 | 127291 | 50.6ms |  |  | $string.= defined( $child_text) ? $sep . $child_text : '';
9010 |  |  |  |  | } continue { $child= $child->{next_sibling}; }
9011 |  |  |  |  |
9012 | 127291 | 10.7ms |  |  | unless( defined $string) { $string=''; }
9013 |  |  |  |  |
9014 | 127291 | 211ms |  |  | return $output_text_filter ? $output_text_filter->( $string) : $string;
9015 |  |  |  |  | }
9016 |  |  |  |  |
9017 |  |  |  |  | sub text_only
9018 |  |  |  |  | { return join '', map { $_->text if( $_->is_text || (exists $_->{'ent'})) } $_[0]->_children; }
9019 |  |  |  |  |
9020 |  |  |  |  | sub trimmed_text
9021 |  |  |  |  | { my $elt= shift;
9022 |  |  |  |  | my $text= $elt->text( @_);
9023 |  |  |  |  | $text=~ s{\s+}{ }sg;
9024 |  |  |  |  | $text=~ s{^\s*}{};
9025 |  |  |  |  | $text=~ s{\s*$}{};
9026 |  |  |  |  | return $text;
9027 |  |  |  |  | }
9028 |  |  |  |  |
9029 |  |  |  |  | sub trim
9030 |  |  |  |  | { my( $elt)= @_;
9031 |  |  |  |  | my $pcdata= $elt->first_descendant( $TEXT);
9032 |  |  |  |  | (my $pcdata_text= $pcdata->text)=~ s{^\s+}{}s;
9033 |  |  |  |  | $pcdata->set_text( $pcdata_text);
9034 |  |  |  |  | $pcdata= $elt->last_descendant( $TEXT);
9035 |  |  |  |  | ($pcdata_text= $pcdata->text)=~ s{\s+$}{};
9036 |  |  |  |  | $pcdata->set_text( $pcdata_text);
9037 |  |  |  |  | foreach my $pcdata ($elt->descendants( $TEXT))
9038 |  |  |  |  | { ($pcdata_text= $pcdata->text)=~ s{\s+}{ }g;
9039 |  |  |  |  | $pcdata->set_text( $pcdata_text);
9040 |  |  |  |  | }
9041 |  |  |  |  | return $elt;
9042 |  |  |  |  | }
9043 |  |  |  |  |
9044 |  |  |  |  |
9045 |  |  |  |  | # remove cdata sections (turns them into regular pcdata) in an element
9046 |  |  |  |  | sub remove_cdata
9047 |  |  |  |  | { my $elt= shift;
9048 |  |  |  |  | foreach my $cdata ($elt->descendants_or_self( $CDATA))
9049 |  |  |  |  | { if( $keep_encoding)
9050 |  |  |  |  | { my $data= $cdata->{cdata};
9051 |  |  |  |  | $data=~ s{([&<"'])}{$XML::Twig::base_ent{$1}}g;
9052 |  |  |  |  | $cdata->{pcdata}= (delete $cdata->{empty} || 1) && $data;
9053 |  |  |  |  | }
9054 |  |  |  |  | else
9055 |  |  |  |  | { $cdata->{pcdata}= (delete $cdata->{empty} || 1) && $cdata->{cdata}; }
9056 |  |  |  |  | $cdata->{gi}=$XML::Twig::gi2index{$PCDATA} or $cdata->set_gi( $PCDATA);
9057 |  |  |  |  | undef $cdata->{cdata};
9058 |  |  |  |  | }
9059 |  |  |  |  | }
9060 |  |  |  |  |
9061 |  |  |  |  | sub _is_private { return _is_private_name( $_[0]->gi); }
9062 |  |  |  |  | sub _is_private_name { return $_[0]=~ m{^#(?!default:)}; }
9063 |  |  |  |  |
9064 |  |  |  |  |
9065 | 1 | 3.76ms | 1 | 16µs | } # end of block containing package globals ($pretty_print, $quotes, keep_encoding...) # spent 16µs making 1 call to XML::Twig::Elt::BEGIN@8119
9066 |  |  |  |  |
9067 |  |  |  |  | # merges consecutive #PCDATAs in am element
9068 |  |  |  |  | sub normalize
9069 |  |  |  |  | { my( $elt)= @_;
9070 |  |  |  |  | my @descendants= $elt->descendants( $PCDATA);
9071 |  |  |  |  | while( my $desc= shift @descendants)
9072 |  |  |  |  | { if( ! length $desc->{pcdata}) { $desc->delete; next; }
9073 |  |  |  |  | while( @descendants && $desc->{next_sibling} && $desc->{next_sibling}== $descendants[0])
9074 |  |  |  |  | { my $to_merge= shift @descendants;
9075 |  |  |  |  | $desc->merge_text( $to_merge);
9076 |  |  |  |  | }
9077 |  |  |  |  | }
9078 |  |  |  |  | return $elt;
9079 |  |  |  |  | }
9080 |  |  |  |  |
9081 |  |  |  |  | # SAX export methods
9082 |  |  |  |  | sub toSAX1
9083 |  |  |  |  | { _toSAX(@_, \&_start_tag_data_SAX1, \&_end_tag_data_SAX1); }
9084 |  |  |  |  |
9085 |  |  |  |  | sub toSAX2
9086 |  |  |  |  | { _toSAX(@_, \&_start_tag_data_SAX2, \&_end_tag_data_SAX2); }
9087 |  |  |  |  |
9088 |  |  |  |  | sub _toSAX
9089 |  |  |  |  | { my( $elt, $handler, $start_tag_data, $end_tag_data)= @_;
9090 |  |  |  |  | if( $elt->{gi} >= $XML::Twig::SPECIAL_GI)
9091 |  |  |  |  | { my $data= $start_tag_data->( $elt);
9092 |  |  |  |  | _start_prefix_mapping( $elt, $handler, $data);
9093 |  |  |  |  | if( $data && (my $start_element = $handler->can( 'start_element')))
9094 |  |  |  |  | { unless( $elt->{'flushed'}) { $start_element->( $handler, $data); } }
9095 |  |  |  |  |
9096 |  |  |  |  | foreach my $child ($elt->_children)
9097 |  |  |  |  | { $child->_toSAX( $handler, $start_tag_data, $end_tag_data); }
9098 |  |  |  |  |
9099 |  |  |  |  | if( (my $data= $end_tag_data->( $elt)) && (my $end_element = $handler->can( 'end_element')) )
9100 |  |  |  |  | { $end_element->( $handler, $data); }
9101 |  |  |  |  | _end_prefix_mapping( $elt, $handler);
9102 |  |  |  |  | }
9103 |  |  |  |  | else # text or special element
9104 |  |  |  |  | { if( (exists $elt->{'pcdata'}) && (my $characters= $handler->can( 'characters')))
9105 |  |  |  |  | { $characters->( $handler, { Data => $elt->{pcdata} }); }
9106 |  |  |  |  | elsif( (exists $elt->{'cdata'}))
9107 |  |  |  |  | { if( my $start_cdata= $handler->can( 'start_cdata'))
9108 |  |  |  |  | { $start_cdata->( $handler); }
9109 |  |  |  |  | if( my $characters= $handler->can( 'characters'))
9110 |  |  |  |  | { $characters->( $handler, {Data => $elt->{cdata} }); }
9111 |  |  |  |  | if( my $end_cdata= $handler->can( 'end_cdata'))
9112 |  |  |  |  | { $end_cdata->( $handler); }
9113 |  |  |  |  | }
9114 |  |  |  |  | elsif( ((exists $elt->{'target'})) && (my $pi= $handler->can( 'processing_instruction')))
9115 |  |  |  |  | { $pi->( $handler, { Target =>$elt->{target}, Data => $elt->{data} }); }
9116 |  |  |  |  | elsif( ((exists $elt->{'comment'})) && (my $comment= $handler->can( 'comment')))
9117 |  |  |  |  | { $comment->( $handler, { Data => $elt->{comment} }); }
9118 |  |  |  |  | elsif( ((exists $elt->{'ent'})))
9119 |  |  |  |  | {
9120 |  |  |  |  | if( my $se= $handler->can( 'skipped_entity'))
9121 |  |  |  |  | { $se->( $handler, { Name => $elt->ent_name }); }
9122 |  |  |  |  | elsif( my $characters= $handler->can( 'characters'))
9123 |  |  |  |  | { if( defined $elt->ent_string)
9124 |  |  |  |  | { $characters->( $handler, {Data => $elt->ent_string}); }
9125 |  |  |  |  | else
9126 |  |  |  |  | { $characters->( $handler, {Data => $elt->ent_name}); }
9127 |  |  |  |  | }
9128 |  |  |  |  | }
9129 |  |  |  |  |
9130 |  |  |  |  | }
9131 |  |  |  |  | }
9132 |  |  |  |  |
9133 |  |  |  |  | sub _start_tag_data_SAX1
9134 |  |  |  |  | { my( $elt)= @_;
9135 |  |  |  |  | my $name= $XML::Twig::index2gi[$elt->{'gi'}];
9136 |  |  |  |  | return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
9137 |  |  |  |  | my $attributes={};
9138 |  |  |  |  | my $atts= $elt->{att};
9139 |  |  |  |  | while( my( $att, $value)= each %$atts)
9140 |  |  |  |  | { $attributes->{$att}= $value unless( ( $att=~ m{^#(?!default:)} )); }
9141 |  |  |  |  | my $data= { Name => $name, Attributes => $attributes};
9142 |  |  |  |  | return $data;
9143 |  |  |  |  | }
9144 |  |  |  |  |
9145 |  |  |  |  | sub _end_tag_data_SAX1
9146 |  |  |  |  | { my( $elt)= @_;
9147 |  |  |  |  | return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
9148 |  |  |  |  | return { Name => $XML::Twig::index2gi[$elt->{'gi'}] };
9149 |  |  |  |  | }
9150 |  |  |  |  |
9151 |  |  |  |  | sub _start_tag_data_SAX2
9152 |  |  |  |  | { my( $elt)= @_;
9153 |  |  |  |  | my $data={};
9154 |  |  |  |  |
9155 |  |  |  |  | my $name= $XML::Twig::index2gi[$elt->{'gi'}];
9156 |  |  |  |  | return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
9157 |  |  |  |  | $data->{Name} = $name;
9158 |  |  |  |  | $data->{Prefix} = $elt->ns_prefix;
9159 |  |  |  |  | $data->{LocalName} = $elt->local_name;
9160 |  |  |  |  | $data->{NamespaceURI} = $elt->namespace;
9161 |  |  |  |  |
9162 |  |  |  |  | # save a copy of the data so we can re-use it for the end tag
9163 |  |  |  |  | my %sax2_data= %$data;
9164 |  |  |  |  | $elt->{twig_elt_SAX2_data}= \%sax2_data;
9165 |  |  |  |  |
9166 |  |  |  |  | # add the attributes
9167 |  |  |  |  | $data->{Attributes}= $elt->_atts_to_SAX2;
9168 |  |  |  |  |
9169 |  |  |  |  | return $data;
9170 |  |  |  |  | }
9171 |  |  |  |  |
9172 |  |  |  |  | sub _atts_to_SAX2
9173 |  |  |  |  | { my $elt= shift;
9174 |  |  |  |  | my $SAX2_atts= {};
9175 |  |  |  |  | foreach my $att (keys %{$elt->{att}})
9176 |  |  |  |  | {
9177 |  |  |  |  | next if( ( $att=~ m{^#(?!default:)} ));
9178 |  |  |  |  | my $SAX2_att={};
9179 |  |  |  |  | $SAX2_att->{Name} = $att;
9180 |  |  |  |  | $SAX2_att->{Prefix} = _ns_prefix( $att);
9181 |  |  |  |  | $SAX2_att->{LocalName} = _local_name( $att);
9182 |  |  |  |  | $SAX2_att->{NamespaceURI} = $elt->namespace( $SAX2_att->{Prefix});
9183 |  |  |  |  | $SAX2_att->{Value} = $elt->{'att'}->{$att};
9184 |  |  |  |  | my $SAX2_att_name= "{$SAX2_att->{NamespaceURI}}$SAX2_att->{LocalName}";
9185 |  |  |  |  |
9186 |  |  |  |  | $SAX2_atts->{$SAX2_att_name}= $SAX2_att;
9187 |  |  |  |  | }
9188 |  |  |  |  | return $SAX2_atts;
9189 |  |  |  |  | }
9190 |  |  |  |  |
9191 |  |  |  |  | sub _start_prefix_mapping
9192 |  |  |  |  | { my( $elt, $handler, $data)= @_;
9193 |  |  |  |  | if( my $start_prefix_mapping= $handler->can( 'start_prefix_mapping')
9194 |  |  |  |  | and my @new_prefix_mappings= grep { /^\{[^}]*\}xmlns/ || /^\{$XMLNS_URI\}/ } keys %{$data->{Attributes}}
9195 |  |  |  |  | )
9196 |  |  |  |  | { foreach my $prefix (@new_prefix_mappings)
9197 |  |  |  |  | { my $prefix_string= $data->{Attributes}->{$prefix}->{LocalName};
9198 |  |  |  |  | if( $prefix_string eq 'xmlns') { $prefix_string=''; }
9199 |  |  |  |  | my $prefix_data=
9200 |  |  |  |  | { Prefix => $prefix_string,
9201 |  |  |  |  | NamespaceURI => $data->{Attributes}->{$prefix}->{Value}
9202 |  |  |  |  | };
9203 |  |  |  |  | $start_prefix_mapping->( $handler, $prefix_data);
9204 |  |  |  |  | $elt->{twig_end_prefix_mapping} ||= [];
9205 |  |  |  |  | push @{$elt->{twig_end_prefix_mapping}}, $prefix_string;
9206 |  |  |  |  | }
9207 |  |  |  |  | }
9208 |  |  |  |  | }
9209 |  |  |  |  |
9210 |  |  |  |  | sub _end_prefix_mapping
9211 |  |  |  |  | { my( $elt, $handler)= @_;
9212 |  |  |  |  | if( my $end_prefix_mapping= $handler->can( 'end_prefix_mapping'))
9213 |  |  |  |  | { foreach my $prefix (@{$elt->{twig_end_prefix_mapping}})
9214 |  |  |  |  | { $end_prefix_mapping->( $handler, { Prefix => $prefix} ); }
9215 |  |  |  |  | }
9216 |  |  |  |  | }
9217 |  |  |  |  |
9218 |  |  |  |  | sub _end_tag_data_SAX2
9219 |  |  |  |  | { my( $elt)= @_;
9220 |  |  |  |  | return if( ( (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 1) eq '#') && (substr( $XML::Twig::index2gi[$elt->{'gi'}], 0, 9) ne '#default:') ));
9221 |  |  |  |  | return $elt->{twig_elt_SAX2_data};
9222 |  |  |  |  | }
9223 |  |  |  |  |
9224 |  |  |  |  | sub contains_text
9225 |  |  |  |  | { my $elt= shift;
9226 |  |  |  |  | my $child= $elt->{first_child};
9227 |  |  |  |  | while ($child)
9228 |  |  |  |  | { return 1 if( $child->is_text || (exists $child->{'ent'}));
9229 |  |  |  |  | $child= $child->{next_sibling};
9230 |  |  |  |  | }
9231 |  |  |  |  | return 0;
9232 |  |  |  |  | }
9233 |  |  |  |  |
9234 |  |  |  |  | # creates a single pcdata element containing the text as child of the element
9235 |  |  |  |  | # options:
9236 |  |  |  |  | # - force_pcdata: when set to a true value forces the text to be in a #PCDATA
9237 |  |  |  |  | # even if the original element was a #CDATA
9238 |  |  |  |  | sub set_text
9239 |  |  |  |  | { my( $elt, $string, %option)= @_;
9240 |  |  |  |  |
9241 |  |  |  |  | if( $XML::Twig::index2gi[$elt->{'gi'}] eq $PCDATA)
9242 |  |  |  |  | { return $elt->{pcdata}= (delete $elt->{empty} || 1) && $string; }
9243 |  |  |  |  | elsif( $XML::Twig::index2gi[$elt->{'gi'}] eq $CDATA)
9244 |  |  |  |  | { if( $option{force_pcdata})
9245 |  |  |  |  | { $elt->{gi}=$XML::Twig::gi2index{$PCDATA} or $elt->set_gi( $PCDATA);
9246 |  |  |  |  | $elt->{cdata}= '';
9247 |  |  |  |  | return $elt->{pcdata}= (delete $elt->{empty} || 1) && $string;
9248 |  |  |  |  | }
9249 |  |  |  |  | else
9250 |  |  |  |  | { $elt->{cdata}= $string;
9251 |  |  |  |  | return $string;
9252 |  |  |  |  | }
9253 |  |  |  |  | }
9254 |  |  |  |  | elsif( $elt->contains_a_single( $PCDATA) )
9255 |  |  |  |  | { # optimized so we have a slight chance of not losing embedded comments and pi's
9256 |  |  |  |  | $elt->{first_child}->set_pcdata( $string);
9257 |  |  |  |  | return $elt;
9258 |  |  |  |  | }
9259 |  |  |  |  |
9260 |  |  |  |  | foreach my $child (@{[$elt->_children]})
9261 |  |  |  |  | { $child->delete; }
9262 |  |  |  |  |
9263 |  |  |  |  | my $pcdata= $elt->_new_pcdata( $string);
9264 |  |  |  |  | $pcdata->paste( $elt);
9265 |  |  |  |  |
9266 |  |  |  |  | delete $elt->{empty};
9267 |  |  |  |  |
9268 |  |  |  |  | return $elt;
9269 |  |  |  |  | }
9270 |  |  |  |  |
9271 |  |  |  |  | # set the content of an element from a list of strings and elements
9272 |  |  |  |  | sub set_content
9273 |  |  |  |  | { my $elt= shift;
9274 |  |  |  |  |
9275 |  |  |  |  | return $elt unless defined $_[0];
9276 |  |  |  |  |
9277 |  |  |  |  | # attributes can be given as a hash (passed by ref)
9278 |  |  |  |  | if( ref $_[0] eq 'HASH')
9279 |  |  |  |  | { my $atts= shift;
9280 |  |  |  |  | $elt->del_atts; # usually useless but better safe than sorry
9281 |  |  |  |  | $elt->set_atts( $atts);
9282 |  |  |  |  | return $elt unless defined $_[0];
9283 |  |  |  |  | }
9284 |  |  |  |  |
9285 |  |  |  |  | # check next argument for #EMPTY
9286 |  |  |  |  | if( !(ref $_[0]) && ($_[0] eq $EMPTY) )
9287 |  |  |  |  | { $elt->{empty}= 1; return $elt; }
9288 |  |  |  |  |
9289 |  |  |  |  | # case where we really want to do a set_text, the element is '#PCDATA'
9290 |  |  |  |  | # or contains a single PCDATA and we only want to add text in it
9291 |  |  |  |  | if( ($XML::Twig::index2gi[$elt->{'gi'}] eq $PCDATA || $elt->contains_a_single( $PCDATA))
9292 |  |  |  |  | && (@_ == 1) && !( ref $_[0]))
9293 |  |  |  |  | { $elt->set_text( $_[0]);
9294 |  |  |  |  | return $elt;
9295 |  |  |  |  | }
9296 |  |  |  |  | elsif( ($XML::Twig::index2gi[$elt->{'gi'}] eq $CDATA) && (@_ == 1) && !( ref $_[0]))
9297 |  |  |  |  | { $elt->{cdata}= $_[0];
9298 |  |  |  |  | return $elt;
9299 |  |  |  |  | }
9300 |  |  |  |  |
9301 |  |  |  |  | # delete the children
9302 |  |  |  |  | foreach my $child (@{[$elt->_children]})
9303 |  |  |  |  | { $child->delete; }
9304 |  |  |  |  |
9305 |  |  |  |  | if( @_) { delete $elt->{empty}; }
9306 |  |  |  |  |
9307 |  |  |  |  | foreach my $child (@_)
9308 |  |  |  |  | { if( ref( $child) && isa( $child, 'XML::Twig::Elt'))
9309 |  |  |  |  | { # argument is an element
9310 |  |  |  |  | $child->paste( 'last_child', $elt);
9311 |  |  |  |  | }
9312 |  |  |  |  | else
9313 |  |  |  |  | { # argument is a string
9314 |  |  |  |  | if( (my $pcdata= $elt->{last_child}) && $elt->{last_child}->is_pcdata)
9315 |  |  |  |  | { # previous child is also pcdata: just concatenate
9316 |  |  |  |  | $pcdata->{pcdata}= (delete $pcdata->{empty} || 1) && $pcdata->{pcdata} . $child
9317 |  |  |  |  | }
9318 |  |  |  |  | else
9319 |  |  |  |  | { # previous child is not a string: create a new pcdata element
9320 |  |  |  |  | $pcdata= $elt->_new_pcdata( $child);
9321 |  |  |  |  | $pcdata->paste( 'last_child', $elt);
9322 |  |  |  |  | }
9323 |  |  |  |  | }
9324 |  |  |  |  | }
9325 |  |  |  |  |
9326 |  |  |  |  |
9327 |  |  |  |  | return $elt;
9328 |  |  |  |  | }
9329 |  |  |  |  |
9330 |  |  |  |  | # inserts an element (whose gi is given) as child of the element
9331 |  |  |  |  | # all children of the element are now children of the new element
9332 |  |  |  |  | # returns the new element
9333 |  |  |  |  | sub insert
9334 |  |  |  |  | { my ($elt, @args)= @_;
9335 |  |  |  |  | # first cut the children
9336 |  |  |  |  | my @children= do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; };
9337 |  |  |  |  | foreach my $child (@children)
9338 |  |  |  |  | { $child->cut; }
9339 |  |  |  |  | # insert elements
9340 |  |  |  |  | while( my $gi= shift @args)
9341 |  |  |  |  | { my $new_elt= $elt->new( $gi);
9342 |  |  |  |  | # add attributes if needed
9343 |  |  |  |  | if( defined( $args[0]) && ( isa( $args[0], 'HASH')) )
9344 |  |  |  |  | { $new_elt->set_atts( shift @args); }
9345 |  |  |  |  | # paste the element
9346 |  |  |  |  | $new_elt->paste( $elt);
9347 |  |  |  |  | delete $elt->{empty};
9348 |  |  |  |  | $elt= $new_elt;
9349 |  |  |  |  | }
9350 |  |  |  |  | # paste back the children
9351 |  |  |  |  | foreach my $child (@children)
9352 |  |  |  |  | { $child->paste( 'last_child', $elt); }
9353 |  |  |  |  | return $elt;
9354 |  |  |  |  | }
9355 |  |  |  |  |
9356 |  |  |  |  | # insert a new element
9357 |  |  |  |  | # $elt->insert_new_element( $opt_position, $gi, $opt_atts_hash, @opt_content);
9358 |  |  |  |  | # the element is created with the same syntax as new
9359 |  |  |  |  | # position is the same as in paste, first_child by default
9360 |  |  |  |  | sub insert_new_elt
9361 |  |  |  |  | { my $elt= shift;
9362 |  |  |  |  | my $position= $_[0];
9363 |  |  |  |  | if( ($position eq 'before') || ($position eq 'after')
9364 |  |  |  |  | || ($position eq 'first_child') || ($position eq 'last_child'))
9365 |  |  |  |  | { shift; }
9366 |  |  |  |  | else
9367 |  |  |  |  | { $position= 'first_child'; }
9368 |  |  |  |  |
9369 |  |  |  |  | my $new_elt= $elt->new( @_);
9370 |  |  |  |  | $new_elt->paste( $position, $elt);
9371 |  |  |  |  |
9372 |  |  |  |  | #if( defined $new_elt->{'att'}->{$ID}) { $new_elt->set_id( $new_elt->{'att'}->{$ID}); }
9373 |  |  |  |  |
9374 |  |  |  |  | return $new_elt;
9375 |  |  |  |  | }
9376 |  |  |  |  |
9377 |  |  |  |  | # wraps an element in elements which gi's are given as arguments
9378 |  |  |  |  | # $elt->wrap_in( 'td', 'tr', 'table') wraps the element as a single
9379 |  |  |  |  | # cell in a table for example
9380 |  |  |  |  | # returns the new element
9381 |  |  |  |  | sub wrap_in
9382 |  |  |  |  | { my $elt= shift;
9383 |  |  |  |  | while( my $gi = shift @_)
9384 |  |  |  |  | { my $new_elt = $elt->new( $gi);
9385 |  |  |  |  | if( $elt->{twig_current})
9386 |  |  |  |  | { my $t= $elt->twig;
9387 |  |  |  |  | $t->{twig_current}= $new_elt;
9388 |  |  |  |  | delete $elt->{'twig_current'};
9389 |  |  |  |  | $new_elt->{'twig_current'}=1;
9390 |  |  |  |  | }
9391 |  |  |  |  |
9392 |  |  |  |  | if( my $parent= $elt->{parent})
9393 |  |  |  |  | { $new_elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $new_elt->{parent});} ;
9394 |  |  |  |  | if( $parent->{first_child} == $elt) { $parent->{first_child}= $new_elt; }
9395 |  |  |  |  | if( $parent->{last_child} == $elt) { delete $parent->{empty}; $parent->{last_child}=$new_elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; }
9396 |  |  |  |  | }
9397 |  |  |  |  | else
9398 |  |  |  |  | { # wrapping the root
9399 |  |  |  |  | my $twig= $elt->twig;
9400 |  |  |  |  | if( $twig && $twig->root && ($twig->root eq $elt) )
9401 |  |  |  |  | { $twig->set_root( $new_elt);
9402 |  |  |  |  | }
9403 |  |  |  |  | }
9404 |  |  |  |  |
9405 |  |  |  |  | if( my $prev_sibling= $elt->{prev_sibling})
9406 |  |  |  |  | { $new_elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $new_elt->{prev_sibling});} ;
9407 |  |  |  |  | $prev_sibling->{next_sibling}= $new_elt;
9408 |  |  |  |  | }
9409 |  |  |  |  |
9410 |  |  |  |  | if( my $next_sibling= $elt->{next_sibling})
9411 |  |  |  |  | { $new_elt->{next_sibling}= $next_sibling;
9412 |  |  |  |  | $next_sibling->{prev_sibling}=$new_elt; if( $XML::Twig::weakrefs) { weaken( $next_sibling->{prev_sibling});} ;
9413 |  |  |  |  | }
9414 |  |  |  |  | $new_elt->{first_child}= $elt;
9415 |  |  |  |  | delete $new_elt->{empty}; $new_elt->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $new_elt->{last_child});} ;
9416 |  |  |  |  |
9417 |  |  |  |  | $elt->{parent}=$new_elt; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ;
9418 |  |  |  |  | $elt->{prev_sibling}=undef; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
9419 |  |  |  |  | $elt->{next_sibling}= undef;
9420 |  |  |  |  |
9421 |  |  |  |  | # add the attributes if the next argument is a hash ref
9422 |  |  |  |  | if( defined( $_[0]) && (isa( $_[0], 'HASH')) )
9423 |  |  |  |  | { $new_elt->set_atts( shift @_); }
9424 |  |  |  |  |
9425 |  |  |  |  | $elt= $new_elt;
9426 |  |  |  |  | }
9427 |  |  |  |  |
9428 |  |  |  |  | return $elt;
9429 |  |  |  |  | }
9430 |  |  |  |  |
9431 |  |  |  |  | sub replace
9432 |  |  |  |  | { my( $elt, $ref)= @_;
9433 |  |  |  |  |
9434 |  |  |  |  | if( $elt->{parent}) { $elt->cut; }
9435 |  |  |  |  |
9436 |  |  |  |  | if( my $parent= $ref->{parent})
9437 |  |  |  |  | { $elt->{parent}=$parent; if( $XML::Twig::weakrefs) { weaken( $elt->{parent});} ;
9438 |  |  |  |  | if( $parent->{first_child} == $ref) { $parent->{first_child}= $elt; }
9439 |  |  |  |  | if( $parent->{last_child} == $ref) { delete $parent->{empty}; $parent->{last_child}=$elt; if( $XML::Twig::weakrefs) { weaken( $parent->{last_child});} ; }
9440 |  |  |  |  | }
9441 |  |  |  |  | elsif( $ref->twig && $ref == $ref->twig->root)
9442 |  |  |  |  | { $ref->twig->set_root( $elt); }
9443 |  |  |  |  |
9444 |  |  |  |  | if( my $prev_sibling= $ref->{prev_sibling})
9445 |  |  |  |  | { $elt->{prev_sibling}=$prev_sibling; if( $XML::Twig::weakrefs) { weaken( $elt->{prev_sibling});} ;
9446 |  |  |  |  | $prev_sibling->{next_sibling}= $elt;
9447 |  |  |  |  | }
9448 |  |  |  |  | if( my $next_sibling= $ref->{next_sibling})
9449 |  |  |  |  | { $elt->{next_sibling}= $next_sibling;
9450 |  |  |  |  | $next_sibling->{prev_sibling}=$elt; if( $XML::Twig::weakrefs) { weaken( $next_sibling->{prev_sibling});} ;
9451 |  |  |  |  | }
9452 |  |  |  |  |
9453 |  |  |  |  | $ref->{parent}=undef; if( $XML::Twig::weakrefs) { weaken( $ref->{parent});} ;
9454 |  |  |  |  | $ref->{prev_sibling}=undef; if( $XML::Twig::weakrefs) { weaken( $ref->{prev_sibling});} ;
9455 |  |  |  |  | $ref->{next_sibling}= undef;
9456 |  |  |  |  | return $ref;
9457 |  |  |  |  | }
9458 |  |  |  |  |
9459 |  |  |  |  | sub replace_with
9460 |  |  |  |  | { my $ref= shift;
9461 |  |  |  |  | my $elt= shift;
9462 |  |  |  |  | $elt->replace( $ref);
9463 |  |  |  |  | foreach my $new_elt (reverse @_)
9464 |  |  |  |  | { $new_elt->paste( after => $elt); }
9465 |  |  |  |  | return $elt;
9466 |  |  |  |  | }
9467 |  |  |  |  |
9468 |  |  |  |  |
9469 |  |  |  |  | # move an element, same syntax as paste, except the element is first cut
9470 |  |  |  |  | sub move
9471 |  |  |  |  | { my $elt= shift;
9472 |  |  |  |  | $elt->cut;
9473 |  |  |  |  | $elt->paste( @_);
9474 |  |  |  |  | return $elt;
9475 |  |  |  |  | }
9476 |  |  |  |  |
9477 |  |  |  |  |
9478 |  |  |  |  | # adds a prefix to an element, creating a pcdata child if needed
9479 |  |  |  |  | sub prefix
9480 |  |  |  |  | { my ($elt, $prefix, $option)= @_;
9481 |  |  |  |  | my $asis= ($option && ($option eq 'asis')) ? 1 : 0;
9482 |  |  |  |  | if( (exists $elt->{'pcdata'})
9483 |  |  |  |  | && (($asis && $elt->{asis}) || (!$asis && ! $elt->{asis}))
9484 |  |  |  |  | )
9485 |  |  |  |  | { $elt->{pcdata}= (delete $elt->{empty} || 1) && $prefix . $elt->{pcdata}; }
9486 |  |  |  |  | elsif( $elt->{first_child} && $elt->{first_child}->is_pcdata
9487 |  |  |  |  | && ( ($asis && $elt->{first_child}->{asis})
9488 |  |  |  |  | || (!$asis && ! $elt->{first_child}->{asis}))
9489 |  |  |  |  | )
9490 |  |  |  |  | {
9491 |  |  |  |  | $elt->{first_child}->set_pcdata( $prefix . $elt->{first_child}->pcdata);
9492 |  |  |  |  | }
9493 |  |  |  |  | else
9494 |  |  |  |  | { my $new_elt= $elt->_new_pcdata( $prefix);
9495 |  |  |  |  | my $pos= (exists $elt->{'pcdata'}) ? 'before' : 'first_child';
9496 |  |  |  |  | $new_elt->paste( $pos => $elt);
9497 |  |  |  |  | if( $asis) { $new_elt->set_asis; }
9498 |  |  |  |  | }
9499 |  |  |  |  | return $elt;
9500 |  |  |  |  | }
9501 |  |  |  |  |
9502 |  |  |  |  | # adds a suffix to an element, creating a pcdata child if needed
9503 |  |  |  |  | sub suffix
9504 |  |  |  |  | { my ($elt, $suffix, $option)= @_;
9505 |  |  |  |  | my $asis= ($option && ($option eq 'asis')) ? 1 : 0;
9506 |  |  |  |  | if( (exists $elt->{'pcdata'})
9507 |  |  |  |  | && (($asis && $elt->{asis}) || (!$asis && ! $elt->{asis}))
9508 |  |  |  |  | )
9509 |  |  |  |  | { $elt->{pcdata}= (delete $elt->{empty} || 1) && $elt->{pcdata} . $suffix; }
9510 |  |  |  |  | elsif( $elt->{last_child} && $elt->{last_child}->is_pcdata
9511 |  |  |  |  | && ( ($asis && $elt->{last_child}->{asis})
9512 |  |  |  |  | || (!$asis && ! $elt->{last_child}->{asis}))
9513 |  |  |  |  | )
9514 |  |  |  |  | { $elt->{last_child}->set_pcdata( $elt->{last_child}->pcdata . $suffix); }
9515 |  |  |  |  | else
9516 |  |  |  |  | { my $new_elt= $elt->_new_pcdata( $suffix);
9517 |  |  |  |  | my $pos= (exists $elt->{'pcdata'}) ? 'after' : 'last_child';
9518 |  |  |  |  | $new_elt->paste( $pos => $elt);
9519 |  |  |  |  | if( $asis) { $new_elt->set_asis; }
9520 |  |  |  |  | }
9521 |  |  |  |  | return $elt;
9522 |  |  |  |  | }
9523 |  |  |  |  |
9524 |  |  |  |  | # create a path to an element ('/root/.../gi)
9525 |  |  |  |  | sub path
9526 |  |  |  |  | { my $elt= shift;
9527 |  |  |  |  | my @context= ( $elt, $elt->ancestors);
9528 |  |  |  |  | return "/" . join( "/", reverse map {$_->gi} @context);
9529 |  |  |  |  | }
9530 |  |  |  |  |
9531 |  |  |  |  | sub xpath
9532 |  |  |  |  | { my $elt= shift;
9533 |  |  |  |  | my $xpath;
9534 |  |  |  |  | foreach my $ancestor (reverse $elt->ancestors_or_self)
9535 |  |  |  |  | { my $gi= $XML::Twig::index2gi[$ancestor->{'gi'}];
9536 |  |  |  |  | $xpath.= "/$gi";
9537 |  |  |  |  | my $index= $ancestor->prev_siblings( $gi) + 1;
9538 |  |  |  |  | unless( ($index == 1) && !$ancestor->next_sibling( $gi))
9539 |  |  |  |  | { $xpath.= "[$index]"; }
9540 |  |  |  |  | }
9541 |  |  |  |  | return $xpath;
9542 |  |  |  |  | }
9543 |  |  |  |  |
9544 |  |  |  |  | # methods used mainly by wrap_children
9545 |  |  |  |  |
9546 |  |  |  |  | # return a string with the
9547 |  |  |  |  | # for an element <foo><elt att="val">...</elt><elt2/><elt>...</elt></foo>
9548 |  |  |  |  | # returns '<elt att="val"><elt2><elt>'
9549 |  |  |  |  | sub _stringify_struct
9550 |  |  |  |  | { my( $elt, %opt)= @_;
9551 |  |  |  |  | my $string='';
9552 |  |  |  |  | my $pretty_print= set_pretty_print( 'none');
9553 |  |  |  |  | foreach my $child ($elt->_children)
9554 |  |  |  |  | { $child->add_id; $string .= $child->start_tag( { escape_gt => 1 }) ||''; }
9555 |  |  |  |  | set_pretty_print( $pretty_print);
9556 |  |  |  |  | return $string;
9557 |  |  |  |  | }
9558 |  |  |  |  |
9559 |  |  |  |  | # wrap a series of elements in a new one
9560 |  |  |  |  | sub _wrap_range
9561 |  |  |  |  | { my $elt= shift;
9562 |  |  |  |  | my $gi= shift;
9563 |  |  |  |  | my $atts= isa( $_[0], 'HASH') ? shift : undef;
9564 |  |  |  |  | my $range= shift; # the string with the tags to wrap
9565 |  |  |  |  |
9566 |  |  |  |  | my $t= $elt->twig;
9567 |  |  |  |  |
9568 |  |  |  |  | # get the tags to wrap
9569 |  |  |  |  | my @to_wrap;
9570 |  |  |  |  | while( $range=~ m{<\w+\s+[^>]*id=("[^"]*"|'[^']*')[^>]*>}g)
9571 |  |  |  |  | { push @to_wrap, $t->elt_id( substr( $1, 1, -1)); }
9572 |  |  |  |  |
9573 |  |  |  |  | return '' unless @to_wrap;
9574 |  |  |  |  |
9575 |  |  |  |  | my $to_wrap= shift @to_wrap;
9576 |  |  |  |  | my %atts= %$atts;
9577 |  |  |  |  | my $new_elt= $to_wrap->wrap_in( $gi, \%atts);
9578 |  |  |  |  | $_->move( last_child => $new_elt) foreach (@to_wrap);
9579 |  |  |  |  |
9580 |  |  |  |  | return '';
9581 |  |  |  |  | }
9582 |  |  |  |  |
9583 |  |  |  |  | # wrap children matching a regexp in a new element
9584 |  |  |  |  | sub wrap_children
9585 |  |  |  |  | { my( $elt, $regexp, $gi, $atts)= @_;
9586 |  |  |  |  |
9587 |  |  |  |  | $atts ||={};
9588 |  |  |  |  |
9589 |  |  |  |  | my $elt_as_string= $elt->_stringify_struct; # stringify the elt structure
9590 |  |  |  |  | $regexp=~ s{(<[^>]*>)}{_match_expr( $1)}eg; # in the regexp, replace gi's by the proper regexp
9591 |  |  |  |  | $elt_as_string=~ s{($regexp)}{$elt->_wrap_range( $gi, $atts, $1)}eg; # then do the actual replace
9592 |  |  |  |  |
9593 |  |  |  |  | return $elt;
9594 |  |  |  |  | }
9595 |  |  |  |  |
9596 |  |  |  |  | sub _match_expr
9597 |  |  |  |  | { my $tag= shift;
9598 |  |  |  |  | my( $gi, %atts)= XML::Twig::_parse_start_tag( $tag);
9599 |  |  |  |  | return _match_tag( $gi, %atts);
9600 |  |  |  |  | }
9601 |  |  |  |  |
9602 |  |  |  |  |
9603 |  |  |  |  | sub _match_tag
9604 |  |  |  |  | { my( $elt, %atts)= @_;
9605 |  |  |  |  | my $string= "<$elt\\b";
9606 |  |  |  |  | foreach my $key (sort keys %atts)
9607 |  |  |  |  | { my $val= qq{\Q$atts{$key}\E};
9608 |  |  |  |  | $string.= qq{[^>]*$key=(?:"$val"|'$val')};
9609 |  |  |  |  | }
9610 |  |  |  |  | $string.= qq{[^>]*>};
9611 |  |  |  |  | return "(?:$string)";
9612 |  |  |  |  | }
9613 |  |  |  |  |
9614 |  |  |  |  | sub field_to_att
9615 |  |  |  |  | { my( $elt, $cond, $att)= @_;
9616 |  |  |  |  | $att ||= $cond;
9617 |  |  |  |  | my $child= $elt->first_child( $cond) or return undef;
9618 |  |  |  |  | $elt->set_att( $att => $child->text);
9619 |  |  |  |  | $child->cut;
9620 |  |  |  |  | return $elt;
9621 |  |  |  |  | }
9622 |  |  |  |  |
9623 |  |  |  |  | sub att_to_field
9624 |  |  |  |  | { my( $elt, $att, $tag)= @_;
9625 |  |  |  |  | $tag ||= $att;
9626 |  |  |  |  | my $child= $elt->insert_new_elt( first_child => $tag, $elt->{'att'}->{$att});
9627 |  |  |  |  | $elt->del_att( $att);
9628 |  |  |  |  | return $elt;
9629 |  |  |  |  | }
9630 |  |  |  |  |
9631 |  |  |  |  | # sort children methods
9632 |  |  |  |  |
9633 |  |  |  |  | sub sort_children_on_field
9634 |  |  |  |  | { my $elt = shift;
9635 |  |  |  |  | my $field = shift;
9636 |  |  |  |  | my $get_key= sub { return $_[0]->field( $field) };
9637 |  |  |  |  | return $elt->sort_children( $get_key, @_);
9638 |  |  |  |  | }
9639 |  |  |  |  |
9640 |  |  |  |  | sub sort_children_on_att
9641 |  |  |  |  | { my $elt = shift;
9642 |  |  |  |  | my $att = shift;
9643 |  |  |  |  | my $get_key= sub { return $_[0]->{'att'}->{$att} };
9644 |  |  |  |  | return $elt->sort_children( $get_key, @_);
9645 |  |  |  |  | }
9646 |  |  |  |  |
9647 |  |  |  |  | sub sort_children_on_value
9648 |  |  |  |  | { my $elt = shift;
9649 |  |  |  |  | #my $get_key= eval qq{ sub { $NO_WARNINGS; return \$_[0]->text } };
9650 |  |  |  |  | my $get_key= \&text;
9651 |  |  |  |  | return $elt->sort_children( $get_key, @_);
9652 |  |  |  |  | }
9653 |  |  |  |  |
9654 |  |  |  |  | sub sort_children
9655 |  |  |  |  | { my( $elt, $get_key, %opt)=@_;
9656 |  |  |  |  | $opt{order} ||= 'normal';
9657 |  |  |  |  | $opt{type} ||= 'alpha';
9658 |  |  |  |  | my( $par_a, $par_b)= ($opt{order} eq 'reverse') ? qw( b a) : qw ( a b) ;
9659 |  |  |  |  | my $op= ($opt{type} eq 'numeric') ? '<=>' : 'cmp' ;
9660 |  |  |  |  | my @children= $elt->cut_children;
9661 |  |  |  |  | if( $opt{type} eq 'numeric')
9662 |  |  |  |  | { @children= map { $_->[1] }
9663 |  |  |  |  | sort { $a->[0] <=> $b->[0] }
9664 |  |  |  |  | map { [ $get_key->( $_), $_] } @children;
9665 |  |  |  |  | }
9666 |  |  |  |  | elsif( $opt{type} eq 'alpha')
9667 |  |  |  |  | { @children= map { $_->[1] }
9668 |  |  |  |  | sort { $a->[0] cmp $b->[0] }
9669 |  |  |  |  | map { [ $get_key->( $_), $_] } @children;
9670 |  |  |  |  | }
9671 |  |  |  |  | else
9672 |  |  |  |  | { croak "wrong sort type '$opt{type}', should be either 'alpha' or 'numeric'"; }
9673 |  |  |  |  |
9674 |  |  |  |  | @children= reverse @children if( $opt{order} eq 'reverse');
9675 |  |  |  |  | $elt->set_content( @children);
9676 |  |  |  |  | }
9677 |  |  |  |  |
9678 |  |  |  |  |
9679 |  |  |  |  | # comparison methods
9680 |  |  |  |  |
9681 |  |  |  |  | sub before
9682 |  |  |  |  | { my( $a, $b)=@_;
9683 |  |  |  |  | if( $a->cmp( $b) == -1) { return 1; } else { return 0; }
9684 |  |  |  |  | }
9685 |  |  |  |  |
9686 |  |  |  |  | sub after
9687 |  |  |  |  | { my( $a, $b)=@_;
9688 |  |  |  |  | if( $a->cmp( $b) == 1) { return 1; } else { return 0; }
9689 |  |  |  |  | }
9690 |  |  |  |  |
9691 |  |  |  |  | sub lt
9692 |  |  |  |  | { my( $a, $b)=@_;
9693 |  |  |  |  | return 1 if( $a->cmp( $b) == -1);
9694 |  |  |  |  | return 0;
9695 |  |  |  |  | }
9696 |  |  |  |  |
9697 |  |  |  |  | sub le
9698 |  |  |  |  | { my( $a, $b)=@_;
9699 |  |  |  |  | return 1 unless( $a->cmp( $b) == 1);
9700 |  |  |  |  | return 0;
9701 |  |  |  |  | }
9702 |  |  |  |  |
9703 |  |  |  |  | sub gt
9704 |  |  |  |  | { my( $a, $b)=@_;
9705 |  |  |  |  | return 1 if( $a->cmp( $b) == 1);
9706 |  |  |  |  | return 0;
9707 |  |  |  |  | }
9708 |  |  |  |  |
9709 |  |  |  |  | sub ge
9710 |  |  |  |  | { my( $a, $b)=@_;
9711 |  |  |  |  | return 1 unless( $a->cmp( $b) == -1);
9712 |  |  |  |  | return 0;
9713 |  |  |  |  | }
9714 |  |  |  |  |
9715 |  |  |  |  |
9716 |  |  |  |  | sub cmp
9717 | 77 | 10µs |  |  | # spent 1.42ms (479µs+937µs) within XML::Twig::Elt::cmp which was called 77 times, avg 18µs/call: # 77 times (479µs+937µs) by CORE::sort at line 3696, avg 18µs/call { my( $a, $b)=@_;
9718 |  |  |  |  |
9719 |  |  |  |  | # easy cases
9720 | 77 | 10µs |  |  | return 0 if( $a == $b);
9721 | 77 | 28µs | 77 | 161µs | return 1 if( $a->in($b)); # a in b => a starts after b # spent 161µs making 77 calls to XML::Twig::Elt::in, avg 2µs/call
9722 | 77 | 25µs | 77 | 127µs | return -1 if( $b->in($a)); # b in a => a starts before b # spent 127µs making 77 calls to XML::Twig::Elt::in, avg 2µs/call
9723 |  |  |  |  |
9724 |  |  |  |  | # ancestors does not include the element itself
9725 | 77 | 34µs | 77 | 325µs | my @a_pile= ($a, $a->ancestors); # spent 325µs making 77 calls to XML::Twig::Elt::ancestors, avg 4µs/call
9726 | 77 | 29µs | 77 | 324µs | my @b_pile= ($b, $b->ancestors); # spent 324µs making 77 calls to XML::Twig::Elt::ancestors, avg 4µs/call
9727 |  |  |  |  |
9728 |  |  |  |  | # the 2 elements are not in the same twig
9729 | 77 | 12µs |  |  | return undef unless( $a_pile[-1] == $b_pile[-1]);
9730 |  |  |  |  |
9731 |  |  |  |  | # find the first non common ancestors (they are siblings)
9732 | 77 | 8µs |  |  | my $a_anc= pop @a_pile;
9733 | 77 | 6µs |  |  | my $b_anc= pop @b_pile;
9734 |  |  |  |  |
9735 | 77 | 16µs |  |  | while( $a_anc == $b_anc)
9736 | 178 | 15µs |  |  | { $a_anc= pop @a_pile;
9737 | 178 | 34µs |  |  | $b_anc= pop @b_pile;
9738 |  |  |  |  | }
9739 |  |  |  |  |
9740 |  |  |  |  | # from there move left and right and figure out the order
9741 | 77 | 13µs |  |  | my( $a_prev, $a_next, $b_prev, $b_next)= ($a_anc, $a_anc, $b_anc, $b_anc);
9742 | 77 | 4µs |  |  | while()
9743 | 97 | 25µs |  |  | { $a_prev= $a_prev->{prev_sibling} || return( -1);
9744 | 83 | 33µs |  |  | return 1 if( $a_prev == $b_next);
9745 | 57 | 6µs |  |  | $a_next= $a_next->{next_sibling} || return( 1);
9746 | 57 | 20µs |  |  | return -1 if( $a_next == $b_prev);
9747 | 42 | 19µs |  |  | $b_prev= $b_prev->{prev_sibling} || return( 1);
9748 | 38 | 11µs |  |  | return -1 if( $b_prev == $a_next);
9749 | 31 | 3µs |  |  | $b_next= $b_next->{next_sibling} || return( -1);
9750 | 31 | 14µs |  |  | return 1 if( $b_next == $a_prev);
9751 |  |  |  |  | }
9752 |  |  |  |  | }
9753 |  |  |  |  |
9754 |  |  |  |  | sub _dump
9755 |  |  |  |  | { my( $elt, $option)= @_;
9756 |  |  |  |  |
9757 |  |  |  |  | my $atts = defined $option->{atts} ? $option->{atts} : 1;
9758 |  |  |  |  | my $extra = defined $option->{extra} ? $option->{extra} : 0;
9759 |  |  |  |  | my $short_text = defined $option->{short_text} ? $option->{short_text} : 40;
9760 |  |  |  |  |
9761 |  |  |  |  | my $sp= '| ';
9762 |  |  |  |  | my $indent= $sp x $elt->level;
9763 |  |  |  |  | my $indent_sp= ' ' x $elt->level;
9764 |  |  |  |  |
9765 |  |  |  |  | my $dump='';
9766 |  |  |  |  | if( $elt->is_elt)
9767 |  |  |  |  | {
9768 |  |  |  |  | $dump .= $indent . '|-' . $XML::Twig::index2gi[$elt->{'gi'}];
9769 |  |  |  |  |
9770 |  |  |  |  | if( $atts && (my @atts= $elt->att_names) )
9771 |  |  |  |  | { $dump .= ' ' . join( ' ', map { qq{$_="} . $elt->{'att'}->{$_} . qq{"} } @atts); }
9772 |  |  |  |  |
9773 |  |  |  |  | $dump .= "\n";
9774 |  |  |  |  | if( $extra) { $dump .= $elt->_dump_extra_data( $indent, $indent_sp, $short_text); }
9775 |  |  |  |  | $dump .= join( "", map { $_->_dump( $option) } do { my $elt= $elt; my @children=(); my $child= $elt->{first_child}; while( $child) { push @children, $child; $child= $child->{next_sibling}; } @children; });
9776 |  |  |  |  | }
9777 |  |  |  |  | else
9778 |  |  |  |  | {
9779 |  |  |  |  | if( (exists $elt->{'pcdata'}))
9780 |  |  |  |  | { $dump .= "$indent|-PCDATA: '" . _short_text( $elt->{pcdata}, $short_text) . "'\n" }
9781 |  |  |  |  | elsif( (exists $elt->{'ent'}))
9782 |  |  |  |  | { $dump .= "$indent|-ENTITY: '" . _short_text( $elt->{ent}, $short_text) . "'\n" }
9783 |  |  |  |  | elsif( (exists $elt->{'cdata'}))
9784 |  |  |  |  | { $dump .= "$indent|-CDATA: '" . _short_text( $elt->{cdata}, $short_text) . "'\n" }
9785 |  |  |  |  | elsif( (exists $elt->{'comment'}))
9786 |  |  |  |  | { $dump .= "$indent|-COMMENT: '" . _short_text( $elt->comment_string, $short_text) . "'\n" }
9787 |  |  |  |  | elsif( (exists $elt->{'target'}))
9788 |  |  |  |  | { $dump .= "$indent|-PI: '" . $elt->{target} . "' - '" . _short_text( $elt->{data}, $short_text) . "'\n" }
9789 |  |  |  |  | if( $extra) { $dump .= $elt->_dump_extra_data( $indent, $indent_sp, $short_text); }
9790 |  |  |  |  | }
9791 |  |  |  |  | return $dump;
9792 |  |  |  |  | }
9793 |  |  |  |  |
9794 |  |  |  |  | sub _dump_extra_data
9795 |  |  |  |  | { my( $elt, $indent, $indent_sp, $short_text)= @_;
9796 |  |  |  |  | my $dump='';
9797 |  |  |  |  | if( $elt->extra_data)
9798 |  |  |  |  | { my $extra_data = $indent . "|-- (cpi before) '" . _short_text( $elt->extra_data, $short_text) . "'";
9799 |  |  |  |  | $extra_data=~ s{\n}{$indent_sp}g;
9800 |  |  |  |  | $dump .= $extra_data . "\n";
9801 |  |  |  |  | }
9802 |  |  |  |  | if( $elt->{extra_data_in_pcdata})
9803 |  |  |  |  | { foreach my $data ( @{$elt->{extra_data_in_pcdata}})
9804 |  |  |  |  | { my $extra_data = $indent . "|-- (cpi offset $data->{offset}) '" . _short_text( $data->{text}, $short_text) . "'";
9805 |  |  |  |  | $extra_data=~ s{\n}{$indent_sp}g;
9806 |  |  |  |  | $dump .= $extra_data . "\n";
9807 |  |  |  |  | }
9808 |  |  |  |  | }
9809 |  |  |  |  | if( $elt->{extra_data_before_end_tag})
9810 |  |  |  |  | { my $extra_data = $indent . "|-- (cpi end) '" . _short_text( $elt->{extra_data_before_end_tag}, $short_text) . "'";
9811 |  |  |  |  | $extra_data=~ s{\n}{$indent_sp}g;
9812 |  |  |  |  | $dump .= $extra_data . "\n";
9813 |  |  |  |  | }
9814 |  |  |  |  | return $dump;
9815 |  |  |  |  | }
9816 |  |  |  |  |
9817 |  |  |  |  |
9818 |  |  |  |  | sub _short_text
9819 |  |  |  |  | { my( $string, $length)= @_;
9820 |  |  |  |  | if( !$length || (length( $string) < $length) ) { return $string; }
9821 |  |  |  |  | my $l1= (length( $string) -5) /2;
9822 |  |  |  |  | my $l2= length( $string) - ($l1 + 5);
9823 |  |  |  |  | return substr( $string, 0, $l1) . ' ... ' . substr( $string, -$l2);
9824 |  |  |  |  | }
9825 |  |  |  |  |
9826 |  |  |  |  |
9827 | 7 | 12µs | 7 | 13µs | # spent 26µs (13+13) within XML::Twig::Elt::_and which was called 7 times, avg 4µs/call: # 7 times (13µs+13µs) by XML::Twig::Elt::_gi_test at line 5917, avg 4µs/call sub _and { return _join_defined( ' && ', @_); } # spent 13µs making 7 calls to XML::Twig::Elt::_join_defined, avg 2µs/call
9828 | 7 | 15µs |  |  | # spent 13µs within XML::Twig::Elt::_join_defined which was called 7 times, avg 2µs/call: # 7 times (13µs+0s) by XML::Twig::Elt::_and at line 9827, avg 2µs/call sub _join_defined { return join( shift(), grep { $_ } @_); }
9829 |  |  |  |  |
9830 | 1 | 61µs |  |  | 1;
9831 |  |  |  |  | __END__
|  |  |  |  | # spent 600ns within Spreadsheet::ParseXLSX::__ANON__ which was called: # once (600ns+0s) by Spreadsheet::ParseXLSX::BEGIN@14 at line 14 of /home/micha/Projekt/spreadsheet-parsexlsx/lib/Spreadsheet/ParseXLSX.pm sub Spreadsheet::ParseXLSX::__ANON__; # xsub