D64-Disk-Dir-Item
view release on metacpan or search on metacpan
$item->data(\@data);
# Get/set the actual file type:
my $type = $item->type();
$item->type($type);
# Get/set "closed" flag (when not set produces "*", or "splat" files):
my $is_closed = $item->closed();
$item->closed($is_closed);
# Get/set "locked" flag (when set produces ">" locked files):
my $is_locked = $item->locked();
$item->locked($is_locked);
# Get/set track location of first sector of file:
my $track = $item->track();
$item->track($track);
# Get/set sector location of first sector of file:
my $sector = $item->sector();
$item->sector($sector);
# Get/set 16 character filename (in CBM ASCII, padded with $A0):
if (ref $is_closed) {
die q{Invalid "closed" flag};
}
my $closed_bit = $is_closed ? 0b10000000 : 0b00000000;
$self->[$I_CLOSED] = chr ((ord ($self->[$I_CLOSED]) & 0b01111111) | $closed_bit);
}
return (ord ($self->[$I_CLOSED]) & 0b10000000) == 0b10000000;
}
=head2 locked
Get "locked" flag:
my $is_locked = $item->locked();
Returns true when "locked" flag is set, and false otherwise.
Set "locked" flag:
$item->locked($is_locked);
When "locked" flag is set, it produces ">" locked files.
=cut
sub locked {
my ($self, $is_locked) = @_;
if (defined $is_locked) {
if (ref $is_locked) {
die q{Invalid "locked" flag};
}
my $locked_bit = $is_locked ? 0b01000000 : 0b00000000;
$self->[$I_LOCKED] = chr ((ord ($self->[$I_LOCKED]) & 0b10111111) | $locked_bit);
}
return (ord ($self->[$I_LOCKED]) & 0b01000000) == 0b01000000;
}
=head2 track
Get track location of first sector of file:
my $track = $item->track();
my $verbose = $args{verbose};
$fh ||= *STDOUT;
$fh->binmode(':bytes');
my $stdout = select $fh;
if ($as_petscii) {
my $type = $self->type_to_string($self->type(), 1);
my $closed = $self->closed() ? 0x20 : 0x2a; # "*"
my $locked = $self->locked() ? 0x3c : 0x20; # "<"
my $track = sprintf "%2d", $self->track();
my $sector = sprintf "%2d", $self->sector();
my $size = ascii_to_petscii($self->size());
my $name = sprintf "\"%s\"", $self->name(padding_with_a0 => 0);
$name =~ s/\x00//g; # align file type string to the right column
if ($verbose) {
printf "%-4d %-18s%c%s%c %s %s\n", $size, $name, $closed, $type, $locked, $track, $sector;
}
else {
printf "%-4d %-18s%c%s%c\n", $size, $name, $closed, $type, $locked;
}
}
else {
my $type = $self->type_to_string($self->type());
my $closed = $self->closed() ? ord ' ' : ord '*';
my $locked = $self->locked() ? ord '<' : ord ' ';
my $track = sprintf "%2d", petscii_to_ascii $self->track();
my $sector = sprintf "%2d", petscii_to_ascii $self->sector();
my $size = $self->size();
my $name = sprintf "\"%s\"", petscii_to_ascii($self->name(padding_with_a0 => 0));
$name =~ s/\x00//g; # align file type string to the right column
if ($verbose) {
printf "%-4d %-18s%c%s%c %s %s\n", $size, $name, $closed, $type, $locked, $track, $sector;
}
else {
printf "%-4d %-18s%c%s%c\n", $size, $name, $closed, $type, $locked;
}
}
select $stdout;
return;
}
=head2 validate
$test->data($data);
my $type = $self->type();
die unless defined $type;
$test->type($type);
my $closed = $self->closed();
die unless defined $closed;
$test->closed($closed);
my $locked = $self->locked();
die unless defined $locked;
$test->locked($locked);
my $track = $self->track();
die unless defined $track;
$test->track($track);
my $sector = $self->sector();
die unless defined $sector;
$test->sector($sector);
my $name = $self->name();
use Test::Exception;
use Test::More tests => 41;
########################################
our $class;
BEGIN {
$class = 'D64::Disk::Dir::Item';
use_ok($class, qw(:all));
}
########################################
{
can_ok($class, qw(new data type closed locked track sector name side_track side_sector record_length size print validate));
}
########################################
{
my $test_del = $T_DEL == 0b000;
my $test_seq = $T_SEQ == 0b001;
my $test_prg = $T_PRG == 0b010;
my $test_usr = $T_USR == 0b011;
my $test_rel = $T_REL == 0b100;
my $test_cbm = $T_CBM == 0b101;
my $test_dir = $T_DIR == 0b110;
}
########################################
{
my $item = get_item();
my $is_closed = $item->closed();
ok($is_closed, 'get closed flag from a valid directory item');
}
########################################
{
my $item = $class->new();
my $is_locked = $item->locked();
ok(!$is_locked, 'get locked flag from an empty directory item');
}
########################################
{
my $item = get_item();
my $is_locked = $item->locked();
ok(!$is_locked, 'get locked flag from a valid directory item');
}
########################################
{
my $item = $class->new();
my $track = $item->track();
is($track, 0x00, 'get track location of first sector of file from an empty directory item');
}
########################################
{
my $item = get_item();
my $item = get_item();
throws_ok(
sub { $item->closed([1]); },
qr/Invalid "closed" flag/,
'set invalid closed flag for a valid directory item',
);
}
########################################
{
my $item = $class->new();
$item->locked(1);
ok($item->locked(), 'set locked flag for an empty directory item');
}
########################################
{
my $item = $class->new();
$item->locked(0);
ok(!$item->locked(), 'clear locked flag for an empty directory item');
}
########################################
{
my $item = get_item();
$item->locked(1);
ok($item->locked(), 'set locked flag for a valid directory item');
}
########################################
{
my $item = get_item();
$item->locked(0);
ok(!$item->locked(), 'clear locked flag for a valid directory item');
}
########################################
{
my $item = get_item();
throws_ok(
sub { $item->locked([1]); },
qr/Invalid "locked" flag/,
'set invalid locked flag for a valid directory item',
);
}
########################################
{
my $item = $class->new();
my $track = 0x11;
$item->track($track);
is($item->track(), $track, 'set new track location of first sector of file for an empty directory item');
}
########################################
t/05-data.t view on Meta::CPAN
{
my $item = get_item();
$item->closed(0);
my @bytes = qw(02 11 00 54 45 53 54 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 00 00 00 00 00 00 00 00 00 01 00);
my $data = join '', map { chr } map { hex } @bytes;
is($item->data(), $data, 'clear closed flag for a valid directory item and fetch data bytes');
}
########################################
{
my $item = get_item();
$item->locked(1);
my @bytes = qw(c2 11 00 54 45 53 54 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 00 00 00 00 00 00 00 00 00 01 00);
my $data = join '', map { chr } map { hex } @bytes;
is($item->data(), $data, 'set locked flag for a valid directory item and fetch data bytes');
}
########################################
{
my $item = get_item();
$item->track(0x13);
my @bytes = qw(82 13 00 54 45 53 54 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 a0 00 00 00 00 00 00 00 00 00 01 00);
my $data = join '', map { chr } map { hex } @bytes;
is($item->data(), $data, 'set new track location of first sector of file for a valid directory item and fetch data bytes');
}
########################################
t/06-print.t view on Meta::CPAN
my $print_out = ${$sh->sref};
chomp $print_out;
is($print_out, '1 "test" prg 17 0', 'verbosely print out valid directory item in ASCII mode');
}
########################################
{
my $sh = new IO::Scalar;
my $item = get_item();
$item->type($T_REL);
$item->closed(0);
$item->locked(1);
my $name = chr(0x4e) . chr(0x45) . chr(0x57) . chr(0x46) . chr(0x49) . chr(0x4c) . chr(0x45) . chr(0x20) . chr(0x4e) . chr(0x45) . chr(0x57) . chr(0x46) . chr(0x49) . chr(0x4c) . chr(0x45);
$item->name($name);
$item->size(160);
$item->print(fh => $sh);
my $print_out = ${$sh->sref};
chomp $print_out;
is($print_out, '160 "newfile newfile" *rel<', 'print out modified directory item in ASCII mode');
}
########################################
{
my $sh = new IO::Scalar;
my $item = get_item();
$item->type($T_REL);
$item->closed(0);
$item->locked(1);
my $name = chr(0x4e) . chr(0x45) . chr(0x57) . chr(0x46) . chr(0x49) . chr(0x4c) . chr(0x45) . chr(0x20) . chr(0x4e) . chr(0x45) . chr(0x57) . chr(0x46) . chr(0x49) . chr(0x4c) . chr(0x45);
$item->name($name);
$item->size(160);
$item->print(fh => $sh, verbose => 1);
my $print_out = ${$sh->sref};
chomp $print_out;
is($print_out, '160 "newfile newfile" *rel< 17 0', 'verbosely print out modified directory item in ASCII mode');
}
########################################
{
t/06-print.t view on Meta::CPAN
is($print_out, $expected_print_out, 'print out valid directory item in PETSCII mode');
}
########################################
{
my $sh = new IO::Scalar;
my $item = get_item();
$item->type($T_REL);
$item->track(0x13);
$item->sector(0x03);
$item->closed(0);
$item->locked(1);
my $name = chr(0x4e) . chr(0x45) . chr(0x57) . chr(0x46) . chr(0x49) . chr(0x4c) . chr(0x45) . chr(0x20) . chr(0x4e) . chr(0x45) . chr(0x57) . chr(0x46) . chr(0x49) . chr(0x4c) . chr(0x45);
$item->name($name);
$item->size(320);
$item->print(fh => $sh, as_petscii => 1);
my $print_out = ${$sh->sref};
chomp $print_out;
my @expected_bytes = qw(33 32 30 20 20 22 4e 45 57 46 49 4c 45 20 4e 45 57 46 49 4c 45 22 20 2a 52 45 4c 3c);
my $expected_print_out = join '', map { chr } map { hex } @expected_bytes;
is($print_out, $expected_print_out, 'print out modified directory item in PETSCII mode');
}
( run in 1.063 second using v1.01-cache-2.11-cpan-49f99fa48dc )