package Common;
#--------------------
#
# GLOBALS...
#
#--------------------
use vars qw(@DATA_SA
@DATA_LA
$DATA_S
@ADATA_SA
$ADATA_S
$FDATA_S
@FDATA_LA
);
#------------------------------
# Data...
# ...as a scalar-array:
@DATA_SA = (
"A diner while ",
"dining at Crewe\n",
"Found a rather large ",
"mouse in his stew\n Said the waiter, \"Don't shout,\n",
" And ",
"wave it about..."
);
# ...as a string:
$DATA_S = join '', @DATA_SA;
# ...as a line-array:
@DATA_LA = lines($DATA_S);
# Additional data...
# ...as a scalar-array:
@ADATA_SA = (
"\nor the rest",
" will be wanting one ",
"too.\"\n",
);
# ...as a string:
$ADATA_S = join '', @ADATA_SA;
# Full data...
# ...as a string:
$FDATA_S = $DATA_S . $ADATA_S;
# ...as a line-array:
@FDATA_LA = lines($FDATA_S);
# Tester:
my $T;
# Scratch...
my $BUF = ''; # buffer
my $M; # message
#------------------------------
# lines STR
#------------------------------
sub lines {
my $s = shift;
split /^/, $s;
}
#------------------------------
# test_init PARAMHASH
#------------------------------
# Init common tests.
#
sub test_init {
my ($self, %p) = @_;
$T = $p{TBone};
}
#------------------------------
# test_print HANDLE, TEST
#------------------------------
# Test printing to handle.
# 1
#
sub test_print {
my ($self, $GH, $all) = @_;
local($_);
# Append with print:
$M = "PRINT: able to print to $GH";
$GH->print($ADATA_SA[0]);
$GH->print(@ADATA_SA[1..2]);
$T->ok(1, $M);
}
#------------------------------
# test_getc HANDLE
#------------------------------
# Test getc().
# 1
#
sub test_getc {
my ($self, $GH) = @_;
local($_);
my @c;
$M = "GETC: seek(0,0) and getc()";
$GH->seek(0,0);
for (0..2) { $c[$_] = $GH->getc };
$T->ok((($c[0] eq 'A') &&
($c[1] eq ' ') &&
($c[2] eq 'd')), $M);
}
#------------------------------
# test_getline HANDLE
#------------------------------
# Test getline() and getlines().
# 4
#
sub test_getline {
my ($self, $GH) = @_;
local($_);
$M = "GETLINE/SEEK3: seek(3,START) and getline() gets part of 1st line";
$GH->seek(3,0);
my $got = $GH->getline;
my $want = "iner while dining at Crewe\n";
$T->ok(($got eq $want), $M,
GH => $GH,
Got => $got,
Want => $want);
$M = "GETLINE/NEXT: next getline() gets subsequent line";
$_ = $GH->getline;
$T->ok(($_ eq "Found a rather large mouse in his stew\n"), $M,
Got => $_);
$M = "GETLINE/EOF: repeated getline() finds end of stream";
my $last;
for (1..6) { $last = $GH->getline }
$T->ok(!$last, $M,
Last => (defined($last) ? $last : 'undef'));
$M = "GETLINE/GETLINES: seek(0,0) and getlines() slurps in string";
$GH->seek(0,0);
my @got = $GH->getlines;
my $gots = join '', @got;
$T->ok(($gots eq $FDATA_S), $M,
GotAll => $gots,
WantAll => $FDATA_S,
Got => \@got);
}
#------------------------------
# test_read HANDLE
#------------------------------
# Test read().
# 4
#
sub test_read {
my ($self, $GH) = @_;
local($_);
$M = "READ/FIRST10: reading first 10 bytes with seek(0,START) + read(10)";
$GH->seek(0,0);
$GH->read($BUF,10);
$T->ok(($BUF eq "A diner wh"), $M);
$M = "READ/NEXT10: reading next 10 bytes with read(10)";
$GH->read($BUF,10);
$T->ok(($BUF eq "ile dining"), $M);
$M = "READ/TELL20: tell() the current location as 20";
$T->ok(($GH->tell == 20), $M);
$M = "READ/SLURP: seek(0,START) + read(1000) reads in whole handle";
$GH->seek(0,0);
$GH->read($BUF,1000);
$T->ok(($BUF eq $FDATA_S), $M);
}
#------------------------------
# test_seek HANDLE
#------------------------------
# Test seeks other than (0,0).
# 2
#
sub test_seek {
my ($self, $GH) = @_;
local($_);
$M = "SEEK/SET: seek(2,SET) + read(5) returns 'diner'";
$GH->seek(2,0);
$GH->read($BUF,5);
$T->ok_eq($BUF, 'diner',
$M);
$M = "SEEK/END: seek(-6,END) + read(3) returns 'too'";
$GH->seek(-6,2);
$GH->read($BUF,3);
$T->ok_eq($BUF, 'too',
$M);
$M = "SEEK/CUR: seek(-7,CUR) + read(7) returns 'one too'";
$GH->seek(-7,1);
$GH->read($BUF,7);
$T->ok_eq($BUF, 'one too',
$M);
}
#------------------------------
# test_tie PARAMHASH
#------------------------------
# Test tiehandle getline() interface.
# 4
#
sub test_tie {
my ($self, %p) = @_;
my ($tieclass, @tieargs) = @{$p{TieArgs}};
local($_);
my @lines;
my $i;
my $nmatched;
$M = "TIE/TIE: able to tie";
tie(*OUT, $tieclass, @tieargs);
$T->ok(1, $M,
TieClass => $tieclass,
TieArgs => \@tieargs);
$M = "TIE/PRINT: printing data";
print OUT @DATA_SA;
print OUT $ADATA_SA[0];
print OUT @ADATA_SA[1..2];
$T->ok(1, $M);
$M = "TIE/GETLINE: seek(0,0) and scalar <> get expected lines";
tied(*OUT)->seek(0,0); # rewind
@lines = (); push @lines, $_ while <OUT>; # get lines one at a time
$nmatched = 0; # total up matches...
for (0..$#lines) { ++$nmatched if ($lines[$_] eq $FDATA_LA[$_]) };
$T->ok(($nmatched == int(@FDATA_LA)), $M,
Want => \@FDATA_LA,
Gotl => \@lines,
Lines=> "0..$#lines",
Match=> $nmatched,
FDatl=> int(@FDATA_LA),
FData=> \@FDATA_LA);
$M = "TIE/GETLINES: seek(0,0) and array <> slurps in lines";
tied(*OUT)->seek(0,0); # rewind
@lines = <OUT>; # get lines all at once
$nmatched = 0; # total up matches...
for (0..$#lines) { ++$nmatched if ($lines[$_] eq $FDATA_LA[$_]) };
$T->ok(($nmatched == int(@FDATA_LA)), $M,
Want => \@FDATA_LA,
Gotl => \@lines,
Lines=> "0..$#lines",
Match=> $nmatched);
# $M = "TIE/TELL: telling data";
# my $tell_oo = tied(*OUT)->tell;
# my $tell_tie = tell OUT;
# $T->ok(($tell_oo == $tell_tie), $M,
# Want => $tell_oo,
# Gotl => $tell_tie);
}
#------------------------------
# test_recordsep
#------------------------------
# Try $/ tests.
#
# 3 x undef
# 3 x empty
# 2 x custom
# 11 x newline
#
sub test_recordsep_count {
my ($self, $seps) = @_;
my $count = 0;
$count += 3 if ($seps =~ /undef/) ;
$count += 3 if ($seps =~ /empty/) ;
$count += 2 if ($seps =~ /custom/) ;
$count += 11 if ($seps =~ /newline/);
$count;
}
sub test_recordsep {
my ($self, $seps, $opener) = @_;
my $GH;
my @lines = ("par 1, line 1\n",
"par 1, line 2\n",
"\n",
"\n",
"\n",
"\n",
"par 2, line 1\n",
"\n",
"par 3, line 1\n",
"par 3, line 2\n",
"par 3, line 3");
my $all = join('', @lines);
### Slurp everything:
if ($seps =~ /undef/) {
$GH = &$opener(\@lines);
local $/ = undef;
$T->ok_eq($GH->getline, $all,
"RECORDSEP undef: getline slurps everything");
}
### Read a little, slurp the rest:
if ($seps =~ /undef/) {
$GH = &$opener(\@lines);
$T->ok_eq($GH->getline, $lines[0],
"RECORDSEP undef: get first line");
local $/ = undef;
$T->ok_eq($GH->getline, join('', @lines[1..$#lines]),
"RECORDSEP undef: slurp the rest");
}
### Read paragraph by paragraph:
if ($seps =~ /empty/) {
$GH = &$opener(\@lines);
local $/ = "";
$T->ok_eq($GH->getline, join('', @lines[0..2]),
"RECORDSEP empty: first par");
$T->ok_eq($GH->getline, join('', @lines[6..7]),
"RECORDSEP empty: second par");
$T->ok_eq($GH->getline, join('', @lines[8..10]),
"RECORDSEP empty: third par");
}
### Read record by record:
if ($seps =~ /custom/) {
$GH = &$opener(\@lines);
local $/ = "1,";
$T->ok_eq($GH->getline, "par 1,",
"RECORDSEP custom: first rec");
$T->ok_eq($GH->getline, " line 1\npar 1,",
"RECORDSEP custom: second rec");
}
### Read line by line:
if ($seps =~ /newline/) {
$GH = &$opener(\@lines);
local $/ = "\n";
for my $i (0..10) {
$T->ok_eq($GH->getline, $lines[$i],
"RECORDSEP newline: rec $i");
}
}
}
#------------------------------
1;
syntax highlighted by Code2HTML, v. 0.9.1