# Before `./Build install' is performed this script should be runnable with
# `./Build test'. After `./Build install' it should work as `perl 10_Disk.t'
#---------------------------------------------------------------------
# 10_Disk.t
# Copyright 2006 Christopher J. Madsen
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
# GNU General Public License or the Artistic License for more details.
#
# Test the AppleII::Disk module
#---------------------------------------------------------------------
use FindBin;
use Test::More tests => 36;
BEGIN { use_ok('AppleII::Disk') };
use bytes;
#---------------------------------------------------------------------
my $dir = "$FindBin::Bin/tmpdir";
mkdir $dir;
chdir $dir or die "Can't cd $dir: $!";
my $dfn = "test.DO";
my $pfn = "test.PO";
foreach ($dfn, $pfn) {
unlink $_ or die "Can't unlink $_: $!" if -e $_;
}
#---------------------------------------------------------------------
# Create a new DOS 3.3-order image and test it:
my $d = AppleII::Disk->new($dfn, 'drw');
isa_ok($d, 'AppleII::Disk', '$d');
isa_ok($d, 'AppleII::Disk::DOS33', '$d');
$d->blocks(280); # 140KB floppy
is($d->blocks, 280, "$dfn is 280 blocks");
is($d->read_block(42), "\0" x 512, "block 42 is empty");
eval { $d->read_block(280) };
like($@, qr/Invalid (?:block|position)/, "Caught reading block out-of-range");
eval { $d->write_block(279, "A" x 256, "B") };
is($@, '', "Wrote block 279");
is($d->{actlen}, 0x23000, "$dfn is now 140KB"); # WARNING: internal data
is($d->read_sector(34, 1), "A" x 256, "Read 34/01");
is($d->read_sector(34, 15), "B" x 256, "Read 34/15");
# Fill in data for the ProDOS-order tests:
eval { $d->write_sector(34, 14, "C" x 256) };
is($@, '', "Wrote 34/14");
eval { $d->write_sector(34, 0, '', "D") };
is($@, '', "Wrote 34/00");
eval { $d->write_sector(34, 0, '', "D") };
is($@, '', "Wrote 34/00");
eval { $d->write_sector( 0, 0, 'HI' x 128) };
is($@, '', "Wrote 00/00");
is($d->read_block(0), ('HI' x 128) . ("\0" x 256), "Read block 0");
undef $d;
#---------------------------------------------------------------------
# Open the same image, but treat it as ProDOS-order:
my $pd = AppleII::Disk->new($dfn, 'prw');
isa_ok($pd, 'AppleII::Disk', '$pd');
isa_ok($pd, 'AppleII::Disk::ProDOS', '$pd');
is($pd->blocks, 280, "$dfn is still 280 blocks");
is($pd->read_block(42), "\0" x 512, "block 42 is still empty");
eval { $pd->read_block(280) };
like($@, qr/Invalid (?:block|position)/, "Caught reading block out-of-range");
is($pd->{actlen}, 0x23000, "$dfn is still 140KB"); # WARNING: internal data
is($pd->read_block(279), ("C" x 256) . ("B" x 256), "Read block 279");
is($pd->read_block(272), ("D" x 256) . ("A" x 256), "Read block 272");
is($pd->read_blocks([279, 0, 272]),
("C" x 256) . ("B" x 256) . ("\0" x 512) . ("D" x 256) . ("A" x 256),
"Read blocks 279, NULL, 272");
# write_blocks shouldn't alter block 0:
eval { $pd->write_blocks([279, 0, 272], 'F' x 0x600) };
is($@, '', 'Wrote blocks 279, 0, 272');
is($pd->read_block(279), ("F" x 512), "Read block 279 again");
is($pd->read_block(272), ("F" x 512), "Read block 272 again");
is($pd->read_block(0), ('HI' x 128) . ("\0" x 256), "Read block 0 again");
undef $pd;
#---------------------------------------------------------------------
# Create a new ProDOS-order image and test it:
my $np = AppleII::Disk->new($pfn, 'prw');
isa_ok($np, 'AppleII::Disk', '$np');
isa_ok($np, 'AppleII::Disk::ProDOS', '$np');
$np->blocks(280); # 140KB floppy
is($np->blocks, 280, "$pfn is 280 blocks");
eval { $np->write_block(279, "A" x 256) };
like($@, qr/Data block is 256 bytes/, "Caught writing short block");
is($np->read_block(279), "\0" x 512, "Block 279 still empty");
eval { $np->write_block(279, "A" x 256, "B") };
is($@, '', "Wrote block 279 to $pfn");
is($np->read_block(279), ("A" x 256) . ("B" x 256), "Read block 279");
is($np->{actlen}, 0x23000, "$pfn is now 140KB"); # WARNING: internal data
undef $np;
#---------------------------------------------------------------------
# Local Variables:
# mode: perl
# End: