mirror of
https://github.com/stephenenelson/convert-binhex.git
synced 2024-11-22 02:30:55 +00:00
1742 lines
44 KiB
Perl
1742 lines
44 KiB
Perl
package Convert::BinHex;
|
|
|
|
|
|
=head1 NAME
|
|
|
|
Convert::BinHex - extract data from Macintosh BinHex files
|
|
|
|
I<ALPHA WARNING: this code is currently in its Alpha release.
|
|
Things may change drastically until the interface is hammered out:
|
|
if you have suggestions or objections, please speak up now!>
|
|
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
B<Simple functions:>
|
|
|
|
use Convert::BinHex qw(binhex_crc macbinary_crc);
|
|
|
|
# Compute HQX7-style CRC for data, pumping in old CRC if desired:
|
|
$crc = binhex_crc($data, $crc);
|
|
|
|
# Compute the MacBinary-II-style CRC for the data:
|
|
$crc = macbinary_crc($data, $crc);
|
|
|
|
B<Hex to bin, low-level interface.>
|
|
Conversion is actually done via an object (L<"Convert::BinHex::Hex2Bin">)
|
|
which keeps internal conversion state:
|
|
|
|
# Create and use a "translator" object:
|
|
my $H2B = Convert::BinHex->hex2bin; # get a converter object
|
|
while (<STDIN>) {
|
|
print $STDOUT $H2B->next($_); # convert some more input
|
|
}
|
|
print $STDOUT $H2B->done; # no more input: finish up
|
|
|
|
B<Hex to bin, OO interface.>
|
|
The following operations I<must> be done in the order shown!
|
|
|
|
# Read data in piecemeal:
|
|
$HQX = Convert::BinHex->open(FH=>\*STDIN) || die "open: $!";
|
|
$HQX->read_header; # read header info
|
|
@data = $HQX->read_data; # read in all the data
|
|
@rsrc = $HQX->read_resource; # read in all the resource
|
|
|
|
B<Bin to hex, low-level interface.>
|
|
Conversion is actually done via an object (L<"Convert::BinHex::Bin2Hex">)
|
|
which keeps internal conversion state:
|
|
|
|
# Create and use a "translator" object:
|
|
my $B2H = Convert::BinHex->bin2hex; # get a converter object
|
|
while (<STDIN>) {
|
|
print $STDOUT $B2H->next($_); # convert some more input
|
|
}
|
|
print $STDOUT $B2H->done; # no more input: finish up
|
|
|
|
B<Bin to hex, file interface.> Yes, you can convert I<to> BinHex
|
|
as well as from it!
|
|
|
|
# Create new, empty object:
|
|
my $HQX = Convert::BinHex->new;
|
|
|
|
# Set header attributes:
|
|
$HQX->filename("logo.gif");
|
|
$HQX->type("GIFA");
|
|
$HQX->creator("CNVS");
|
|
|
|
# Give it the data and resource forks (either can be absent):
|
|
$HQX->data(Path => "/path/to/data"); # here, data is on disk
|
|
$HQX->resource(Data => $resourcefork); # here, resource is in core
|
|
|
|
# Output as a BinHex stream, complete with leading comment:
|
|
$HQX->encode(\*STDOUT);
|
|
|
|
B<PLANNED!!!! Bin to hex, "CAP" interface.>
|
|
I<Thanks to Ken Lunde for suggesting this>.
|
|
|
|
# Create new, empty object from CAP tree:
|
|
my $HQX = Convert::BinHex->from_cap("/path/to/root/file");
|
|
$HQX->encode(\*STDOUT);
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
B<BinHex> is a format used by Macintosh for transporting Mac files
|
|
safely through electronic mail, as short-lined, 7-bit, semi-compressed
|
|
data streams. Ths module provides a means of converting those
|
|
data streams back into into binary data.
|
|
|
|
|
|
=head1 FORMAT
|
|
|
|
I<(Some text taken from RFC-1741.)>
|
|
Files on the Macintosh consist of two parts, called I<forks>:
|
|
|
|
=over 4
|
|
|
|
=item Data fork
|
|
|
|
The actual data included in the file. The Data fork is typically the
|
|
only meaningful part of a Macintosh file on a non-Macintosh computer system.
|
|
For example, if a Macintosh user wants to send a file of data to a
|
|
user on an IBM-PC, she would only send the Data fork.
|
|
|
|
=item Resource fork
|
|
|
|
Contains a collection of arbitrary attribute/value pairs, including
|
|
program segments, icon bitmaps, and parametric values.
|
|
|
|
=back
|
|
|
|
Additional information regarding Macintosh files is stored by the
|
|
Finder in a hidden file, called the "Desktop Database".
|
|
|
|
Because of the complications in storing different parts of a
|
|
Macintosh file in a non-Macintosh filesystem that only handles
|
|
consecutive data in one part, it is common to convert the Macintosh
|
|
file into some other format before transferring it over the network.
|
|
The BinHex format squashes that data into transmittable ASCII as follows:
|
|
|
|
=over 4
|
|
|
|
=item 1.
|
|
|
|
The file is output as a B<byte stream> consisting of some basic header
|
|
information (filename, type, creator), then the data fork, then the
|
|
resource fork.
|
|
|
|
=item 2.
|
|
|
|
The byte stream is B<compressed> by looking for series of duplicated
|
|
bytes and representing them using a special binary escape sequence
|
|
(of course, any occurences of the escape character must also be escaped).
|
|
|
|
=item 3.
|
|
|
|
The compressed stream is B<encoded> via the "6/8 hemiola" common
|
|
to I<base64> and I<uuencode>: each group of three 8-bit bytes (24 bits)
|
|
is chopped into four 6-bit numbers, which are used as indexes into
|
|
an ASCII "alphabet".
|
|
(I assume that leftover bytes are zero-padded; documentation is thin).
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use vars qw(@ISA @EXPORT_OK $VERSION $QUIET);
|
|
use integer;
|
|
|
|
use Carp;
|
|
use Exporter;
|
|
use FileHandle;
|
|
|
|
@ISA = qw(Exporter);
|
|
@EXPORT_OK = qw(
|
|
macbinary_crc
|
|
binhex_crc
|
|
);
|
|
|
|
|
|
|
|
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
|
$VERSION = substr q$Revision: 1.119 $, 10;
|
|
|
|
# My identity:
|
|
my $I = 'binhex:';
|
|
|
|
# Utility function:
|
|
sub min {
|
|
my ($a, $b) = @_;
|
|
($a < $b) ? $a : $b;
|
|
}
|
|
|
|
# An array useful for CRC calculations that use 0x1021 as the "seed":
|
|
my @MAGIC = (
|
|
0x0000, 0x1021, 0x2042, 0x3063, 0x4084, 0x50a5, 0x60c6, 0x70e7,
|
|
0x8108, 0x9129, 0xa14a, 0xb16b, 0xc18c, 0xd1ad, 0xe1ce, 0xf1ef,
|
|
0x1231, 0x0210, 0x3273, 0x2252, 0x52b5, 0x4294, 0x72f7, 0x62d6,
|
|
0x9339, 0x8318, 0xb37b, 0xa35a, 0xd3bd, 0xc39c, 0xf3ff, 0xe3de,
|
|
0x2462, 0x3443, 0x0420, 0x1401, 0x64e6, 0x74c7, 0x44a4, 0x5485,
|
|
0xa56a, 0xb54b, 0x8528, 0x9509, 0xe5ee, 0xf5cf, 0xc5ac, 0xd58d,
|
|
0x3653, 0x2672, 0x1611, 0x0630, 0x76d7, 0x66f6, 0x5695, 0x46b4,
|
|
0xb75b, 0xa77a, 0x9719, 0x8738, 0xf7df, 0xe7fe, 0xd79d, 0xc7bc,
|
|
0x48c4, 0x58e5, 0x6886, 0x78a7, 0x0840, 0x1861, 0x2802, 0x3823,
|
|
0xc9cc, 0xd9ed, 0xe98e, 0xf9af, 0x8948, 0x9969, 0xa90a, 0xb92b,
|
|
0x5af5, 0x4ad4, 0x7ab7, 0x6a96, 0x1a71, 0x0a50, 0x3a33, 0x2a12,
|
|
0xdbfd, 0xcbdc, 0xfbbf, 0xeb9e, 0x9b79, 0x8b58, 0xbb3b, 0xab1a,
|
|
0x6ca6, 0x7c87, 0x4ce4, 0x5cc5, 0x2c22, 0x3c03, 0x0c60, 0x1c41,
|
|
0xedae, 0xfd8f, 0xcdec, 0xddcd, 0xad2a, 0xbd0b, 0x8d68, 0x9d49,
|
|
0x7e97, 0x6eb6, 0x5ed5, 0x4ef4, 0x3e13, 0x2e32, 0x1e51, 0x0e70,
|
|
0xff9f, 0xefbe, 0xdfdd, 0xcffc, 0xbf1b, 0xaf3a, 0x9f59, 0x8f78,
|
|
0x9188, 0x81a9, 0xb1ca, 0xa1eb, 0xd10c, 0xc12d, 0xf14e, 0xe16f,
|
|
0x1080, 0x00a1, 0x30c2, 0x20e3, 0x5004, 0x4025, 0x7046, 0x6067,
|
|
0x83b9, 0x9398, 0xa3fb, 0xb3da, 0xc33d, 0xd31c, 0xe37f, 0xf35e,
|
|
0x02b1, 0x1290, 0x22f3, 0x32d2, 0x4235, 0x5214, 0x6277, 0x7256,
|
|
0xb5ea, 0xa5cb, 0x95a8, 0x8589, 0xf56e, 0xe54f, 0xd52c, 0xc50d,
|
|
0x34e2, 0x24c3, 0x14a0, 0x0481, 0x7466, 0x6447, 0x5424, 0x4405,
|
|
0xa7db, 0xb7fa, 0x8799, 0x97b8, 0xe75f, 0xf77e, 0xc71d, 0xd73c,
|
|
0x26d3, 0x36f2, 0x0691, 0x16b0, 0x6657, 0x7676, 0x4615, 0x5634,
|
|
0xd94c, 0xc96d, 0xf90e, 0xe92f, 0x99c8, 0x89e9, 0xb98a, 0xa9ab,
|
|
0x5844, 0x4865, 0x7806, 0x6827, 0x18c0, 0x08e1, 0x3882, 0x28a3,
|
|
0xcb7d, 0xdb5c, 0xeb3f, 0xfb1e, 0x8bf9, 0x9bd8, 0xabbb, 0xbb9a,
|
|
0x4a75, 0x5a54, 0x6a37, 0x7a16, 0x0af1, 0x1ad0, 0x2ab3, 0x3a92,
|
|
0xfd2e, 0xed0f, 0xdd6c, 0xcd4d, 0xbdaa, 0xad8b, 0x9de8, 0x8dc9,
|
|
0x7c26, 0x6c07, 0x5c64, 0x4c45, 0x3ca2, 0x2c83, 0x1ce0, 0x0cc1,
|
|
0xef1f, 0xff3e, 0xcf5d, 0xdf7c, 0xaf9b, 0xbfba, 0x8fd9, 0x9ff8,
|
|
0x6e17, 0x7e36, 0x4e55, 0x5e74, 0x2e93, 0x3eb2, 0x0ed1, 0x1ef0
|
|
);
|
|
|
|
# Ssssssssssshhhhhhhhhh:
|
|
$QUIET = 0;
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
=head2 CRC computation
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item macbinary_crc DATA, SEED
|
|
|
|
Compute the MacBinary-II-style CRC for the given DATA, with the CRC
|
|
seeded to SEED. Normally, you start with a SEED of 0, and you pump in
|
|
the previous CRC as the SEED if you're handling a lot of data one chunk
|
|
at a time. That is:
|
|
|
|
$crc = 0;
|
|
while (<STDIN>) {
|
|
$crc = macbinary_crc($_, $crc);
|
|
}
|
|
|
|
I<Note:> Extracted from the I<mcvert> utility (Doug Moore, April '87),
|
|
using a "magic array" algorithm by Jim Van Verth for efficiency.
|
|
Converted to Perl5 by Eryq. B<Untested.>
|
|
|
|
=cut
|
|
|
|
sub macbinary_crc {
|
|
my $len = length($_[0]);
|
|
my $crc = $_[1];
|
|
my $i;
|
|
for ($i = 0; $i < $len; $i++) {
|
|
($crc ^= (vec($_[0], $i, 8) << 8)) &= 0xFFFF;
|
|
$crc = ($crc << 8) ^ $MAGIC[$crc >> 8];
|
|
}
|
|
$crc;
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item binhex_crc DATA, SEED
|
|
|
|
Compute the HQX-style CRC for the given DATA, with the CRC seeded to SEED.
|
|
Normally, you start with a SEED of 0, and you pump in the previous CRC as
|
|
the SEED if you're handling a lot of data one chunk at a time. That is:
|
|
|
|
$crc = 0;
|
|
while (<STDIN>) {
|
|
$crc = binhex_crc($_, $crc);
|
|
}
|
|
|
|
I<Note:> Extracted from the I<mcvert> utility (Doug Moore, April '87),
|
|
using a "magic array" algorithm by Jim Van Verth for efficiency.
|
|
Converted to Perl5 by Eryq.
|
|
|
|
=cut
|
|
|
|
sub binhex_crc {
|
|
my $len = length($_[0]);
|
|
my $crc = $_[1];
|
|
my $i;
|
|
for ($i = 0; $i < $len; $i++) {
|
|
my $ocrc = $crc;
|
|
$crc = (((($crc & 0xFF) << 8) | vec($_[0], $i, 8))
|
|
^ $MAGIC[$crc >> 8]) & 0xFFFF;
|
|
## printf "CRCin = %04x, char = %02x (%c), CRCout = %04x\n",
|
|
## $ocrc, vec($_[0], $i, 8), ord(substr($_[0], $i, 1)), $crc;
|
|
}
|
|
$crc;
|
|
}
|
|
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head1 OO INTERFACE
|
|
|
|
=head2 Conversion
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item bin2hex
|
|
|
|
I<Class method, constructor.>
|
|
Return a converter object. Just creates a new instance of
|
|
L<"Convert::BinHex::Bin2Hex">; see that class for details.
|
|
|
|
=cut
|
|
|
|
sub bin2hex {
|
|
return Convert::BinHex::Bin2Hex->new;
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item hex2bin
|
|
|
|
I<Class method, constructor.>
|
|
Return a converter object. Just creates a new instance of
|
|
L<"Convert::BinHex::Hex2Bin">; see that class for details.
|
|
|
|
=cut
|
|
|
|
sub hex2bin {
|
|
return Convert::BinHex::Hex2Bin->new;
|
|
}
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head2 Construction
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item new PARAMHASH
|
|
|
|
I<Class method, constructor.>
|
|
Return a handle on a BinHex'able entity. In general, the data and resource
|
|
forks for such an entity are stored in native format (binary) format.
|
|
|
|
Parameters in the PARAMHASH are the same as header-oriented method names,
|
|
and may be used to set attributes:
|
|
|
|
$HQX = new Convert::BinHex filename => "icon.gif",
|
|
type => "GIFB",
|
|
creator => "CNVS";
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my ($class, %params) = @_;
|
|
|
|
# Create object:
|
|
my $self = bless {
|
|
Data => new Convert::BinHex::Fork, # data fork
|
|
Rsrc => new Convert::BinHex::Fork, # resource fork
|
|
}, $class; # basic object
|
|
|
|
# Process params:
|
|
my $method;
|
|
foreach $method (qw(creator filename flags requires type version
|
|
software_version)){
|
|
$self->$method($params{$method}) if exists($params{$method});
|
|
}
|
|
$self;
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item open PARAMHASH
|
|
|
|
I<Class method, constructor.>
|
|
Return a handle on a new BinHex'ed stream, for parsing.
|
|
Params are:
|
|
|
|
=over 4
|
|
|
|
=item Data
|
|
|
|
Input a HEX stream from the given data. This can be a scalar, or a
|
|
reference to an array of scalars.
|
|
|
|
=item Expr
|
|
|
|
Input a HEX stream from any open()able expression. It will be opened and
|
|
binmode'd, and the filehandle will be closed either on a C<close()>
|
|
or when the object is destructed.
|
|
|
|
=item FH
|
|
|
|
Input a HEX stream from the given filehandle.
|
|
|
|
=item NoComment
|
|
|
|
If true, the parser should not attempt to skip a leading "(This file...)"
|
|
comment. That means that the first nonwhite characters encountered
|
|
must be the binhex'ed data.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub open {
|
|
my $self = shift;
|
|
my %params = @_;
|
|
|
|
# Create object:
|
|
ref($self) or $self = $self->new;
|
|
|
|
# Set up input:
|
|
my $data;
|
|
if ($params{FH}) {
|
|
$self->{FH} = Convert::BinHex::IO_Handle->wrap($params{FH});
|
|
}
|
|
elsif ($params{Expr}) {
|
|
$self->{FH} = FileHandle->new($params{Expr}) or
|
|
croak "$I can't open $params{Expr}: $!\n";
|
|
$self->{FH} = Convert::BinHex::IO_Handle->wrap($self->{FH});
|
|
}
|
|
elsif ($params{Data}) {
|
|
if (!ref($data = $params{Data})) { # scalar
|
|
$self->{FH} = Convert::BinHex::IO_Scalar->wrap(\$data);
|
|
}
|
|
elsif (ref($data) eq 'ARRAY') {
|
|
$data = join('', @$data);
|
|
$self->{FH} = Convert::BinHex::IO_Scalar->wrap(\$data);
|
|
}
|
|
}
|
|
$self->{FH} or croak "$I missing a valid input source\n";
|
|
|
|
# Comments?
|
|
$self->{CommentRead} = $params{NoComment};
|
|
|
|
# Reset the converter!
|
|
$self->{H2B} = Convert::BinHex::Hex2Bin->new;
|
|
$self;
|
|
}
|
|
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head2 Get/set header information
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
#------------------------------
|
|
|
|
=item creator [VALUE]
|
|
|
|
I<Instance method.>
|
|
Get/set the creator of the file. This is a four-character
|
|
string (though I don't know if it's guaranteed to be printable ASCII!)
|
|
that serves as part of the Macintosh's version of a MIME "content-type".
|
|
|
|
For example, a document created by "Canvas" might have
|
|
creator C<"CNVS">.
|
|
|
|
=cut
|
|
|
|
sub creator { (@_ > 1) ? ($_[0]->{Creator} = $_[1]) : $_[0]->{Creator} }
|
|
|
|
#------------------------------
|
|
|
|
=item data [PARAMHASH]
|
|
|
|
I<Instance method.>
|
|
Get/set the data fork. Any arguments are passed into the
|
|
new() method of L<"Convert::BinHex::Fork">.
|
|
|
|
=cut
|
|
|
|
sub data {
|
|
my $self = shift;
|
|
@_ ? $self->{Data} = Convert::BinHex::Fork->new(@_) : $self->{Data};
|
|
}
|
|
|
|
#------------------------------
|
|
|
|
=item filename [VALUE]
|
|
|
|
I<Instance method.>
|
|
Get/set the name of the file.
|
|
|
|
=cut
|
|
|
|
sub filename { (@_ > 1) ? ($_[0]->{Filename} = $_[1]) : $_[0]->{Filename} }
|
|
|
|
#------------------------------
|
|
|
|
=item flags [VALUE]
|
|
|
|
I<Instance method.>
|
|
Return the flags, as an integer. Use bitmasking to get as the values
|
|
you need.
|
|
|
|
=cut
|
|
|
|
sub flags { (@_ > 1) ? ($_[0]->{Flags} = $_[1]) : $_[0]->{Flags} }
|
|
|
|
#------------------------------
|
|
|
|
=item header_as_string
|
|
|
|
Return a stringified version of the header that you might
|
|
use for logging/debugging purposes. It looks like this:
|
|
|
|
X-HQX-Software: BinHex 4.0 (Convert::BinHex 1.102)
|
|
X-HQX-Filename: Something_new.eps
|
|
X-HQX-Version: 0
|
|
X-HQX-Type: EPSF
|
|
X-HQX-Creator: ART5
|
|
X-HQX-Data-Length: 49731
|
|
X-HQX-Rsrc-Length: 23096
|
|
|
|
As some of you might have guessed, this is RFC-822-style, and
|
|
may be easily plunked down into the middle of a mail header, or
|
|
split into lines, etc.
|
|
|
|
=cut
|
|
|
|
sub header_as_string {
|
|
my $self = shift;
|
|
my @h;
|
|
push @h, "X-HQX-Software: " .
|
|
"BinHex " . ($self->requires || '4.0') .
|
|
" (Convert::BinHex $VERSION)";
|
|
push @h, "X-HQX-Filename: " . $self->filename;
|
|
push @h, "X-HQX-Version: " . $self->version;
|
|
push @h, "X-HQX-Type: " . $self->type;
|
|
push @h, "X-HQX-Creator: " . $self->creator;
|
|
push @h, "X-HQX-Flags: " . sprintf("%x", $self->flags);
|
|
push @h, "X-HQX-Data-Length: " . $self->data->length;
|
|
push @h, "X-HQX-Rsrc-Length: " . $self->resource->length;
|
|
push @h, "X-HQX-CRC: " . sprintf("%x", $self->{HdrCRC});
|
|
return join("\n", @h) . "\n";
|
|
}
|
|
|
|
#------------------------------
|
|
|
|
=item requires [VALUE]
|
|
|
|
I<Instance method.>
|
|
Get/set the software version required to convert this file, as
|
|
extracted from the comment that preceded the actual binhex'ed
|
|
data; e.g.:
|
|
|
|
(This file must be converted with BinHex 4.0)
|
|
|
|
In this case, after parsing in the comment, the code:
|
|
|
|
$HQX->requires;
|
|
|
|
would get back "4.0".
|
|
|
|
=cut
|
|
|
|
sub requires {
|
|
(@_ > 1) ? ($_[0]->{Requires} = $_[1]) : $_[0]->{Requires}
|
|
}
|
|
*software_version = \&requires;
|
|
|
|
#------------------------------
|
|
|
|
=item resource [PARAMHASH]
|
|
|
|
I<Instance method.>
|
|
Get/set the resource fork. Any arguments are passed into the
|
|
new() method of L<"Convert::BinHex::Fork">.
|
|
|
|
=cut
|
|
|
|
sub resource {
|
|
my $self = shift;
|
|
@_ ? $self->{Rsrc} = Convert::BinHex::Fork->new(@_) : $self->{Rsrc};
|
|
}
|
|
|
|
#------------------------------
|
|
|
|
=item type [VALUE]
|
|
|
|
I<Instance method.>
|
|
Get/set the type of the file. This is a four-character
|
|
string (though I don't know if it's guaranteed to be printable ASCII!)
|
|
that serves as part of the Macintosh's version of a MIME "content-type".
|
|
|
|
For example, a GIF89a file might have type C<"GF89">.
|
|
|
|
=cut
|
|
|
|
sub type { (@_ > 1) ? ($_[0]->{Type} = $_[1]) : $_[0]->{Type} }
|
|
|
|
#------------------------------
|
|
|
|
=item version [VALUE]
|
|
|
|
I<Instance method.>
|
|
Get/set the version, as an integer.
|
|
|
|
=cut
|
|
|
|
sub version { (@_ > 1) ? ($_[0]->{Version} = $_[1]) : $_[0]->{Version} }
|
|
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
### OBSOLETE!!!
|
|
sub data_length { shift->data->length(@_) }
|
|
sub resource_length { shift->resource->length(@_) }
|
|
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head2 Decode, high-level
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item read_comment
|
|
|
|
I<Instance method.>
|
|
Skip past the opening comment in the file, which is of the form:
|
|
|
|
(This file must be converted with BinHex 4.0)
|
|
|
|
As per RFC-1741, I<this comment must immediately precede the BinHex data,>
|
|
and any text before it will be ignored.
|
|
|
|
I<You don't need to invoke this method yourself;> C<read_header()> will
|
|
do it for you. After the call, the version number in the comment is
|
|
accessible via the C<requires()> method.
|
|
|
|
=cut
|
|
|
|
sub read_comment {
|
|
my $self = shift;
|
|
return 1 if ($self->{CommentRead}); # prevent accidents
|
|
local($_);
|
|
while (defined($_ = $self->{FH}->getline)) {
|
|
chomp;
|
|
if (/^\(This file must be converted with BinHex ([\d\.]+).*\)\s*$/i) {
|
|
$self->requires($1);
|
|
return $self->{CommentRead} = 1;
|
|
}
|
|
}
|
|
croak "$I comment line (This file must be converted with BinHex...) ".
|
|
"not found\n";
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item read_header
|
|
|
|
I<Instance method.>
|
|
Read in the BinHex file header. You must do this first!
|
|
|
|
=cut
|
|
|
|
sub read_header {
|
|
my $self = shift;
|
|
return 1 if ($self->{HeaderRead}); # prevent accidents
|
|
|
|
# Skip comment:
|
|
$self->read_comment;
|
|
|
|
# Get header info:
|
|
$self->filename ($self->read_str($self->read_byte));
|
|
$self->version ($self->read_byte);
|
|
$self->type ($self->read_str(4));
|
|
$self->creator ($self->read_str(4));
|
|
$self->flags ($self->read_short);
|
|
$self->data_length ($self->read_long);
|
|
$self->resource_length ($self->read_long);
|
|
$self->{HdrCRC} = $self->read_short;
|
|
$self->{HeaderRead} = 1;
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
#
|
|
# _read_fork
|
|
#
|
|
# I<Instance method, private.>
|
|
# Read in a fork.
|
|
#
|
|
|
|
sub _read_fork {
|
|
my $self = shift;
|
|
|
|
# Pass in call if array context:
|
|
if (wantarray) {
|
|
local($_);
|
|
my @all;
|
|
push @all, $_ while (defined($_ = $self->_read_fork(@_)));
|
|
return @all;
|
|
}
|
|
|
|
# Get args:
|
|
my ($fork, $n) = @_;
|
|
if($self->{$fork}->length == 0) {
|
|
$self->{$fork}->crc($self->read_short);
|
|
return undef;
|
|
}
|
|
defined($n) or $n = 2048;
|
|
|
|
# Reset pointer into fork if necessary:
|
|
if (!defined($self->{$fork}{Ptr})) {
|
|
$self->{$fork}{Ptr} = 0;
|
|
$self->{CompCRC} = 0;
|
|
}
|
|
|
|
# Check for EOF:
|
|
return undef if ($self->{$fork}{Ptr} >= $self->{$fork}->length);
|
|
|
|
# Read up to, but not exceeding, the number of bytes left in the fork:
|
|
my $n2read = min($n, ($self->{$fork}->length - $self->{$fork}{Ptr}));
|
|
my $data = $self->read_str($n2read);
|
|
$self->{$fork}{Ptr} += length($data);
|
|
|
|
# If we just read the last byte, read the CRC also:
|
|
if (($self->{$fork}{Ptr} == $self->{$fork}->length) && # last byte
|
|
!defined($self->{$fork}->crc)) { # no CRC
|
|
my $comp_CRC;
|
|
|
|
# Move computed CRC forward by two zero bytes, and grab the value:
|
|
if ($self->{CheckCRC}) {
|
|
$self->{CompCRC} = binhex_crc("\000\000", $self->{CompCRC});
|
|
}
|
|
|
|
# Get CRC as stored in file:
|
|
$self->{$fork}->crc($self->read_short); # get stored CRC
|
|
|
|
# Compare, and note corruption if detected:
|
|
if ($self->{CheckCRC} and ($self->{$fork}->crc != $comp_CRC)) {
|
|
&Carp::carp("CRCs do not match: corrupted data?") unless $QUIET;
|
|
$self->{Corrupted} = 1;
|
|
}
|
|
}
|
|
|
|
# Return the bytes:
|
|
$data;
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item read_data [NBYTES]
|
|
|
|
I<Instance method.>
|
|
Read information from the data fork. Use it in an array context to
|
|
slurp all the data into an array of scalars:
|
|
|
|
@data = $HQX->read_data;
|
|
|
|
Or use it in a scalar context to get the data piecemeal:
|
|
|
|
while (defined($data = $HQX->read_data)) {
|
|
# do stuff with $data
|
|
}
|
|
|
|
The NBYTES to read defaults to 2048.
|
|
|
|
=cut
|
|
|
|
sub read_data {
|
|
shift->_read_fork('Data',@_);
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item read_resource [NBYTES]
|
|
|
|
I<Instance method.>
|
|
Read in all/some of the resource fork.
|
|
See C<read_data()> for usage.
|
|
|
|
=cut
|
|
|
|
sub read_resource {
|
|
shift->_read_fork('Rsrc',@_);
|
|
}
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
|
|
|
|
#------------------------------------------------------------
|
|
#
|
|
# read BUFFER, NBYTES
|
|
#
|
|
# Read the next NBYTES (decompressed) bytes from the input stream
|
|
# into BUFFER. Returns the number of bytes actually read, and
|
|
# undef on end of file.
|
|
#
|
|
# I<Note:> the calling style mirrors the IO::Handle read() function.
|
|
|
|
my $READBUF = '';
|
|
sub read {
|
|
my ($self, $n) = ($_[0], $_[2]);
|
|
$_[1] = ''; # just in case
|
|
my $FH = $self->{FH};
|
|
local($^W) = 0;
|
|
|
|
# Get more BIN bytes until enough or EOF:
|
|
my $bin;
|
|
while (length($self->{BIN_QUEUE}) < $n) {
|
|
$FH->read($READBUF, 4096) or last;
|
|
$self->{BIN_QUEUE} .= $self->{H2B}->next($READBUF); # save BIN
|
|
}
|
|
|
|
# We've got as many bytes as we're gonna get:
|
|
$_[1] = substr($self->{BIN_QUEUE}, 0, $n);
|
|
$self->{BIN_QUEUE} = substr($self->{BIN_QUEUE}, $n);
|
|
|
|
# Advance the CRC:
|
|
if ($self->{CheckCRC}) {
|
|
$self->{CompCRC} = binhex_crc($_[1], $self->{CompCRC});
|
|
}
|
|
return length($_[1]);
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
#
|
|
# read_str NBYTES
|
|
#
|
|
# Read and return the next NBYTES bytes, or die with "unexpected end of file"
|
|
|
|
sub read_str {
|
|
my ($self, $n) = @_;
|
|
my $buf = '';
|
|
$self->read($buf, $n);
|
|
croak "$I unexpected end of file (wanted $n, got " . length($buf) . ")\n"
|
|
if ($n and (length($buf) < $n));
|
|
return $buf;
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
#
|
|
# read_byte
|
|
# read_short
|
|
# read_long
|
|
#
|
|
# Read 1, 2, or 4 bytes, and return the value read as an unsigned integer.
|
|
# If not that many bytes remain, die with "unexpected end of file";
|
|
|
|
sub read_byte {
|
|
ord($_[0]->read_str(1));
|
|
}
|
|
|
|
sub read_short {
|
|
unpack("n", $_[0]->read_str(2));
|
|
}
|
|
|
|
sub read_long {
|
|
unpack("N", $_[0]->read_str(4));
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head2 Encode, high-level
|
|
|
|
=over 4
|
|
|
|
=cut
|
|
|
|
#------------------------------------------------------------
|
|
|
|
=item encode OUT
|
|
|
|
Encode the object as a BinHex stream to the given output handle OUT.
|
|
OUT can be a filehandle, or any blessed object that responds to a
|
|
C<print()> message.
|
|
|
|
The leading comment is output, using the C<requires()> attribute.
|
|
|
|
=cut
|
|
|
|
sub encode {
|
|
my $self = shift;
|
|
|
|
# Get output handle:
|
|
my $OUT = shift; $OUT = wrap Convert::BinHex::IO_Handle $OUT;
|
|
|
|
# Get a new converter:
|
|
my $B2H = $self->bin2hex;
|
|
|
|
# Comment:
|
|
$OUT->print("(This file must be converted with BinHex ",
|
|
($self->requires || '4.0'),
|
|
")\n");
|
|
|
|
# Build header in core:
|
|
my @hdrs;
|
|
my $flen = length($self->filename);
|
|
push @hdrs, pack("C", $flen);
|
|
push @hdrs, pack("a$flen", $self->filename);
|
|
push @hdrs, pack('C', $self->version);
|
|
push @hdrs, pack('a4', $self->type || '????');
|
|
push @hdrs, pack('a4', $self->creator || '????');
|
|
push @hdrs, pack('n', $self->flags || 0);
|
|
push @hdrs, pack('N', $self->data->length || 0);
|
|
push @hdrs, pack('N', $self->resource->length || 0);
|
|
my $hdr = join '', @hdrs;
|
|
|
|
# Compute the header CRC:
|
|
my $crc = binhex_crc("\000\000", binhex_crc($hdr, 0));
|
|
|
|
# Output the header (plus its CRC):
|
|
$OUT->print($B2H->next($hdr . pack('n', $crc)));
|
|
|
|
# Output the data fork:
|
|
$self->data->encode($OUT, $B2H);
|
|
|
|
# Output the resource fork:
|
|
$self->resource->encode($OUT, $B2H);
|
|
|
|
# Finish:
|
|
$OUT->print($B2H->done);
|
|
1;
|
|
}
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head1 SUBMODULES
|
|
|
|
=cut
|
|
|
|
#============================================================
|
|
#
|
|
package Convert::BinHex::Bin2Hex;
|
|
#
|
|
#============================================================
|
|
|
|
=head2 Convert::BinHex::Bin2Hex
|
|
|
|
A BINary-to-HEX converter. This kind of conversion requires
|
|
a certain amount of state information; it cannot be done by
|
|
just calling a simple function repeatedly. Use it like this:
|
|
|
|
# Create and use a "translator" object:
|
|
my $B2H = Convert::BinHex->bin2hex; # get a converter object
|
|
while (<STDIN>) {
|
|
print STDOUT $B2H->next($_); # convert some more input
|
|
}
|
|
print STDOUT $B2H->done; # no more input: finish up
|
|
|
|
# Re-use the object:
|
|
$B2H->rewind; # ready for more action!
|
|
while (<MOREIN>) { ...
|
|
|
|
On each iteration, C<next()> (and C<done()>) may return either
|
|
a decent-sized non-empty string (indicating that more converted data
|
|
is ready for you) or an empty string (indicating that the converter
|
|
is waiting to amass more input in its private buffers before handing
|
|
you more stuff to output.
|
|
|
|
Note that C<done()> I<always> converts and hands you whatever is left.
|
|
|
|
This may have been a good approach. It may not. Someday, the converter
|
|
may also allow you give it an object that responds to read(), or
|
|
a FileHandle, and it will do all the nasty buffer-filling on its own,
|
|
serving you stuff line by line:
|
|
|
|
# Someday, maybe...
|
|
my $B2H = Convert::BinHex->bin2hex(\*STDIN);
|
|
while (defined($_ = $B2H->getline)) {
|
|
print STDOUT $_;
|
|
}
|
|
|
|
Someday, maybe. Feel free to voice your opinions.
|
|
|
|
=cut
|
|
|
|
#------------------------------
|
|
#
|
|
# new
|
|
|
|
sub new {
|
|
my $self = bless {}, shift;
|
|
return $self->rewind;
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# rewind
|
|
|
|
sub rewind {
|
|
my $self = shift;
|
|
$self->{CBIN} = ' ' x 2048; $self->{CBIN} = ''; # BIN waiting for xlation
|
|
$self->{HEX} = ' ' x 2048; $self->{HEX} = ''; # HEX waiting for output
|
|
$self->{LINE} = 0; # current line of output
|
|
$self->{EOL} = "\n";
|
|
$self;
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# next MOREDATA
|
|
|
|
sub next { shift->_next(0, @_) }
|
|
|
|
#------------------------------
|
|
#
|
|
# done
|
|
|
|
sub done { shift->_next(1) }
|
|
|
|
#------------------------------
|
|
#
|
|
# _next ATEOF, [MOREDATA]
|
|
#
|
|
# Instance method, private. Supply more data, and get any more output.
|
|
# Returns the empty string often, if not enough output has accumulated.
|
|
|
|
sub _next {
|
|
my $self = shift;
|
|
my $eof = shift;
|
|
|
|
# Get the BINary data to process this time round, re-queueing the rest:
|
|
# Handle EOF and non-EOF conditions separately:
|
|
my $new_bin;
|
|
if ($eof) { # No more BINary input...
|
|
# Pad the queue with nuls to exactly 3n characters:
|
|
$self->{CBIN} .= ("\x00" x ((3 - length($self->{CBIN}) % 3) % 3))
|
|
}
|
|
else { # More BINary input...
|
|
# "Compress" new stuff, and add it to the queue:
|
|
($new_bin = $_[0]) =~ s/\x90/\x90\x00/g;
|
|
$self->{CBIN} .= $new_bin;
|
|
|
|
# Return if not enough to bother with:
|
|
return '' if (length($self->{CBIN}) < 2048);
|
|
}
|
|
|
|
# ...At this point, QUEUE holds compressed binary which we will attempt
|
|
# to convert to some HEX characters...
|
|
|
|
# Trim QUEUE to exactly 3n characters, saving the excess:
|
|
my $requeue = '';
|
|
$requeue .= chop($self->{CBIN}) while (length($self->{CBIN}) % 3);
|
|
|
|
# Uuencode, adding stuff to hex:
|
|
my $hex = ' ' x 2048; $hex = '';
|
|
pos($self->{CBIN}) = 0;
|
|
while ($self->{CBIN} =~ /(.{1,45})/gs) {
|
|
$hex .= substr(pack('u', $1), 1);
|
|
chop($hex);
|
|
}
|
|
$self->{CBIN} = reverse($requeue); # put the excess back on the queue
|
|
|
|
# Switch to BinHex alphabet:
|
|
$hex =~ tr
|
|
{` -_}
|
|
{!!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr};
|
|
|
|
# Prepend any HEX we have queued from the last time:
|
|
$hex = (($self->{LINE}++ ? '' : ':') . # start with ":" pad?
|
|
$self->{HEX} . # any output in the queue?
|
|
$hex);
|
|
|
|
# Break off largest chunk of 64n characters, put remainder back in queue:
|
|
my $rem = length($hex) % 64;
|
|
$self->{HEX} = ($rem ? substr($hex, -$rem) : '');
|
|
$hex = substr($hex, 0, (length($hex)-$rem));
|
|
|
|
# Put in an EOL every 64'th character:
|
|
$hex =~ s{(.{64})}{$1$self->{EOL}}sg;
|
|
|
|
# No more input? Then tack on the remainder now:
|
|
if ($eof) {
|
|
$hex .= $self->{HEX} . ":" . ($self->{EOL} ? $self->{EOL} : '');
|
|
}
|
|
|
|
# Done!
|
|
$hex;
|
|
}
|
|
|
|
|
|
|
|
|
|
#============================================================
|
|
#
|
|
package Convert::BinHex::Hex2Bin;
|
|
#
|
|
#============================================================
|
|
|
|
=head2 Convert::BinHex::Hex2Bin
|
|
|
|
A HEX-to-BINary converter. This kind of conversion requires
|
|
a certain amount of state information; it cannot be done by
|
|
just calling a simple function repeatedly. Use it like this:
|
|
|
|
# Create and use a "translator" object:
|
|
my $H2B = Convert::BinHex->hex2bin; # get a converter object
|
|
while (<STDIN>) {
|
|
print STDOUT $H2B->next($_); # convert some more input
|
|
}
|
|
print STDOUT $H2B->done; # no more input: finish up
|
|
|
|
# Re-use the object:
|
|
$H2B->rewind; # ready for more action!
|
|
while (<MOREIN>) { ...
|
|
|
|
On each iteration, C<next()> (and C<done()>) may return either
|
|
a decent-sized non-empty string (indicating that more converted data
|
|
is ready for you) or an empty string (indicating that the converter
|
|
is waiting to amass more input in its private buffers before handing
|
|
you more stuff to output.
|
|
|
|
Note that C<done()> I<always> converts and hands you whatever is left.
|
|
|
|
Note that this converter does I<not> find the initial
|
|
"BinHex version" comment. You have to skip that yourself. It
|
|
only handles data between the opening and closing C<":">.
|
|
|
|
=cut
|
|
|
|
#------------------------------
|
|
#
|
|
# new
|
|
|
|
sub new {
|
|
my $self = bless {}, shift;
|
|
return $self->rewind;
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# rewind
|
|
|
|
sub rewind {
|
|
my $self = shift;
|
|
$self->hex2comp_rewind;
|
|
$self->comp2bin_rewind;
|
|
$self;
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# next MOREDATA
|
|
|
|
sub next {
|
|
my $self = shift;
|
|
$_[0] =~ s/\s//g if (defined($_[0])); # more input
|
|
return $self->comp2bin_next($self->hex2comp_next($_[0]));
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# done
|
|
|
|
sub done {
|
|
return "";
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# hex2comp_rewind
|
|
|
|
sub hex2comp_rewind {
|
|
my $self = shift;
|
|
$self->{HEX} = '';
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# hex2comp_next HEX
|
|
#
|
|
# WARNING: argument is modified destructively for efficiency!!!!
|
|
|
|
sub hex2comp_next {
|
|
my $self = shift;
|
|
### print "hex2comp: newhex = $newhex\n";
|
|
|
|
# Concat new with queue, and kill any padding:
|
|
my $hex = $self->{HEX} . (defined($_[0]) ? $_[0] : '');
|
|
if (index($hex, ':') >= 0) {
|
|
$hex =~ s/^://; # start of input
|
|
if ($hex =~ s/:\s*\Z//) { # end of input
|
|
my $leftover = (length($hex) % 4); # need to pad!
|
|
$hex .= "\000" x (4 - $leftover) if $leftover; # zero pad
|
|
}
|
|
}
|
|
|
|
# Get longest substring of length 4n possible; put rest back on queue:
|
|
my $rem = length($hex) % 4;
|
|
$self->{HEX} = ($rem ? substr($hex, -$rem) : '');
|
|
for (; $rem; --$rem) { chop $hex };
|
|
return undef if ($hex eq ''); # nothing to do!
|
|
|
|
# Convert to uuencoded format:
|
|
$hex =~ tr
|
|
{!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr}
|
|
{ -_};
|
|
|
|
# Now, uudecode:
|
|
my $comp = '';
|
|
my $len;
|
|
my $up;
|
|
local($^W) = 0; ### KLUDGE
|
|
while ($hex =~ /\G(.{1,60})/gs) {
|
|
$len = chr(32 + ((length($1)*3)>>2)); # compute length byte
|
|
$comp .= unpack("u", $len . $1 ); # uudecode
|
|
}
|
|
|
|
# We now have the compressed binary... expand it:
|
|
### print "hex2comp: comp = $comp\n";
|
|
$comp;
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# comp2bin_rewind
|
|
|
|
sub comp2bin_rewind {
|
|
my $self = shift;
|
|
$self->{COMP} = '';
|
|
$self->{LASTC} = '';
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# comp2bin_next COMP
|
|
#
|
|
# WARNING: argument is modified destructively for efficiency!!!!
|
|
|
|
sub comp2bin_next {
|
|
my $self = shift;
|
|
|
|
# Concat new with queue... anything to do?
|
|
my $comp = $self->{COMP} . (defined($_[0]) ? $_[0] : '');
|
|
return undef if ($comp eq '');
|
|
|
|
# For each character in compressed string...
|
|
$self->{COMP} = '';
|
|
my $lastc = $self->{LASTC}; # speed hack
|
|
my $exp = ''; # expanded string
|
|
my $i;
|
|
my ($c, $n);
|
|
for ($i = 0; $i < length($comp); $i++) {
|
|
if (($c = substr($comp, $i, 1)) eq "\x90") { # MARK
|
|
### print "c = MARK\n";
|
|
unless (length($n = substr($comp, ++$i, 1))) {
|
|
$self->{COMP} = "\x90";
|
|
last;
|
|
}
|
|
### print "n = ", ord($n), "; lastc = ", ord($lastc), "\n";
|
|
$exp .= ((ord($n) ? ($lastc x (ord($n)-1)) # repeat last char
|
|
: ($lastc = "\x90"))); # literal MARK
|
|
}
|
|
else { # other CHAR
|
|
### print "c = ", ord($c), "\n";
|
|
$exp .= ($lastc = $c);
|
|
}
|
|
### print "exp is now $exp\n";
|
|
}
|
|
|
|
# Either hit EOS, or there's a MARK char at the very end:
|
|
$self->{LASTC} = $lastc;
|
|
### print "leaving with lastc=$lastc and comp=$self->{COMP}\n";
|
|
### print "comp2bin: exp = $exp\n";
|
|
$exp;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
#============================================================
|
|
#
|
|
package Convert::BinHex::Fork;
|
|
#
|
|
#============================================================
|
|
|
|
=head2 Convert::BinHex::Fork
|
|
|
|
A fork in a Macintosh file.
|
|
|
|
# How to get them...
|
|
$data_fork = $HQX->data; # get the data fork
|
|
$rsrc_fork = $HQX->resource; # get the resource fork
|
|
|
|
# Make a new fork:
|
|
$FORK = Convert::BinHex::Fork->new(Path => "/tmp/file.data");
|
|
$FORK = Convert::BinHex::Fork->new(Data => $scalar);
|
|
$FORK = Convert::BinHex::Fork->new(Data => \@array_of_scalars);
|
|
|
|
# Get/set the length of the data fork:
|
|
$len = $FORK->length;
|
|
$FORK->length(170); # this overrides the REAL value: be careful!
|
|
|
|
# Get/set the path to the underlying data (if in a disk file):
|
|
$path = $FORK->path;
|
|
$FORK->path("/tmp/file.data");
|
|
|
|
# Get/set the in-core data itself, which may be a scalar or an arrayref:
|
|
$data = $FORK->data;
|
|
$FORK->data($scalar);
|
|
$FORK->data(\@array_of_scalars);
|
|
|
|
# Get/set the CRC:
|
|
$crc = $FORK->crc;
|
|
$FORK->crc($crc);
|
|
|
|
=cut
|
|
|
|
|
|
# Import some stuff into our namespace:
|
|
*binhex_crc = \&Convert::BinHex::binhex_crc;
|
|
|
|
#------------------------------
|
|
#
|
|
# new PARAMHASH
|
|
|
|
sub new {
|
|
my ($class, %params) = @_;
|
|
bless \%params, $class;
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# length [VALUE]
|
|
|
|
sub length {
|
|
my $self = shift;
|
|
|
|
# Set length?
|
|
$self->{Length} = shift if @_;
|
|
|
|
# Return explicit length, if any
|
|
return $self->{Length} if defined($self->{Length});
|
|
|
|
# Compute it:
|
|
if (defined($self->{Path})) {
|
|
return (-s $self->{Path});
|
|
}
|
|
elsif (!ref($self->{Data})) {
|
|
return length($self->{Data});
|
|
}
|
|
elsif (ref($self->{Data} eq 'ARRAY')) {
|
|
my $n = 0;
|
|
foreach (@{$self->{Data}}) { $n += length($_) }
|
|
return $n;
|
|
}
|
|
return undef; # unknown!
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# path [VALUE]
|
|
|
|
sub path {
|
|
my $self = shift;
|
|
if (@_) { $self->{Path} = shift; delete $self->{Data} }
|
|
$self->{Path};
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# data [VALUE]
|
|
|
|
sub data {
|
|
my $self = shift;
|
|
if (@_) { $self->{Data} = shift; delete $self->{Path} }
|
|
$self->{Data};
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# crc [VALUE]
|
|
|
|
sub crc {
|
|
my $self = shift;
|
|
@_ ? $self->{CRC} = shift : $self->{CRC};
|
|
}
|
|
|
|
#------------------------------
|
|
#
|
|
# encode OUT, B2H
|
|
#
|
|
# Instance method, private. Encode this fork as part of a BinHex stream.
|
|
# It will be printed to handle OUT using the binhexer B2H.
|
|
|
|
sub encode {
|
|
my ($self, $OUT, $B2H) = @_;
|
|
my $buf = '';
|
|
require POSIX if $^O||'' eq "MacOS";
|
|
require Fcntl if $^O||'' eq "MacOS";
|
|
my $fd;
|
|
|
|
# Reset the CRC:
|
|
$self->{CRC} = 0;
|
|
|
|
# Output the data, calculating the CRC as we go:
|
|
if (defined($self->{Path})) { # path to fork file
|
|
if ($^O||'' eq "MacOS" and $self->{Fork} eq "RSRC") {
|
|
$fd = POSIX::open($self->{Path},&POSIX::O_RDONLY | &Fcntl::O_RSRC);
|
|
while (POSIX::read($fd, $buf, 2048) > 0) {
|
|
$self->{CRC} = binhex_crc($buf, $self->{CRC});
|
|
$OUT->print($B2H->next($buf));
|
|
}
|
|
POSIX::close($fd);
|
|
}
|
|
else {
|
|
open FORK, $self->{Path} or die "$self->{Path}: $!";
|
|
while (read(\*FORK, $buf, 2048)) {
|
|
$self->{CRC} = binhex_crc($buf, $self->{CRC});
|
|
$OUT->print($B2H->next($buf));
|
|
}
|
|
close FORK;
|
|
}
|
|
}
|
|
elsif (!defined($self->{Data})) { # nothing!
|
|
&Carp::carp("no data in fork!") unless $Convert::BinHex::QUIET;
|
|
}
|
|
elsif (!ref($self->{Data})) { # scalar
|
|
$self->{CRC} = binhex_crc($self->{Data}, $self->{CRC});
|
|
$OUT->print($B2H->next($self->{Data}));
|
|
}
|
|
elsif (ref($self->{Data}) eq 'ARRAY') { # array of scalars
|
|
foreach $buf (@{$self->{Data}}) {
|
|
$self->{CRC} = binhex_crc($buf, $self->{CRC});
|
|
$OUT->print($B2H->next($buf));
|
|
}
|
|
}
|
|
else {
|
|
&Carp::croak("bad/unsupported data in fork");
|
|
}
|
|
|
|
# Finish the CRC, and output it:
|
|
$self->{CRC} = binhex_crc("\000\000", $self->{CRC});
|
|
$OUT->print($B2H->next(pack("n", $self->{CRC})));
|
|
1;
|
|
}
|
|
|
|
|
|
|
|
|
|
#============================================================
|
|
#
|
|
package Convert::BinHex::IO_Handle;
|
|
#
|
|
#============================================================
|
|
|
|
# Wrap a non-object filehandle inside a blessed, printable interface:
|
|
# Does nothing if the given $fh is already a blessed object.
|
|
sub wrap {
|
|
my ($class, $fh) = @_;
|
|
no strict 'refs';
|
|
$fh or $fh = select; # no filehandle means selected one
|
|
ref($fh) or $fh = \*$fh; # scalar becomes a globref
|
|
return $fh if (ref($fh) and (ref($fh) !~ /^(GLOB|FileHandle)$/));
|
|
bless \$fh, $class; # wrap it in a printable interface
|
|
}
|
|
sub print {
|
|
my $FH = ${shift(@_)};
|
|
print $FH @_;
|
|
}
|
|
sub getline {
|
|
my $FH = ${shift(@_)};
|
|
scalar(<$FH>);
|
|
}
|
|
sub read {
|
|
read ${$_[0]}, $_[1], $_[2];
|
|
}
|
|
|
|
|
|
|
|
#============================================================
|
|
#
|
|
package Convert::BinHex::IO_Scalar;
|
|
#
|
|
#============================================================
|
|
|
|
# Wrap a scalar inside a blessed, printable interface:
|
|
sub wrap {
|
|
my ($class, $scalarref) = @_;
|
|
defined($scalarref) or $scalarref = \"";
|
|
pos($$scalarref) = 0;
|
|
bless $scalarref, $class;
|
|
}
|
|
sub print {
|
|
my $self = shift;
|
|
$$self .= join('', @_);
|
|
1;
|
|
}
|
|
sub getline {
|
|
my $self = shift;
|
|
($$self =~ /\G(.*?\n?)/g) or return undef;
|
|
return $1;
|
|
}
|
|
sub read {
|
|
my $self = shift;
|
|
$_[0] = substr($$self, pos($$self), $_[1]);
|
|
pos($$self) += $_[1];
|
|
return length($_[0]);
|
|
}
|
|
|
|
|
|
|
|
#==============================
|
|
|
|
=head1 UNDER THE HOOD
|
|
|
|
=head2 Design issues
|
|
|
|
=over 4
|
|
|
|
=item BinHex needs a stateful parser
|
|
|
|
Unlike its cousins I<base64> and I<uuencode>, BinHex format is not
|
|
amenable to being parsed line-by-line. There appears to be no
|
|
guarantee that lines contain 4n encoded characters... and even if there
|
|
is one, the BinHex compression algorithm interferes: even when you
|
|
can I<decode> one line at a time, you can't necessarily
|
|
I<decompress> a line at a time.
|
|
|
|
For example: a decoded line ending with the byte C<\x90> (the escape
|
|
or "mark" character) is ambiguous: depending on the next decoded byte,
|
|
it could mean a literal C<\x90> (if the next byte is a C<\x00>), or
|
|
it could mean n-1 more repetitions of the previous character (if
|
|
the next byte is some nonzero C<n>).
|
|
|
|
For this reason, a BinHex parser has to be somewhat stateful: you
|
|
cannot have code like this:
|
|
|
|
#### NO! #### NO! #### NO! #### NO! #### NO! ####
|
|
while (<STDIN>) { # read HEX
|
|
print hexbin($_); # convert and write BIN
|
|
}
|
|
|
|
unless something is happening "behind the scenes" to keep track of
|
|
what was last done. I<The dangerous thing, however, is that this
|
|
approach will B<seem> to work, if you only test it on BinHex files
|
|
which do not use compression and which have 4n HEX characters
|
|
on each line.>
|
|
|
|
Since we have to be stateful anyway, we use the parser object to
|
|
keep our state.
|
|
|
|
|
|
=item We need to be handle large input files
|
|
|
|
Solutions that demand reading everything into core don't cut
|
|
it in my book. The first MPEG file that comes along can louse
|
|
up your whole day. So, there are no size limitations in this
|
|
module: the data is read on-demand, and filehandles are always
|
|
an option.
|
|
|
|
|
|
=item Boy, is this slow!
|
|
|
|
A lot of the byte-level manipulation that has to go on, particularly
|
|
the CRC computing (which involves intensive bit-shifting and masking)
|
|
slows this module down significantly. What is needed perhaps is an
|
|
I<optional> extension library where the slow pieces can be done more
|
|
quickly... a Convert::BinHex::CRC, if you will. Volunteers, anyone?
|
|
|
|
Even considering that, however, it's slower than I'd like. I'm
|
|
sure many improvements can be made in the HEX-to-BIN end of things.
|
|
No doubt I'll attempt some as time goes on...
|
|
|
|
=back
|
|
|
|
|
|
|
|
=head2 How it works
|
|
|
|
Since BinHex is a layered format, consisting of...
|
|
|
|
A Macintosh file [the "BIN"]...
|
|
Encoded as a structured 8-bit bytestream, then...
|
|
Compressed to reduce duplicate bytes, then...
|
|
Encoded as 7-bit ASCII [the "HEX"]
|
|
|
|
...there is a layered parsing algorithm to reverse the process.
|
|
Basically, it works in a similar fashion to stdio's fread():
|
|
|
|
0. There is an internal buffer of decompressed (BIN) data,
|
|
initially empty.
|
|
1. Application asks to read() n bytes of data from object
|
|
2. If the buffer is not full enough to accomodate the request:
|
|
2a. The read() method grabs the next available chunk of input
|
|
data (the HEX).
|
|
2b. HEX data is converted and decompressed into as many BIN
|
|
bytes as possible.
|
|
2c. BIN bytes are added to the read() buffer.
|
|
2d. Go back to step 2a. until the buffer is full enough
|
|
or we hit end-of-input.
|
|
|
|
The conversion-and-decompression algorithms need their own internal
|
|
buffers and state (since the next input chunk may not contain all the
|
|
data needed for a complete conversion/decompression operation).
|
|
These are maintained in the object, so parsing two different
|
|
input streams simultaneously is possible.
|
|
|
|
|
|
=head1 WARNINGS
|
|
|
|
Only handles C<Hqx7> files, as per RFC-1741.
|
|
|
|
Remember that Macintosh text files use C<"\r"> as end-of-line:
|
|
this means that if you want a textual file to look normal on
|
|
a non-Mac system, you probably want to do this to the data:
|
|
|
|
# Get the data, and output it according to normal conventions:
|
|
foreach ($HQX->read_data) { s/\r/\n/g; print }
|
|
|
|
|
|
=head1 CHANGE LOG
|
|
|
|
Current version: $Id: BinHex.pm,v 1.119 1997/06/28 05:12:42 eryq Exp $
|
|
|
|
=over 4
|
|
|
|
=item Version 1.118
|
|
|
|
Ready to go public (with Paul's version, patched for native Mac support)!
|
|
Warnings have been suppressed in a few places where undefined values
|
|
appear.
|
|
|
|
=item Version 1.115
|
|
|
|
Fixed another bug in comp2bin, related to the MARK falling on a
|
|
boundary between inputs. Added testing code.
|
|
|
|
=item Version 1.114
|
|
|
|
Added BIN-to-HEX conversion. Eh. It's a start.
|
|
Also, a lot of documentation additions and cleanups.
|
|
Some methods were also renamed.
|
|
|
|
=item Version 1.103
|
|
|
|
Fixed bug in decompression (wasn't saving last character).
|
|
Fixed "NoComment" bug.
|
|
|
|
=item Version 1.102
|
|
|
|
Initial release.
|
|
|
|
=back
|
|
|
|
|
|
=head1 AUTHOR AND CREDITS
|
|
|
|
Written by Eryq, F<http://www.enteract.com/~eryq> / F<eryq@enteract.com>
|
|
|
|
Support for native-Mac conversion, I<plus> invaluable contributions in
|
|
Alpha Testing, I<plus> a few patches, I<plus> the baseline binhex/debinhex
|
|
programs, were provided by Paul J. Schinder (NASA/GSFC).
|
|
|
|
Ken Lunde (Adobe) suggested incorporating the CAP file representation.
|
|
|
|
|
|
=head1 TERMS AND CONDITIONS
|
|
|
|
Copyright (c) 1997 by Eryq. All rights reserved. This program is free
|
|
software; you can redistribute it and/or modify it under the same terms as
|
|
Perl itself.
|
|
|
|
This software comes with B<NO WARRANTY> of any kind.
|
|
See the COPYING file in the distribution for details.
|
|
|
|
=cut
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
my $HQX = new Convert::BinHex
|
|
version => 0,
|
|
filename=>"s.gif",
|
|
type => "GIF8",
|
|
creator => "PCBH",
|
|
flags => 0xFFFF
|
|
;
|
|
|
|
$HQX->data(Path=>"/home/eryq/s.gif");
|
|
$HQX->resource(Path=>"/etc/issue");
|
|
|
|
#$HQX->data(Data=>"123456789");
|
|
#$HQX->resource(Data=>'');
|
|
|
|
$HQX->encode(\*STDOUT);
|
|
|
|
1;
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|