view release on metacpan or  search on metacpan

t/test_3_27.t  view on Meta::CPAN

      );
    is( $t->root->sprint( { pretty_print => 'none' } ), $doc, 'sprint br with pretty_print none' );
}

{
    my $doc = '<d>&amp;</d>';
    my $t   = XML::Twig->new;
    $t->set_keep_encoding(1);
    is( $t->parse($doc)->sprint, $doc, 'set_keep_encoding(1)' );
    $t->set_keep_encoding(0);
    is( $t->parse($doc)->sprint, $doc, 'set_keep_encoding(1)' );
}

{
    my $doc = '<d att="foo"/>';
    is( XML::Twig->nparse( quote => 'single', $doc )->sprint, q{<d att='foo'/>}, 'quote option' );
}

{
    my $doc = qq{<!DOCTYPE doc SYSTEM "dummy.dtd" [<!ENTITY obj.1 SYSTEM "o1.bmp" NDATA bmp>]>\n<doc/>};
    ( my $expected = $doc ) =~ s{ \[.*?\]}{};
    my $t           = XML::Twig->nparse($doc);
    my $entity_list = $t->entity_list;
    foreach my $entity ( $entity_list->list() ) { $entity_list->delete( $entity->name ); }
    is( $t->sprint( Update_DTD => 1 ), $expected, 'parse entities with all chars in their name' );
}

{
    my $tmp = "tmp-t27";
    foreach my $doc (
        qq{<!DOCTYPE d [<!ENTITY e SYSTEM "e.jpeg" NDATA JPEG>]><d/>},
        qq{<!DOCTYPE d><d/>},
        qq{<!DOCTYPE d []><d/>},
        )
    {
        foreach my $keep_encoding ( 0 .. 1 ) {
            open( MYOUT, ">$tmp" ) or die "cannot open $tmp: $!";
            my $t = XML::Twig->new(
                twig_roots => {
                    dummy => sub { }
                },
                twig_print_outside_roots => \*MYOUT,
                keep_encoding            => $keep_encoding,
            )->parse($doc);
            close MYOUT;
            if ( -f $tmp ) {
                is_like( slurp($tmp), $doc, "file with no DTD but entities (keep_encoding: $keep_encoding)" );
                unlink $tmp;
            } else {
                skip( 1,
                    "problem with writing $tmp, likely linked to missing write permission on the current directory" );
            }
        }
    }
}

{
    my $doc = qq{<d><e1 id="e1">foo<e id="e">bar</e>baz</e1><e1 id="e2">toto <![CDATA[tata]]> tutu</e1></d>};
    my $t   = XML::Twig->parse($doc);
    is( $t->elt_id("e1")->text('no_recurse'), 'foobaz',         "text_only" );
    is( $t->elt_id("e2")->text_only,          'toto tata tutu', "text_only (cdata section)" );
    is( $t->elt_id("e")->text_only,           'bar',            "text_only (no embedded elt)" );
}

{
    my $doc = qq{<!DOCTYPE d SYSTEM "dummy.dtd" []><d><e1 id="e1">tutu &lt;&ent; <b>no</b>tata</e1></d>};
    my $t   = XML::Twig->parse($doc);
    is( $t->elt_id("e1")->text(),                 'tutu <&ent; notata',    "text with ent" );
    is( $t->elt_id("e1")->text('no_recurse'),     'tutu <&ent; tata',      "text no_recurse with ent" );
    is( $t->elt_id("e1")->xml_text(),             'tutu &lt;&ent; notata', "xml_text with ent" );
    is( $t->elt_id("e1")->xml_text('no_recurse'), 'tutu &lt;&ent; tata',   "xml_text no_recurse with ent" );
}

if ( $] > 5.008 ) {
    my $r;
    XML::Twig->parse(
        twig_handlers => {
            '/a/b//c' => sub { $r++; }
        },
        q{<a><b><b><c>foo</c></b></b></a>}
    );
    ok( $r, "handler condition with // and nested elts (/a//b/c)" );
} else {
    skip( 1, "not tested under perl < 5.8" );
}

if ( $] > 5.008 ) {
    my @r;
    XML::Twig->parse(
        twig_handlers => {
            's[@#a="1"]'  => sub { push @r, $_->id },
            's/e[@x="1"]' => sub { $_->parent->set_att( '#a' => 1 ); },
        },
        q{<d><s id="s1"><e x="2"/><e /></s><s id="s2"><e x="1" /></s><s id="s3"><e x="2" /> <e x="1"/></s></d>},
    );
    is( join( ':', @r ), 's2:s3', 'inner handler changing parent attribute value' );
} else {
    skip( 1, "not tested under perl < 5.8" );
}

if ( $] > 5.008 ) {
    my @r;
    XML::Twig->parse(
        twig_roots => { '/d/s[@a="1"]/e[@a="1"]' => => sub { push @r, $_->id }, },
        q{<d><s><e a="1" id="e1"/><e id="e2"/></s>
                         <s a="1"><e a="1" id="e3"/><e id="e4"/></s>
                         <s><e a="1" id="e5"/><e id="e6"/></s>
                         <s a="1"><e id="e7"/><e id="e8" a="1"/></s>
                      </d>},
    );
    is( join( ':', @r ), 'e3:e8', 'complex condition with twig_roots' );
} else {
    skip( 1, "not tested under perl < 5.8" );
}

exit 0;    # or you get a weird error under 5.6.2