# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
package TestAPR::perlio;
# to see what happens inside the io layer, assuming that you built
# mod_perl with MP_TRACE=1, run:
# env MOD_PERL_TRACE=o t/TEST -v -trace=debug apr/perlio
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use Fcntl ();
use File::Spec::Functions qw(catfile);
use Apache2::Const -compile => qw(OK CRLF);
#XXX: APR::LARGE_FILES_CONFLICT constant?
#XXX: you can set to zero if largefile support is not enabled in Perl
use constant LARGE_FILES_CONFLICT => 1;
# apr_file_dup has a bug on win32,
# should be fixed in apr 0.9.4 / httpd-2.0.48
require Apache2::Build;
use constant APR_WIN32_FILE_DUP_BUG =>
Apache2::Build::WIN32() && !have_min_apache_version('2.0.48');
sub handler {
my $r = shift;
my $tests = 22;
$tests += 3 unless LARGE_FILES_CONFLICT;
$tests += 1 unless APR_WIN32_FILE_DUP_BUG;
require APR::PerlIO;
plan $r, tests => $tests,
need { "This Perl build doesn't support PerlIO layers" =>
APR::PerlIO::PERLIO_LAYERS_ARE_ENABLED() };
my $vars = Apache::Test::config()->{vars};
my $dir = catfile $vars->{documentroot}, "perlio";
t_mkdir($dir);
my $sep = "-- sep --\n";
my @lines = ("This is a test: $$\n", "test line --sep two\n");
my $expected = $lines[0];
my $expected_all = join $sep, @lines;
# write file
my $file = catfile $dir, "test";
t_debug "open file $file for writing";
my $foo = "bar";
open my $fh, ">:APR", $file, $r->pool
or die "Cannot open $file for writing: $!";
ok ref($fh) eq 'GLOB';
t_debug "write to a file:\n$expected\n";
print $fh $expected_all;
close $fh;
# open() failure test
{
# workaround for locale setups where the error message may be
# in a different language
open my $fh, "perlio_this_file_cannot_exist";
my $errno_string = "$!";
# non-existent file
my $file = "/this/file/does/not/exist";
if (open my $fh, "<:APR", $file, $r->pool) {
t_debug "must not be able to open $file!";
ok 0;
close $fh;
}
else {
ok t_cmp("$!",
$errno_string,
"expected failure");
}
}
# seek/tell() tests
unless (LARGE_FILES_CONFLICT) {
open my $fh, "<:APR", $file, $r->pool
or die "Cannot open $file for reading: $!";
# read the whole file so we can test the buffer flushed
# correctly on seek.
my $dummy = join '', <$fh>;
# Fcntl::SEEK_SET()
my $pos = 3; # rewinds after reading 6 chars above
seek $fh, $pos, Fcntl::SEEK_SET();
my $got = tell($fh);
ok t_cmp($got,
$pos,
"seek/tell the file Fcntl::SEEK_SET");
# Fcntl::SEEK_CUR()
my $step = 10;
$pos = tell($fh) + $step;
seek $fh, $step, Fcntl::SEEK_CUR();
$got = tell($fh);
ok t_cmp($got,
$pos,
"seek/tell the file Fcntl::SEEK_CUR");
# Fcntl::SEEK_END()
$pos = -s $file;
seek $fh, 0, Fcntl::SEEK_END();
$got = tell($fh);
ok t_cmp($got,
$pos,
"seek/tell the file Fcntl::SEEK_END");
close $fh;
}
# read() tests
{
open my $fh, "<:APR", $file, $r->pool
or die "Cannot open $file for reading: $!";
# basic open test
ok ref($fh) eq 'GLOB';
# basic single line read
ok t_cmp(scalar(<$fh>),
$expected,
"single line read");
# slurp mode
seek $fh, 0, Fcntl::SEEK_SET(); # rewind to the start
local $/;
ok t_cmp(scalar(<$fh>),
$expected_all,
"slurp file");
# test ungetc (a long sep requires read ahead)
seek $fh, 0, Fcntl::SEEK_SET(); # rewind to the start
local $/ = $sep;
my @got_lines = <$fh>;
my @expect = ($lines[0] . $sep, $lines[1]);
ok t_cmp(\@got_lines,
\@expect,
"custom complex input record sep read");
close $fh;
}
# eof() tests
{
open my $fh, "<:APR", $file, $r->pool
or die "Cannot open $file for reading: $!";
ok t_cmp(0,
int eof($fh), # returns false, not 0
"not end of file");
# go to the end and read so eof will return 1
seek $fh, 0, Fcntl::SEEK_END();
my $received = <$fh>;
t_debug($received);
ok t_cmp(eof($fh),
1,
"end of file");
close $fh;
}
# dup() test
{
open my $fh, "<:APR", $file, $r->pool
or die "Cannot open $file for reading: $!";
open my $dup_fh, "<&:APR", $fh
or die "Cannot dup $file for reading: $!";
close $fh;
ok ref($dup_fh) eq 'GLOB';
my $received = <$dup_fh>;
close $dup_fh;
unless (APR_WIN32_FILE_DUP_BUG) {
ok t_cmp($received,
$expected,
"read/write a dupped file");
}
}
# unbuffered write
{
open my $wfh, ">:APR", $file, $r->pool
or die "Cannot open $file for writing: $!";
open my $rfh, "<:APR", $file, $r->pool
or die "Cannot open $file for reading: $!";
my $expected = "This is an un buffering write test";
# unbuffer
my $oldfh = select($wfh); $| = 1; select($oldfh);
print $wfh $expected; # must be flushed to disk immediately
ok t_cmp(scalar(<$rfh>),
$expected,
"file unbuffered write");
# buffer up
$oldfh = select($wfh); $| = 0; select($oldfh);
print $wfh $expected; # should be buffered up and not flushed
ok t_cmp(scalar(<$rfh>),
undef,
"file buffered write");
close $wfh;
close $rfh;
}
# tests reading and writing text and binary files
{
for my $file ('MoonRise.jpeg', 'redrum.txt') {
my $in = catfile $dir, $file;
my $out = catfile $dir, "$file.out";
my ($apr_content, $perl_content);
open my $rfh, "<:APR", $in, $r->pool
or die "Cannot open $in for reading: $!";
{
local $/;
$apr_content = <$rfh>;
}
close $rfh;
open my $pfh, "<", $in
or die "Cannot open $in for reading: $!";
binmode($pfh);
{
local $/;
$perl_content = <$pfh>;
}
close $pfh;
ok t_cmp(length $apr_content,
length $perl_content,
"testing data size of $file");
open my $wfh, ">:APR", $out, $r->pool
or die "Cannot open $out for writing: $!";
print $wfh $apr_content;
close $wfh;
ok t_cmp(-s $out,
-s $in,
"testing file size of $file");
unlink $out;
}
}
# tests for various CRLF and utf-8 issues
{
my $scratch = catfile $dir, 'scratch.dat';
my $text;
my $count = 2000;
open my $wfh, ">:crlf", $scratch
or die "Cannot open $scratch for writing: $!";
print $wfh 'a' . ((('a' x 14) . "\n") x $count);
close $wfh;
open my $rfh, "<:APR", $scratch, $r->pool
or die "Cannot open $scratch for reading: $!";
{
local $/;
$text = <$rfh>;
}
close $rfh;
ok t_cmp(count_chars($text, Apache2::Const::CRLF),
$count,
'testing for presence of \015\012');
ok t_cmp(count_chars($text, "\n"),
$count,
'testing for presence of \n');
open $wfh, ">:APR", $scratch, $r->pool
or die "Cannot open $scratch for writing: $!";
print $wfh 'a' . ((('a' x 14) . Apache2::Const::CRLF) x $count);
close $wfh;
open $rfh, "<:APR", $scratch, $r->pool
or die "Cannot open $scratch for reading: $!";
{
local $/;
$text = <$rfh>;
}
close $rfh;
ok t_cmp(count_chars($text, Apache2::Const::CRLF),
$count,
'testing for presence of \015\012');
ok t_cmp(count_chars($text, "\n"),
$count,
'testing for presence of \n');
open $rfh, "<:crlf", $scratch
or die "Cannot open $scratch for reading: $!";
{
local $/;
$text = <$rfh>;
}
close $rfh;
ok t_cmp(count_chars($text, Apache2::Const::CRLF),
0,
'testing for presence of \015\012');
ok t_cmp(count_chars($text, "\n"),
$count,
'testing for presence of \n');
my $utf8 = "\x{042F} \x{0432}\x{0430}\x{0441} \x{043B}\x{044E}";
open $wfh, ">:APR", $scratch, $r->pool
or die "Cannot open $scratch for writing: $!";
binmode($wfh, ':utf8');
print $wfh $utf8;
close $wfh;
open $rfh, "<:APR", $scratch, $r->pool
or die "Cannot open $scratch for reading: $!";
binmode($rfh, ':utf8');
{
local $/;
$text = <$rfh>;
}
close $rfh;
ok t_cmp($text,
$utf8,
'utf8 binmode test');
unlink $scratch;
}
# XXX: need tests
# - for stdin/out/err as they are handled specially
# XXX: tmpfile is missing:
# consider to use 5.8's syntax:
# open $fh, "+>", undef;
# cleanup: t_mkdir will remove the whole tree including the file
Apache2::Const::OK;
}
sub count_chars {
my ($text, $chars) = @_;
my $seen = 0;
$seen++ while $text =~ /$chars/g;
return $seen;
}
1;