—# Mac::AppleSingleDouble.pm, (C) 2001 Jamie Flournoy (jamie@white-mountain.org).
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();
"\n"
;
$this
->dump_entries();
}
sub
dump_header
{
my
$this
=
shift
;
$this
->_require_applesingledouble();
"Dumping "
.
$this
->get_file_format() .
" file '"
.
$this
->{'_filename
'} . "'
:\n";
if
(
$this
->get_file_format() eq
'Plain'
)
{
"Can't dump a file unless it's in AppleSingle or AppleDouble format.\n"
;
return
;
}
"File is "
.
$this
->{
'_size'
} .
" bytes long.\n"
;
"Magic Number is "
.
unpack
(
'H8'
,
$this
->{
'_magicno'
}) .
".\n"
;
"Version Number is "
.
unpack
(
'H8'
,
$this
->{
'_version'
}) .
".\n"
;
"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
} ))
{
"Offset: "
.
$descriptors
->{
$entryid
}->{
'Offset'
} .
"\t"
;
"Length: "
.
$descriptors
->{
$entryid
}->{
'Length'
} .
"\t"
;
my
$entryidname
=
$entryids
{
$entryid
};
if
(!
defined
(
$entryidname
)) {
$entryidname
=
'???'
; }
"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
=
'???'
; }
"EntryID: $entryid ($entryidname)\n"
;
$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__
=head1 NAME
Mac::AppleSingleDouble - Read Mac files in AppleSingle or AppleDouble format.
=head1 SYNOPSIS
use Mac::AppleSingleDouble;
$foo = new Mac::AppleSingleDouble(shift);
$finder_info = $foo->get_finder_info();
print "The file Type is: $finder_info->{'Type'}\n";
print "The file Creator is: $finder_info->{'Creator'}\n";
print "The Finder label color is: $finder_info->{'LabelColor'}\n";
$foo->close();
=head1 REQUIRES
Perl5 (tested with 5.005_03; may work with older versions of Perl 5), the FileHandle module.
=head1 EXPORTS
Nothing.
=head1 DESCRIPTION
Mac::AppleSingleDouble is a class which knows how to decode the
AppleSingle and AppleDouble file formats. An instance of
Mac::AppleSingleDouble represents one file on disk.
The structure of Macintosh files is unlike the structure of files on
non-Macintosh operating systems. Most operating systems represent a
file as a filename (with the file type appended as a suffix), a few
attribute bits, and a single chunk of data. Macintosh files consist of
a filename, attribute bits, a four-character file type code ('TEXT',
'APPL', 'JPEG', 'PDF ', etc.), a four-character file creator code
('MSWD' for Microsoft Word, '8BIM' for Photoshop, 'SIT!' for StuffIt,
etc.), a chunk of unstructured data called the "Data Fork", and a
chunk of structured data called the "Resource Fork". In order to store
Macintosh files on other computers, some form of encoding must be used
or the resource and attribute information will be lost (which is OK in
some cases). MacBinary, BinHex, and AppleSingle all encode the
original Mac file in a single chunk of data suitable for export to
other operating systems. AppleDouble encodes all the Mac-only data in
one file, but leaves the chunk of unstructured data in a separate file
all by itself, which allows non-Mac-aware programs to read the
unstructured data with no decoding step. AppleSingle and AppleDouble
were originally developed for A/UX (an Apple Unix flavor discontinued
long ago), and are used by netatalk (an AppleShare file server for
Unix servers and Mac clients).
If you are working Mac files on a Mac (presumably with MacPerl), you
probably do NOT need this class. If you are working with Mac files on
a non-Mac, the files may be encoded in AppleSingle or AppleDouble
format, and this class can be useful if you need to get at the Mac
file attributes such as the Finder label, the type and creator codes,
or the IsInvisible bit.
See the "AppleSingle/AppleDouble Formats for Foreign Files Developer's
Note" and the book "Inside Macintosh: Finder Interface" from Apple
Computer, Inc for more details on the formats themselves.
=head1 METHODS
=head2 Creation
=over 4
=item $applefile = new Mac::AppleSingleDouble($filename)
Creates a new Mac::AppleSingleDouble object to represent the file named in $filename.
=back
=head2 Cleanup
=over 4
=item $applefile->close()
Closes the underlying AppleSingle or AppleDouble file.
=back
=head2 Access
=over 4
=item $applefile->get_finder_info()
Returns a hash containing Finder information decoded from the FInfo and FXInfo data structures.
=item $applefile->get_entry($id)
Returns the raw binary data of an entry, given its ID. Types defined by Apple are:
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
=item $applefile->get_file_format()
Returns 'AppleSingle', 'AppleDouble', or 'Plain' based on the "magic
number" found at the beginning of the file. (0x00051600 is AppleSingle,
0x00051607 is AppleDouble, and anything else is Plain.)
=item $applefile->is_applesingle()
Returns 1 if the file format is AppleSingle. See get_file_format().
=item $applefile->is_appledouble()
Returns 1 if the file format is AppleDouble. See get_file_format().
=item $applefile->get_entry_descriptors()
Returns a hash with entry IDs as keys, and hash references as values. The references hashes contain three keys: EntryID, Offset, and Length. Offset is the offset from the start of the file to the entry data, and Length is the length of the data, both in bytes. (There are higher-level methods to access entry data so most users will not need to call this method.)
=item $applefile->get_all_entries()
Returns a hash with entry IDs as keys, and raw entry data as values. All entry IDs found in the file will be returned.
=item $applefile->dump()
Dump a formatted ASCII representation of the contents of the AppleSingle or AppleDouble file to STDOUT.
=item $applefile->dump_header()
Dump the filename and file size and header information to STDOUT. The header information includes: magic number, format version number, and all entry descriptors (entry ID, offset, and length of each).
=item $applefile->dump_entries()
Print a hex dump of the entry data for all entries in the file to STDOUT.
=item $applefile->dump_entry($id)
Print a hex dump of the entry data for the specified id to STDOUT.
=back
=head2 Configuration
=over 4
=item $applefile->set_labelnames(%new_labelnames)
Given a hash with keys 0 through 7 and string values, change the values corresponding to the LabelName key in the hash returned by get_finder_info(). Note that 0 should always be 'None' since it cannot be changed in the Finder, and the menu in the Finder lists labels in descending order (starting with 7 and counting down to 1).
=item $applefile->set_labelcolors(%new_labelcolors)
Given a hash with keys 0 through 7 and string values, change the values corresponding to the LabelColors key in the hash returned by get_finder_info(). Note that 0 should always be 'Black' or 'None' since it cannot be changed in the Finder, and the menu in the Finder lists labels in descending order (starting with 7 and counting down to 1).
=item $applefile->preload_entire_file()
Loads all the entry data from the file into memory and closes the underlying file.
=item $applefile->cache_entries()
Causes subsequent entry data accesses to be cached in memory in the object.
=back
=head1 DIAGNOSTICS
=over 4
=item The constructor (new) requires a filename as an argument!
(F) The constructor (new Mac::AppleSingleDouble($filename)) was called but the required filename argument was not defined. The path to the AppleSingle or AppleDouble file to be examined must be passed to the constructor.
=item File '/usr/bin/perl' is not in AppleSingle or AppleDouble format!
(F) The file was readable but did not start with the "magic number" denoting AppleSingle or AppleDouble format.
=item '..' is not a file!
(F) The filename specified in the constructor does not point to a file.
=back
=head1 BUGS
The AppleSingle and AppleDouble formats come in two versions - 1 and
2. I was unable to find documentation for version 1 - supposedly there
is a manual called "A/UX Toolbox: Macintosh ROM Interface", but I was
unable to find it. However, netatalk uses version 1. So, this class
was coded using the version 2 specification but it was tested on
version 1 files written by netatalk. Entry ID 7 appears in version 1
files but I have no idea what it means. However, it seems to work...
=head1 RESTRICTIONS
This module can read AppleSingle and AppleDouble files, but it cannot
create or modify them. It's not worth my time to change it so that it
can (testing it thoroughly with other programs which use the files
would be very time consuming), so I probably won't do it. If you want
to make that enhancement and send your changes to me, I would be happy
to integrate them into a new version and to give you credit for your
work.
=head1 AUTHOR
Jamie Flournoy, jamie@white-mountain.org