File Coverage

blib/lib/Mac/AppleSingleDouble.pm

Criterion	Covered	Total	%
statement	133	206	64.5
branch	19	34	55.8
condition			n/a
subroutine	20	28	71.4
pod	17	17	100.0
total	189	285	66.3

# Mac::AppleSingleDouble.pm, (C) 2001 Jamie Flournoy ([e-mail]).

package Mac::AppleSingleDouble;
require 5;
use FileHandle;

$Mac::AppleSingleDouble::VERSION='1.0';

# default Finder colors for label values.
%labelcolors = (0 => 'Black',
		1 => 'Brown',
		2 => 'Green',
		3 => 'Blue',
		4 => 'Cyan',
		5 => 'Pink',
		6 => 'Red',
		7 => 'Orange');

# default Finder names for label values.
%labelnames = (0 => 'None',
	       1 => 'Project 2',
	       2 => 'Project 1',
	       3 => 'Personal',
	       4 => 'Cool',
	       5 => 'In Progress',
	       6 => 'Hot',
	       7 => 'Essential');

%entryids = (1 => 'Data Fork',
	     2 => 'Resource Fork',
	     3 => 'Real Name',
	     4 => 'Comment',
	     5 => 'Icon, B&W',
	     6 => 'Icon, Color',
	     8 => 'File Dates Info',
	     9 => 'Finder Info',
	     10 => 'Macintosh File Info',
	     11 => 'ProDOS File Info',
	     12 => 'MS-DOS File Info',
	     13 => 'Short Name',
	     14 => 'AFP File Info',
	     15 => 'Directory ID');

# Magic number values mapped to file format (AppleSingle or
# AppleDouble). Any other value means it's not an AppleSingle or
# AppleDouble file.
%formats = ( pack('H8', "00051600") => 'AppleSingle',
	     pack('H8', "00051607") => 'AppleDouble');

sub new
{
    my $class = shift;
    my $filename = shift;
    if (!defined($filename))
    {
	die "The constructor (new) requires a filename as an argument!";
    }
    my $this = {};        # instances are based on hashes
    bless $this, $class;  # now $this is an instance of $class
    $this->_initialize($filename);
    return $this;
}

sub DESTROY
{
    my $this = shift;
    $this->close();
}

sub close
{
    my $this = shift;
    if ($this->{'_filehandle'})
    {
	CORE::close $this->{'_filehandle'};
	undef($this->{'_filehandle'});
    }
}

sub get_finder_info
{
    my $this = shift;
    $this->_require_applesingledouble();
    if (!defined($this->{'_finder_info'}))
    {
	$this->_parse_finder_info($this->get_entry(9));
    }
    return $this->{'_finder_info'}
}

sub get_entry
{
    my $this = shift;
    my $entryid = shift;
    $this->_require_applesingledouble();
    my $entry = $this->{'_entries'}->{$entryid};
    if (!defined($entry))
    {
	$entry = $this->_get_entry_from_file($entryid);
    }
    if ($this->{'_cache_entries'})
    {
	$this->{'_entries'}->{$entryid} = $entry;
    }
    return $entry;
}

sub get_file_format
{
    my $this = shift;
    if (!defined($this->{'_magicno'}))
    {
	$this->_parse_header();
    }
    my $format = $formats{$this->{'_magicno'}};
    if (!defined($format)) { $format = 'Plain'; }
    return $format;
}

sub is_applesingle
{
    my $this = shift;
    return ($this->get_file_format() eq 'AppleSingle');
}

sub is_appledouble
{
    my $this = shift;
    return $this->get_file_format() eq 'AppleDouble';
}

sub preload_entire_file
{
    my $this = shift;
    $this->_require_applesingledouble();
    $this->cache_entries(1);
    $this->get_all_entries();
    $this->close();
}

sub cache_entries
{
    my $this = shift;
    my $val = shift;
    if (defined($val))
    {
	$this->{'_cache_entries'} = $val;
    }
    return $this->{'_cache_entries'};
}


sub get_entry_descriptors
{
    my $this = shift;
    $this->_require_applesingledouble();
    return $this->{'_descriptors'};
}

sub get_all_entries
{
    my $this = shift;
    $this->_require_applesingledouble();
    my %entries = ();
    my $descriptors = $this->get_entry_descriptors();
    foreach $entryid (keys( %{$descriptors} ))
    {
	$entries{$entryid} = $this->get_entry($entryid);
    }
    return \%entries;
}

