D64-Disk-Dir-Item
view release on metacpan or search on metacpan
package D64::Disk::Dir::Item;
=head1 NAME
D64::Disk::Dir::Item - Handling individual Commodore (D64/D71/D81) disk image directory items in pure Perl
=head1 SYNOPSIS
use D64::Disk::Dir::Item qw(:all);
# Create a new disk image directory item instance:
my $item = D64::Disk::Dir::Item->new($data);
my $item = D64::Disk::Dir::Item->new(@data);
my $item = D64::Disk::Dir::Item->new(\@data);
# Fetch item data as a scalar of 30 bytes:
my $data = $item->data();
# Fetch item data as an array of 30 bytes:
my @data = $item->data();
# Update item providing 30 bytes of scalar data:
$item->data($data);
# Update item given array with 30 bytes of data:
$item->data(@data);
$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):
my $name = $item->name();
$item->name($name);
# Get/set track location of first side-sector block (REL file only):
my $side_track = $item->side_track();
$item->side_track($side_track);
# Get/set sector location of first side-sector block (REL file only):
my $side_sector = $item->side_sector();
$item->side_sector($side_sector);
# Get/set relative file record length (REL file only):
my $record_length = $item->record_length();
$item->record_length($record_length);
# Get/set file size in sectors:
my $size = $item->size();
$item->size($size);
# Print out formatted disk image directory item:
$item->print();
# Validate item data against all possible errors:
my $is_valid = $item->validate();
# Check if directory item contains information about the actual disk file:
my $is_empty = $item->empty();
# Check if directory item is writable and can be replaced by any new file:
my $is_writable = $item->writable();
# Clone disk directory item:
my $clone = $item->clone();
# Check if filename matches given CBM ASCII pattern:
my $is_matched = $item->match_name($petscii_pattern);
# Convert any given file type into its three-letter printable string representation:
my $string = D64::Disk::Dir::Item->type_to_string($type);
=head1 DESCRIPTION
C<D64::Disk::Dir::Item> provides a helper class for C<D64::Disk::Layout> module, enabling users to manipulate individual directory entries in an object oriented way without the hassle of worrying about the meaning of individual bits and bytes describ...
=head1 METHODS
=cut
use bytes;
use strict;
$item->type($type);
The following file type constants are the only valid values that may be used to update current item type: C<$T_DEL>, C<$T_SEQ>, C<$T_PRG>, C<$T_USR>, C<$T_REL>, C<$T_CBM>, and C<$T_DIR>.
=cut
sub type {
my ($self, $type) = @_;
if (defined $type) {
if (ref $type) {
die q{Invalid file type constant (scalar value expected)};
}
unless ($self->is_int($type)) {
die q{Invalid file type constant (type constant expected)};
}
if ($type - ($type & 0b1111)) {
die q{Invalid file type constant (only bits 0-3 can be set)};
}
my @valid_values = (0b000, 0b001, 0b010, 0b011, 0b100, 0b101, 0b110);
unless (grep { $_ == $type } @valid_values) {
die q{Illegal file type constant};
}
$self->[$I_TYPE] = chr ((ord ($self->[$I_TYPE]) & 0b11110000) | $type);
}
return ord ($self->[$I_TYPE]) & 0b1111;
}
=head2 closed
Get "closed" flag:
my $is_closed = $item->closed();
Returns true when "closed" flag is set, and false otherwise.
Set "closed" flag:
$item->closed($is_closed);
When "closed" flag is not set, it produces "*", or "splat" files.
=cut
sub closed {
my ($self, $is_closed) = @_;
if (defined $is_closed) {
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();
Set track location of first sector of file:
$item->track($track);
=cut
sub track {
my ($self, $track) = @_;
if (defined $track) {
unless ($self->_is_valid_data_type($track)) {
die sprintf q{Invalid type (%s) of track location of first sector of file (single byte expected)}, $self->_dump($track);
}
unless ($self->_is_valid_number_value($track)) {
die sprintf q{Invalid value (%s) of track location of first sector of file (single byte expected)}, $self->_dump($track);
}
$self->[$I_TRACK] = pack 'C', $track;
}
return unpack 'C', $self->[$I_TRACK];
}
=head2 sector
Get sector location of first sector of file:
my $sector = $item->sector();
Set sector location of first sector of file:
$item->sector($sector);
=cut
sub sector {
my ($self, $sector) = @_;
if (defined $sector) {
unless ($self->_is_valid_data_type($sector)) {
die sprintf q{Invalid type (%s) of sector location of first sector of file (single byte expected)}, $self->_dump($sector);
}
unless ($self->_is_valid_number_value($sector)) {
die sprintf q{Invalid value (%s) of sector location of first sector of file (single byte expected)}, $self->_dump($sector);
}
$self->[$I_SECTOR] = pack 'C', $sector;
}
return unpack 'C', $self->[$I_SECTOR];
}
}
my $size_lo = $size % 0x0100;
my $size_hi = int($size / 0x0100);
$self->[$I_SIZE_LO] = pack 'C', $size_lo;
$self->[$I_SIZE_HI] = pack 'C', $size_hi;
}
my $size_lo = unpack 'C', $self->[$I_SIZE_LO];
my $size_hi = unpack 'C', $self->[$I_SIZE_HI];
# Since a scalar value of a double type (NV) will always be loaded as the result
# of multiplication in Perl 5.6.2, we need to force an integer value into an SV:
return $self->set_iok($size_lo + 256 * $size_hi);
}
=head2 exact_size
Get exact file size in bytes:
my $exact_size = $item->exact_size(disk_image => $disk_image_ref);
Warning! Do not use! This method has not been implemented (yet)!
=cut
sub exact_size {
my ($self) = @_;
# TODO: add another input parameter: required provision of a D64 disk image data...
die q{Not yet implemented};
}
=head2 print
Print out formatted disk image directory item:
$item->print(fh => $fh, as_petscii => $as_petscii, verbose => $verbose);
C<fh> defaults to the standard output. C<as_petscii> defaults to false (meaning that ASCII characters will be printed out by default). C<verbose> defaults to false (changing it to true will additionally print out file's track and sector values).
=cut
sub print {
my ($self, %args) = @_;
my $fh = $args{fh};
my $as_petscii = $args{as_petscii};
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
Validate item data against all possible errors:
my $is_valid = $item->validate();
Returns true when all item data is valid, and false otherwise.
=cut
sub validate {
my ($self) = @_;
my $test = $self->new();
my $is_valid = try {
my $data = $self->data();
die unless defined $data;
$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();
die unless defined $name;
$test->name($name);
if ($self->type() eq $T_REL) {
my $side_track = $self->side_track();
die unless defined $side_track;
$test->side_track($side_track);
my $side_sector = $self->side_sector();
die unless defined $side_sector;
$test->side_sector($side_sector);
my $record_length = $self->record_length();
die unless defined $record_length;
$test->record_length($record_length);
}
my $size = $self->size();
die unless defined $size;
$test->size($size);
1;
}
catch {
0;
};
return $is_valid;
}
=head2 empty
Check if directory item contains information about the actual disk file:
my $is_empty = $item->empty();
True value will be returned when directory item object is empty.
=cut
sub empty {
my ($self) = @_;
my $is_empty = not grep { ord ($_) != 0x00 } @{$self};
return $is_empty;
}
=head2 writable
( run in 0.928 second using v1.01-cache-2.11-cpan-5511b514fd6 )