File Coverage

blib/lib/D64/Disk/Dir/Item.pm

Criterion	Covered	Total	%
statement	305	317	96.2
branch	152	170	89.4
condition	33	45	73.3
subroutine	42	43	97.6
pod	19	24	79.1
total	551	599	91.9

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 provides a helper class for C 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 describing each entry in a disk directory. The whole family of C modules has been implemented in pure Perl as an alternative to Per Olofsson's "diskimage.c" library originally written in an ANSI C.

=head1 METHODS

=cut

use bytes;
use strict;
use utf8;
use warnings;

our $VERSION = '0.07';

use parent 'Clone';

use Data::Dumper;
use Readonly;
use Scalar::Util qw(looks_like_number);
use Text::Convert::PETSCII qw(:convert);
use Try::Tiny;

require XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);

# Setup package constant names:
our (
    # File type constant names:
    $T_DEL, $T_SEQ, $T_PRG, $T_USR, $T_REL, $T_CBM, $T_DIR,

    # Data offset constant names:
    $I_TYPE, $I_NAME, $I_CLOSED, $I_LOCKED,
    $I_TRACK, $I_SECTOR, $I_SIZE_LO, $I_SIZE_HI,
    $I_SIDE_TRACK, $I_SIDE_SECTOR, $I_RECORD_LENGTH,

    # Other package constant names:
    $ITEM_SIZE,
);

# File type constant values:
my %file_type_constants = (
    T_DEL => 0b000,
    T_SEQ => 0b001,
    T_PRG => 0b010,
    T_USR => 0b011,
    T_REL => 0b100,
    T_CBM => 0b101,
    T_DIR => 0b110,
);

# Data offset constant values:
my %data_offset_constants = (
    I_TYPE          => 0x00,
    I_CLOSED        => 0x00,
    I_LOCKED        => 0x00,
    I_TRACK         => 0x01,
    I_SECTOR        => 0x02,
    I_NAME          => 0x03,
    I_SIDE_TRACK    => 0x13,
    I_SIDE_SECTOR   => 0x14,
    I_RECORD_LENGTH => 0x15,
    I_SIZE_LO       => 0x1c,
    I_SIZE_HI       => 0x1d,
);

# Other package constant values:
my %other_package_constants = (
    ITEM_SIZE => 0x1e,
);

# Setup package constant values:
my %all_constants = (%file_type_constants, %data_offset_constants, %other_package_constants);
while (my ($name, $value) = each %all_constants) {
    if ($] < 5.008) {
        eval sprintf q{
            Readonly \\$%s => %d;
        }, $name, $value;
    }
    else {
       eval sprintf q{
            Readonly $%s => %d;
        }, $name, $value;
    }
}

use base qw(Exporter);
our %EXPORT_TAGS = ();
$EXPORT_TAGS{'types'} = [ qw($T_DEL $T_SEQ $T_PRG $T_USR $T_REL $T_CBM $T_DIR) ];
$EXPORT_TAGS{'all'} = [ @{$EXPORT_TAGS{'types'}} ];
our @EXPORT_OK = ( @{$EXPORT_TAGS{'all'}} );
our @EXPORT = qw();

=head2 new

Create an instance of a C class as an empty directory entry:

  my $item = D64::Disk::Dir::Item->new();

Create an instance of a C class providing 30 bytes of data retrieved from a disk directory:

  my $item = D64::Disk::Dir::Item->new(data => $data);
  my $item = D64::Disk::Dir::Item->new(data => \@data);

=cut

sub new {
    my ($this) = shift;
    my $class = ref ($this) || $this;
    my $object = $class->_init();
    my $self = bless $object, $class;
    $self->data(@_) if @_;
    return $self;
}

sub _init {
    my ($class) = @_;
    my @object = map { chr 0x00 } (0x01 .. $ITEM_SIZE);
    return \@object;
}

=head2 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 retrieved from a disk directory:

  $item->data($data);

Update item given array with 30 bytes of data retrieved from a disk directory:

  $item->data(@data);
  $item->data(\@data);

=cut

sub data {
    my ($self, @args) = @_;

    if (scalar @args > 0) {
        if (scalar @args == 1) {
            my ($arg) = @args;
            if (ref $arg eq 'ARRAY') {
                @args = @{$arg};
            }
        }

        if (scalar @args == 1) {
            my ($arg) = @args;
            unless (ref $arg) {
                unless (length $arg == 30) {
                    die q{Unable to set directory item data: Invalid length of data};
                }
                @{$self} = split //, $arg;
            }
            else {
                die q{Unable to set directory item data: Invalid arguments given};
            }
        }
        elsif (scalar @args == 30) {
            for (my $i = 0; $i < @args; $i++) {
                my $byte_value = $args[$i];
                unless ($self->_is_valid_data_type($byte_value)) {
                    die sprintf q{Invalid data type at offset %d (%s)}, $i, ref $args[$i];
                }
                unless ($self->_is_valid_byte_value($byte_value)) {
                    die sprintf q{Invalid byte value at offset %d ($%x)}, $i, $byte_value;
                }
            }
            @{$self} = @args;
        }
        else {
            die q{Unable to set directory item data: Invalid amount of data};
        }
    }

    return unless defined wantarray;
    return wantarray ? @{$self} : join '', @{$self};
}