sub set_labelnames
{
    my $this = shift;
    my $new_labelnames = shift;
    $this->{'_labelnames'} = $new_labelnames;
}

sub set_labelcolors
{
    my $this = shift;
    my $new_labelcolors = shift;
    $this->{'_labelcolors'} = $new_labelcolors;
}

sub dump
{
    my $this = shift;
    $this->dump_header();
    print "\n";
    $this->dump_entries();
}

sub dump_header
{
    my $this = shift;
    $this->_require_applesingledouble();
    print "Dumping " . $this->get_file_format() . " file '" . $this->{'_filename'} . "':\n";
    if ($this->get_file_format() eq 'Plain')
    {
	print "Can't dump a file unless it's in AppleSingle or AppleDouble format.\n";
	return;
    }
    print "File is " . $this->{'_size'} . " bytes long.\n";
    print "Magic Number is " . unpack('H8', $this->{'_magicno'}) . ".\n";
    print "Version Number is " . unpack('H8', $this->{'_version'}) . ".\n";

    print "Entry descriptor table:\n";
    my $descriptors = $this->{'_descriptors'};
    my $d = $descriptors; # make next line look purty
    foreach $entryid (sort {$d->{$a}->{'Offset'} <=> $d->{$b}->{'Offset'} } keys( %{$descriptors} ))
    {
	print "Offset: " . $descriptors->{$entryid}->{'Offset'} . "\t";
	print "Length: " . $descriptors->{$entryid}->{'Length'} . "\t";
	my $entryidname = $entryids{$entryid};
	if (!defined($entryidname)) { $entryidname = '???'; }
	print "EntryID: $entryid ($entryidname)\n";
    }
}

sub dump_entries
{
    my $this = shift;

    my $descriptors = $this->{'_descriptors'};
    foreach $entryid (sort {$descriptors->{$a}->{'Offset'} <=> $descriptors->{$b}->{'Offset'} } keys( %{$descriptors} ))
    {
	$this->dump_entry($entryid);
    }
}

sub dump_entry
{
    my $this = shift;
    my $entryid = shift;

    my $entryidname = $entryids{$entryid};
    if (!defined($entryidname)) { $entryidname = '???'; }
    print "EntryID: $entryid ($entryidname)\n";
    print $this->_hex_dump($this->get_entry($entryid)) . "\n";
}

sub _hex_dump
{
    my $this = shift;
    my $bytes = shift;

    my $length = length($bytes);
    my $hexdump = '';
    # this code is based on a script by David Thorburn-Gundlach
    for ($p = 0; $p < $length; $p += 16)
    {
	$byteno = sprintf('%8lx', $p);
	$byteno =~ s/ /0/g;
	$byteno =~ s/^(....)/$1 /g;
	$asc_string = substr($bytes, $p, 16);
	$hex_string = unpack('H32', $asc_string);
	$hex_string =~ s/(..)/$1 /g;
	$pad = ' ' x (3*(16-length($asc_string)));
	$asc_string =~ s/([\00-\37,\177])/./g;
	$hexdump .= "$byteno:  $hex_string$pad  $asc_string\n";
    }
    return $hexdump;
}

sub _initialize
{
    my $this = shift;
    $this->{'_filename'} = shift;
    if (!-f $this->{'_filename'})
    {
	die "'$this->{'_filename'}' is not a file!";
    }
    $this->{'_entries'} = {};
    $this->{'_labelnames'} = \%labelnames;
    $this->{'_labelcolors'} = \%labelcolors;
}

sub _read_header
{
    my $this = shift;
    my $header_raw;

    my $fh = new FileHandle;
    $fh->open($this->{'_filename'});
    ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat($fh);
    $this->{'_size'} = $size;
    read($fh, $header_raw, 26);
    # not closed here - must use $this->close() later;
    $this->{'_filehandle'} = $fh;

    return $header_raw;
}

sub _parse_header
{
    my $this = shift;
    return if defined($this->{'_magicno'}); # already did it

    $header_raw = $this->_read_header();

    $this->{'_magicno'} = substr($header_raw, 0,4);
    if ($this->get_file_format() ne 'Plain') # will not infinitely recurse because we just set _magicno
    {
	$this->{'_version'} = substr($header_raw, 4,4);
	my $entrycount = unpack('n', substr($header_raw, 24,2));
	my $descriptors_raw = $this->_read_descriptors($entrycount);
	$this->_parse_descriptors($entrycount, $descriptors_raw);
    }
}

