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