sub _is_valid_data_type {
    my ($self, $byte_value) = @_;

    unless (ref $byte_value) {
        return 1;
    }

    return 0;
}

sub _is_valid_byte_value {
    my ($self, $byte_value) = @_;

    if (length ($byte_value) == 1 && ord ($byte_value) >= 0x00 && ord ($byte_value) <= 0xff) {
        return 1;
    }

    return 0;
}

sub _is_valid_number_value {
    my ($self, $number_value) = @_;

    if ($self->is_int($number_value) && $number_value >= 0x00 && $number_value <= 0xff) {
        return 1;
    }

    return 0;
}

sub is_valid_string_value {
    my ($self, $string_value) = @_;

    no bytes;
    unless (grep { ord ($_) < 0x00 || ord ($_) > 0xff } split //, $string_value) {
        return 1;
    }

    return 0;
}

=head2 bytes

C is simply a convenient alias for C.

Fetch item data as a scalar of 30 bytes:

  my $bytes = $item->bytes();

Fetch item data as an array of 30 bytes:

  my @bytes = $item->bytes();

Update item providing 30 bytes of scalar data retrieved from a disk directory:

  $item->bytes($bytes);

Update item given array with 30 bytes of data retrieved from a disk directory:

  $item->bytes(@bytes);
  $item->bytes(\@bytes);

=cut

*bytes = \&data;

=head2 type

Get the actual file type:

  my $type = $item->type();

Set the actual file type:

  $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];
}

=head2 name

Get 16 character filename:

  my $name = $item->name();

Returned value is a CBM ASCII string. Unless specified otherwise, it will be padded with C<$A0>.

Get filename (without C<$A0> padding):

  my $name = $item->name(padding_with_a0 => 0);

C input parameter defaults to C<1>. That means every time filename is fetched from a C object, length of a retrieved string will be 16 characters.

Set 16 character filename:

  $item->name($name);

Input name parameter is expected to be CBM ASCII string. Unless specified otherwise, it will be padded with C<$A0>.

Set 16 character filename (without C<$A0> padding):

  $item->name($name, padding_with_a0 => 0);

C input parameter defaults to C<1>. That means every time filename is written into a C object, it gets complemented with additional C<$A0> bytes up to the maximum length of a filename, which is 16 bytes. Thus by default 16 characters of filename data are always stored in a disk directory item.

In order to convert a PETSCII string to an ASCII string and vice versa, use the following subroutines provided by C module:

  use Text::Convert::PETSCII qw/:all/;

  my $ascii_name = petscii_to_ascii($petscii_name);
  my $petscii_name = ascii_to_petscii($ascii_name);

See L module description for more details on ASCII/PETSCII text conversion.

=cut

sub name {
    my ($self, @options) = @_;

    my $name;
    if (scalar (@options) % 2 == 1) {
        $name = shift @options;
    }
    my %options = @options;
    $options{padding_with_a0} = 1 if not exists $options{padding_with_a0};

    if (defined $name) {
        unless ($self->is_str($name)) {
            die sprintf q{Invalid type (%s) of filename (string value expected)}, $self->_dump($name);
        }
        if (length $name > 16) {
            die sprintf q{Too long (%s) filename (maximum 16 PETSCII characters allowed)}, $self->_dump($name);
        }
        unless ($self->is_valid_string_value($name)) {
            die sprintf q{Invalid string (%s) of filename (PETSCII string expected)}, $self->_dump($name);
        }
        if ($options{padding_with_a0}) {
            $self->[$I_NAME + $_] = chr 0xa0 for (0 .. 15);
        }
        for (my $i = 0; $i < length $name; $i++) {
            $self->[$I_NAME + $i] = substr $name, $i, 1;
        }
    }

    my $name_length = $I_NAME + 15;
    unless ($options{padding_with_a0}) {
        while (ord ($self->[$name_length]) == 0xa0 && $name_length >= $I_NAME) {
            $name_length--;
        }
    }
    $name = join '', @{$self}[$I_NAME..$name_length];

    return $name;
}

=head2 side_track

Get track location of first side-sector block:

  my $side_track = $item->side_track();