sub _read_descriptors
{
    my $this = shift;
    my $entrycount = shift;
    my $descriptors_raw;
    # this must be called after _read_header!
    seek($this->{'_filehandle'}, 26, 0);
    read($this->{'_filehandle'}, $descriptors_raw, $entrycount * 12);
    return $descriptors_raw;
}

sub _parse_descriptors
{
    my $this = shift;
    my $entrycount = shift;
    my $descriptors_raw = shift;
    my(%descriptors);

    for($i = 0; $i < $entrycount; $i++)
    {
	my(%descriptor);
	$entrystart = (12 * $i);
	$descriptor{'EntryID'} = unpack('N', substr($descriptors_raw, $entrystart, 4));
	$descriptor{'Offset'} = unpack('N', substr($descriptors_raw, $entrystart + 4, 4));
	$descriptor{'Length'} = unpack('N', substr($descriptors_raw, $entrystart + 8, 4));

	# store in the descriptors hash keyed by entry ID
	$descriptors{$descriptor{'EntryID'}} = \%descriptor;
    }

    $this->{'_descriptors'} = \%descriptors;
}

sub _parse_finder_info
{
    my $this = shift;
    my $finderinfo_raw = shift;
    my(%finderinfo);

    # based on page 7-76 of Inside Macintosh: Finder Interface
    $finderinfo{'Type'} = substr($finderinfo_raw, 0, 4);
    $finderinfo{'Creator'} = substr($finderinfo_raw, 4, 4);
    $finderinfo{'Flags'} = unpack('n', substr($finderinfo_raw, 8, 2));
    $finderinfo{'Location'} = unpack('nn', substr($finderinfo_raw, 10, 4));
    $finderinfo{'Fldr'} = unpack('n', substr($finderinfo_raw, 14, 2));

    # Finder Flags
    $flagbits = unpack('B8', substr($finderinfo_raw, 8, 1)) .unpack('B8', substr($finderinfo_raw, 9, 1)) ;
    #print "flagbits is $flagbits\n";
    $finderinfo{'Label'} = unpack('C', pack('B8', '0'x5 . substr($flagbits, 12, 3)));
    $finderinfo{'Color'} = $finderinfo{'Label'};
    $finderinfo{'IsOnDesk'} = substr($flagbits, 15, 1);
    $finderinfo{'IsShared'} = substr($flagbits, 9, 1);
    $finderinfo{'HasBeenInited'} = substr($flagbits, 7, 1);
    $finderinfo{'HasCustomIcon'} = substr($flagbits, 5, 1);
    $finderinfo{'IsStationery'} = substr($flagbits, 4, 1);
    $finderinfo{'NameLocked'} = substr($flagbits, 3, 1);
    $finderinfo{'HasBundle'} = substr($flagbits, 2, 1);
    $finderinfo{'IsInvisible'} = substr($flagbits, 1, 1);
    $finderinfo{'IsAlias'} = substr($flagbits, 0, 1);

    # Extended Finder Info
    $finderinfo{'IconID'} = unpack('n', substr($finderinfo_raw, 16, 2));
    $finderinfo{'Script'} = unpack('c', substr($finderinfo_raw, 24, 1));
    $finderinfo{'XFlags'} = unpack('B8', substr($finderinfo_raw, 25, 1));
    $finderinfo{'Comment'} = unpack('n', substr($finderinfo_raw, 26, 2));
    $finderinfo{'PutAway'} = unpack('N', substr($finderinfo_raw, 28, 4));

    my $labelcolor = $this->{'_labelcolors'}->{$finderinfo{'Label'}};
    my $labelname = $this->{'_labelnames'}->{$finderinfo{'Label'}};
    $finderinfo{'LabelColor'} = defined($labelcolor)? $labelcolor : '(no labelcolor provided)';
    $finderinfo{'LabelName'} = defined($labelname)? $labelname : '(no labelname provided)';

    $this->{'_finder_info'} = \%finderinfo;
}

sub _get_entry_from_file
{
    my $this = shift;
    my $entryid = shift;
    my $descriptors = $this->get_entry_descriptors();

    my $descriptor = $descriptors->{$entryid};
    my $entry;
    seek($this->{'_filehandle'}, $descriptor->{'Offset'}, 0);
    read($this->{'_filehandle'}, $entry, $descriptor->{'Length'});
    return $entry;
}

sub _require_applesingledouble
{
    my $this = shift;
    if ($this->get_file_format() eq 'Plain')
    {
	die "File '" . $this->{'_filename'} . "' is not in AppleSingle or AppleDouble format!";
    }
}

1;
__END__