view release on metacpan or  search on metacpan

t/001.t  view on Meta::CPAN

=head1 SYNOPSIS

=head2 Head2

some paragraph

L<other::module/Head2>

L<missing::module/section>

POD

t_write_file(t_catfile($droot, 'other', 'module.pod'), <<'POD');

=head1 NAME bla

=head1 SYNOPSIS

=head2 Head2

some paragraph

L<d::p/Head2>

L<missing::module/section>

POD

##########################################
# direct access mode
##########################################
t_debug 'Testing direct access mode';

$resp=GET_BODY("/d/p.pod");

like $resp, qr!NAME bla</a></h1>!, 'got it';
unlike $resp, qr!class="uplink"!, 'without uplink';
like $resp, qr!a href="/other/module\.pod#Head2"!, 'link to existing module';
like $resp, qr!a href="/perldoc/missing::module#section"!,
    'link to missing module';

##########################################
# POD index
##########################################
t_debug 'Testing POD index';

$resp=GET("/perldoc?open");     # expect redirect

like $resp->header('Location'), qr!/perldoc/\?open!, 'redirect location';
is $resp->code, 302, 'redirect code';

$resp=GET_BODY("/perldoc/");

# <a href="perlfunc" title="perlfunc">perlfunc</a>
like $resp, qr!<a href="\./perlpod" title="perlpod">perlpod</a>!,
    'POD Index: found perlpod';
unlike $resp, qr!href="\./"!, 'POD Index: no "Pod Index" link';
like $resp, qr!href="\./\?\?"!, 'POD Index: "Function Index" link';

# this test also covers unescaped colons in title=...
# <a href="./d::p" title="d::p">d::p</a>
like $resp, qr!<a href="\./d::p" title="d::p">d::p</a>!,
    'POD Index: found d::p (probably found in PODDIR)';

##########################################
# Function index
##########################################
t_debug 'Testing Function index';

$resp=GET("/perldoc??");     # expect redirect

like $resp->header('Location'), qr!/perldoc/\?\?!, 'redirect location';
is $resp->code, 302, 'redirect code';

$resp=GET_BODY("/perldoc/??");

like $resp, qr!<a href="\./\?\$_" title="\$_">\$_</a>!,
    'Function Index: found $_';
like $resp, qr!<a href="\./\?ref" title="ref">ref</a>!,
    'Function Index: found ref';
like $resp, qr!href="\./"!, 'Function Index: "Pod Index" link';
unlike $resp, qr!href="\./\?\?"!, 'Function Index: no "Function Index" link';

##########################################
# POD index / NOINC
##########################################
t_debug 'Testing POD/Function index with NOINC';

$resp=GET_BODY("/NOINC/");

unlike $resp, qr!perlpod!, 'POD Index: perlpod not found';
unlike $resp, qr!href="\./"!, 'POD Index: no "Pod Index" link';
like $resp, qr!href="\./\?\?"!, 'POD Index: "Function Index" link';

# this test also covers unescaped colons in title=...
# <a href="./d::p" title="d::p">d::p</a>
like $resp, qr!<a href="\./d::p" title="d::p">d::p</a>!,
    'POD Index: but found d::p';

$resp=GET_BODY("/NOINC/??");

like $resp, qr!<a href="\./\?\$_" title="\$_">\$_</a>!,
    'Function Index: found $_';
like $resp, qr!<a href="\./\?ref" title="ref">ref</a>!,
    'Function Index: found ref';
like $resp, qr!href="\./"!, 'Function Index: "Pod Index" link';
unlike $resp, qr!href="\./\?\?"!, 'Function Index: no "Function Index" link';

##########################################
# POD index: content compression
##########################################
t_debug 'Testing content compression with POD index';

my $expected=GET_BODY("/perldoc/"); # save a body we know for next tests
$expected=~s/<!--.*?-->//sg;

$resp=GET '/perldoc/', 'Accept-Encoding'=>'gzip,deflate';
like $resp->header('Vary'), qr/\bAccept-Encoding\b/i, 'Vary Header';
is $resp->header('Content-Encoding'), 'deflate', 'Content-Encoding';

{
    my $got=uncompress($resp->content);
    $got=~s/<!--.*?-->//sg;
    is $got, $expected, 'inflated body';
}

$resp=GET '/perldoc/', 'Accept-Encoding'=>'gzip';
like $resp->header('Vary'), qr/\bAccept-Encoding\b/i, 'Vary Header';
is $resp->header('Content-Encoding'), 'gzip', 'Content-Encoding';

{
    my $got=Compress::Zlib::memGunzip($resp->content);
    $got=~s/<!--.*?-->//sg;
    is $got, $expected, 'ungzipped body';
}

$resp=GET '/perldoc/';
like $resp->header('Vary'), qr/\bAccept-Encoding\b/i, 'Vary Header';
is $resp->header('Content-Encoding'), undef, 'Content-Encoding';
is $resp->content, $expected, 'plain body';

SKIP: {
    skip "need MMapDB to test POD index caching", 7
        unless have_module 'MMapDB';
    ##########################################
    # POD index: cached
    ##########################################
    t_debug 'Testing cached POD index';

    unlink t_catfile Apache::Test::vars->{t_dir}, 'cache.mmdb';

    $expected=~s!(\<a href=\"\./\?\?\"\>Function and Variable Index\<\/a\>)!
        $1.qq{\n    <a href="./-">Update POD Cache</a>}!e;

    die 'Please remove '.t_catfile Apache::Test::vars->{t_dir}, 'cache.mmdb'