A track location of first side-sector block is returned for relative files only, an undefined value otherwise.

Set track location of first side-sector block:

  $item->side_track($side_track);

When attempting to assign track location of first side-sector block for a non-relative file, an exception will be thrown.

=cut

sub side_track {
    my ($self, $side_track) = @_;

    if (defined $side_track) {
        unless ($self->type() eq $T_REL) {
            die sprintf q{Illegal file type ('%s') encountered when attempting to set track location of first side-sector block ('rel' files only)}, $self->type_to_string($self->type());
        }
        unless ($self->_is_valid_data_type($side_track)) {
            die sprintf q{Invalid type (%s) of track location of first side-sector block of file (single byte expected)}, $self->_dump($side_track);
        }
        unless ($self->_is_valid_number_value($side_track)) {
            die sprintf q{Invalid value (%s) of track location of first side-sector block of file (single byte expected)}, $self->_dump($side_track);
        }
        $self->[$I_SIDE_TRACK] = pack 'C', $side_track;
    }

    return unless $self->type() eq $T_REL;

    return unpack 'C', $self->[$I_SIDE_TRACK];
}

=head2 side_sector

Get sector location of first side-sector block:

  my $side_sector = $item->side_sector();

A sector location of first side-sector block is returned for relative files only, an undefined value otherwise.

Set sector location of first side-sector block:

  $item->side_sector($side_sector);

When attempting to assign sector location of first side-sector block for a non-relative file, an exception will be thrown.

=cut

sub side_sector {
    my ($self, $side_sector) = @_;

    if (defined $side_sector) {
        unless ($self->type() eq $T_REL) {
            die sprintf q{Illegal file type ('%s') encountered when attempting to set sector location of first side-sector block ('rel' files only)}, $self->type_to_string($self->type());
        }
        unless ($self->_is_valid_data_type($side_sector)) {
            die sprintf q{Invalid type (%s) of sector location of first side-sector block of file (single byte expected)}, $self->_dump($side_sector);
        }
        unless ($self->_is_valid_number_value($side_sector)) {
            die sprintf q{Invalid value (%s) of sector location of first side-sector block of file (single byte expected)}, $self->_dump($side_sector);
        }
        $self->[$I_SIDE_SECTOR] = pack 'C', $side_sector;
    }

    return unless $self->type() eq $T_REL;

    return unpack 'C', $self->[$I_SIDE_SECTOR];
}

=head2 record_length

Get relative file record length:

  my $record_length = $item->record_length();

A relative file record length is returned for relative files only, an undefined value otherwise.

Get relative file record length (relative file only, maximum value 254):

  $item->record_length($record_length);

When attempting to assign relative file record length for a non-relative file or a record length greater than 254, an exception will be thrown.

=cut

sub record_length {
    my ($self, $record_length) = @_;

    if (defined $record_length) {
        unless ($self->type() eq $T_REL) {
            die sprintf q{Illegal file type ('%s') encountered when attempting to set record length ('rel' files only)}, $self->type_to_string($self->type());
        }
        unless ($self->_is_valid_data_type($record_length)) {
            die sprintf q{Invalid type (%s) of relative file record length (single byte expected)}, $self->_dump($record_length);
        }
        unless ($self->_is_valid_number_value($record_length)) {
            die sprintf q{Invalid value (%s) of relative file record length (single byte expected)}, $self->_dump($record_length);
        }
        unless ($record_length >= 0x00 && $record_length < 0xff) {
            die sprintf q{Invalid value (%s) of relative file record length (maximum allowed value 254)}, $self->_dump($record_length);
        }
        $self->[$I_RECORD_LENGTH] = pack 'C', $record_length;
    }

    return unless $self->type() eq $T_REL;

    return unpack 'C', $self->[$I_RECORD_LENGTH];
}

=head2 size

Get file size in sectors:

  my $size = $item->size();

The approximate file size in bytes is <= number_of_sectors * 254.

Set file size in sectors:

  $item->size($size);

=cut

sub size {
    my ($self, $size) = @_;

    if (defined $size) {
        unless ($self->_is_valid_data_type($size) && $self->is_int($size)) {
            die sprintf q{Invalid type (%s) of file size (integer value expected)}, $self->_dump($size);
        }
        unless ($size >= 0x0000 && $size <= 0xffff) {
            die sprintf q{Invalid value (%s) of file size (maximum allowed value %d)}, $self->_dump($size), 0xffff;
        }

        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);

C defaults to the standard output. C defaults to false (meaning that ASCII characters will be printed out by default).

=cut

sub print {
    my ($self, %args) = @_;

    my $fh = $args{fh};
    my $as_petscii = $args{as_petscii};

    $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 $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
        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 $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
        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

Check if slot occupied by this item in a disk directory is writable and can be replaced by any new file that would be written into disk:

  my $is_writable = $item->writable();

True value will be returned when directory item object is writable.

=cut

sub writable {
    my ($self) = @_;

    my $is_writable = !$self->closed() && $self->type() eq $T_DEL;

    return $is_writable;
}

=head2 clone

Clone disk directory item:

  my $clone = $item->clone();

=head2 match_name

Check if filename matches given CBM ASCII pattern:

  my $is_matched = $item->match_name($petscii_pattern);

C<$petscii_pattern> is expected to be a CBM ASCII string containing optional wildcard characters. The following wildcards are allowed/recognized:

=over

=item *
An asterisk C<*> character following any program name will yield successful match if filename is starting with that name.

=item *
A question mark C character used as a wildcard will match any character in a filename.

=back

=cut

sub match_name {
    my ($self, $petscii_pattern) = @_;

    my $name = $self->name(padding_with_a0 => 0);

    my @name = split //, $name;
    my @pattern = split //, $petscii_pattern;

    for (my $i = 0; $i < @pattern; $i++) {
        my $match_pattern = ord $pattern[$i];
        if ($match_pattern == 0x2a) {
            return 1;
        }
        my $character = $name[$i];
        unless (defined $character && $match_pattern == 0x3f) {
            if (!defined $character || ord $character != $match_pattern) {
                return 0;
            }
        }
    }

    if (@name == @pattern) {
        return 1;
    }

    return 0;
}

=head2 type_to_string

Convert given file type into its three-letter printable ASCII/PETSCII string representation:

  my $string = D64::Disk::Dir::Item->type_to_string($type, $as_petscii);

C defaults to false (meaning that ASCII characters will be returned by default).

=cut

sub type_to_string {
    my ($this, $type, $as_petscii) = @_;

    unless ($as_petscii) {
        my @mapping = (
            'del', # $T_DEL
            'seq', # $T_SEQ
            'prg', # $T_PRG
            'usr', # $T_USR
            'rel', # $T_REL
            'cbm', # $T_CBM
            'dir', # $T_DIR
        );

        if ($type >= 0 && $type < @mapping) {
            return $mapping[$type]
        }
        else {
            return '???';
        }
    }
    else {
        my @mapping = (
            '44454c', # $T_DEL
            '534551', # $T_SEQ
            '505247', # $T_PRG
            '555352', # $T_USR
            '52454c', # $T_REL
            '43424d', # $T_CBM
            '444952', # $T_DIR
        );

        if ($type >= 0 && $type < @mapping) {
            return pack 'H*', $mapping[$type];
        }
        else {
            return pack 'H*', '3f3f3f';
        }
    }
}

sub _dump {
    my ($self, $value) = @_;

    my $dump = Data::Dumper->new([$value])->Indent(0)->Terse(1)->Deepcopy(1)->Sortkeys(1)->Dump();

    return $dump;
}

sub is_int {
    my ($this, $var) = @_;

    return _is_int($var);
}

sub is_str {
    my ($this, $var) = @_;

    return _is_str($var);
}

sub magic_to_int {
    my ($this, $magic) = @_;

    return _magic_to_int($magic);
}

sub set_iok {
    my ($self, $var) = @_;

    my $var_iok = _set_iok($var);

    return $var_iok;
}

=head1 BUGS

There are no known bugs at the moment. Please report any bugs or feature requests.

=head1 CAVEATS

No GEOS-specific properties are supported by accessor methods of this module. Due to low popularity of GEOS system and rare amount of GEOS D64 disk images available on the net, I have decided to intentionally skip implementation of C file type format here. Thus all the information needed for the windowing system (icon, window position, creation time/date) cannot be right now accessed conveniently without the knowledge of specific C format details.

=head1 EXPORT

C exports nothing by default.

You may request the import of file type constants (C<$T_DEL>, C<$T_SEQ>, C<$T_PRG>, C<$T_USR>, C<$T_REL>, C<$T_CBM>, and C<$T_DIR>) individually. All of these constants can be explicitly imported from C by using it with the ":types" tag. All constants can be explicitly imported from C by using it with the ":all" tag.

=head1 SEE ALSO

L, L, L.

=head1 AUTHOR

Pawel Krol, [e-mail].

=head1 VERSION

Version 0.07 (2013-03-08)

=head1 COPYRIGHT AND LICENSE

Copyright 2013 by Pawel Krol .

This library is free open source software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.6 or, at your option, any later version of Perl 5 you may have available.

PLEASE NOTE THAT IT COMES WITHOUT A WARRANTY OF ANY KIND!

=cut

1;