#!/usr/local/bin/perl

package Mac::Conversions;
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(binhex debinhex macbinary demacbinary hex2macb macb2hex);

$VERSION = "1.01";
sub Version { $VERSION; }

use strict;
use Convert::BinHex;
use POSIX;
use Fcntl;
use File::Basename;
use Carp;
use FileHandle;

sub new {
    my $class = shift;
    my %arg = @_;
    my %self = ();
    
    $self{Debug} = exists $arg{Debug} ? $arg{Debug} : 0;
    $self{Remove} = exists $arg{Remove} ? $arg{Remove} : 0;
    bless \%self, $class;
}

sub binhex {
#
# Native Mac to BinHex, using Convert::BinHex
#
    use Mac::Files;
    my $bhex;
    my ($lname, $ldir, $has, $size, $rsize, $finfo, $outname, $flags, $i);
    
    my $self = shift;
    my $file = shift || croak("No filename given $!");

    my $hqx = Convert::BinHex->new;
    ($lname,$ldir) = fileparse($file);
    $hqx->filename($lname);
    $outname = uniqify($ldir,$lname,"hqx");

    $has = FSpGetCatInfo($file);
    $finfo = $has->ioFlFndrInfo;
    $size = $has->ioFlLgLen;
    $rsize = $has->ioFlRLgLen;
    $hqx->type($finfo->fdType);
    $hqx->creator($finfo->fdCreator);
    $flags = $finfo->fdFlags;
    $flags &= 0xfeff; #turn off inited bit
    $hqx->flags($flags);
    $hqx->data(Path => $file);
    $hqx->resource(Path => $file, Fork => "RSRC");
    $hqx->data->length($size);
    $hqx->resource->length($rsize);
    if($self->{Debug}) {
        print "About to Binhex $file\n";
        print "Resource size $rsize, data size $size\n";
    }
    $bhex = FileHandle->new;
    $bhex->open($outname,"w") or croak("Unable to open $outname");
    $hqx->encode($bhex);
    $bhex->close;
}

sub debinhex {
#
# BinHex to native Mac
#
    
    use Mac::Files;
    my $bhex;
    my ($data, $testlength, $length,$lname,$ldir,$fd,$i);
    
    my $self = shift;
    my $file = shift || croak("No filename given $!");
    $bhex = FileHandle->new;
    $bhex->open($file,"r") || croak("Unable to open $file: $!");
    my $hqx = Convert::BinHex->open(FH => $bhex);
    $hqx->read_header;
    print $hqx->header_as_string if $self->{Debug};
    my $outname = $hqx->filename;
    ($lname,$ldir) = fileparse($file);

    $outname = uniqify($ldir,$outname);

    FSpCreate($outname, $hqx->creator, $hqx->type)
       or croak("Unable to create Mac file $outname");
    my $reslength = $hqx->resource_length;
    my $datalength = $hqx->data_length;
    $fd = POSIX::open($outname,&POSIX::O_WRONLY|&POSIX::O_CREAT,0755);
    $testlength = 0;
    while(defined($data = $hqx->read_data)) {
        $length = length($data);
        POSIX::write($fd,$data,$length)
          or croak("Couldn't write $length bytes: $!");
        $testlength += $length;
    }
    POSIX::close($fd) or croak "Unable to close $outname";
    croak("Data fork length mismatch, expected $datalength, wrote $testlength")
        if $datalength != $testlength;
    if($reslength) {
        $fd = POSIX::open($outname,
              &Fcntl::O_RSRC | &POSIX::O_WRONLY | &POSIX::O_CREAT,0755);
        $testlength = 0;
        while(defined($data = $hqx->read_resource)) {
            $length = length($data);
            POSIX::write($fd,$data,$length)
                  or croak "Couldn't write $length bytes: $!";
            $testlength += $length;
        }
        POSIX::close($fd) or croak "Unable to close $outname";
        croak("Resource fork length mismatch, expected $reslength, wrote $testlength")
            if $testlength != $reslength;
    }
    my $has = FSpGetCatInfo($outname);
    my $finfo = $has->ioFlFndrInfo;
    $finfo->fdFlags($hqx->flags & 0xfeff); #turn off inited bit
    $finfo->fdType($hqx->type || "????");
    $finfo->fdCreator($hqx->creator || "????");
    if($self->{Debug}) {
        printf "Finder flags: %x\n",$finfo->fdFlags;
        print "File type: ",$finfo->fdType,"\n";
        print "File creator: ",$finfo->fdCreator,"\n";
    }
    $has->ioFlFndrInfo($finfo);
    FSpSetCatInfo($outname,$has)
        or croak "Unable to set catalog info $^E";
    if($self->{Debug}) {
        $has = FSpGetCatInfo ($outname);
        printf "Finder flags for decoded file: %x\n",$has->ioFlFndrInfo->fdFlags;
        print "File type for decoded file: ",$has->ioFlFndrInfo->fdType,"\n";
        print "File creator for decoded file: ",$has->ioFlFndrInfo->fdCreator,"\n";
    }
    $bhex->close;
    if($self->{Remove}) {
        unlink($file) or warn("Unable to remove $file");
    }
}

sub macbinary {
#
# Native Mac to MacBinary II
#
    use Mac::Files;

    my ($macb,$in);
    my ($lname, $ldir, $has, $size, $rsize, $finfo, $outname, $flags,$buf, $n, $i);
    my $total;
    my $self = shift;
    my $file = shift || die "No filename given $!";

    ($lname,$ldir) = fileparse($file);
    $outname = uniqify ($ldir,$lname,"bin");

    $has = FSpGetCatInfo($file);
    $finfo = $has->ioFlFndrInfo;
    $size = $has->ioFlLgLen;
    $rsize = $has->ioFlRLgLen;
    $flags = $finfo->fdFlags;
    if($self->{Debug}) {
        print "About to MacBinary $file\n";
        print "Resource size $rsize, data size $size\n";
    }
    $macb = FileHandle->new;
    $macb->open($outname,"w") or croak("Unable to open $outname");
    my $len = length($lname);
    $buf = pack("xCa63a4a4CxNnCxNNNNnCx14NnCC",
                $len,
                $lname,
                $finfo->fdType,
                $finfo->fdCreator,
                ($finfo->fdFlags & 0xff00) >> 8,
                $finfo->fdLocation,
                0, # $finfo->fdFldr,
                0,
                $size,
                $rsize,
                $has->ioFlCrDat,
                $has->ioFlMdDat,
                0,
                $finfo->fdFlags & 0x00ff,
                0,
                0,
                129,
                129);
    syswrite $macb, $buf, 124;
    my $crc = 0;
    $crc = Convert::BinHex::macbinary_crc($buf,$crc);
    $crc &= 0xffff;
    $crc <<= 16;
    syswrite $macb, pack("N",$crc), 4;
    if($size) {
        $total = 0;
        print "Data Fork\n\n" if $self->{Debug};
        $in = FileHandle->new;
        $in->open($file,"r") or die "Unable to open $file $!";
        while($n = read $in,$buf,2048) {
            if ($n < 2048) {  #assuming here that a file read from the file
                              #system will always return the number of bytes
                              #asked for.  Probably true for local files, but
                              #maybe not for networked disks.
                $n = syswrite $macb, $buf, length($buf);
                $total += $n;
                $n %= 128;
                if($n) {
                    $n = 128 - $n;
                    $buf = pack("x$n");
                    $n = syswrite $macb, $buf, $n;
                    print "Writing $n nulls in last block, $total bytes already written\n"
                                if $self->{Debug};
                }
            } else {
                $n = syswrite $macb, $buf, 2048;
                $total += $n;
            }
        }
        $in->close;
        unless ($size == $total) {
            croak("Size mismatch in data fork: $total, $size");
        }
    }
    if($rsize) {
        $total = 0;
        print "Resource Fork\n\n" if $self->{Debug};
        my $fd = POSIX::open($file,&POSIX::O_RDONLY | &Fcntl::O_RSRC);
        while (($n = POSIX::read($fd, $buf, 2048)) > 0) {
            last unless defined $n;
            if ($n < 2048) {
                $n = syswrite $macb, $buf, length($buf);
                $total += $n;
                $n %= 128;
                if($n) {
                    $n = 128 - $n;
                    $buf = pack("x$n");
                    $n = syswrite $macb, $buf, $n;
                }
            } else {
                $n = syswrite $macb, $buf, 2048;
                $total += $n;
            }
        }
      POSIX::close($fd);
        unless ($rsize == $total) {
            croak("Size mismatch in resource fork: $total, $rsize");
        }
    }
   $macb->close;

}

sub demacbinary {
#
#  Take a MacBinary file and convert it to a native Mac file.
#
    use Mac::Files;
    
    my ($macb,$data);
    my ($buf,$n,$i,$ldir,$lname);
    
    my $self = shift;   
    my $file = shift or croak("No filename given $!");
    $macb = FileHandle->new;
    $macb->open($file,"r") || croak("Unable to open $file: $!");
    $n = read($macb,$buf,128);
	croak("Headerless MacBinary file, that shouldn't be!") unless $n == 128;
    my($namelength,
       $filename,
       $type,
       $creator,
       $highflag,
       $dum1,
       $dum2,
       $dum3,
       $datalength,
       $reslength,
       $dum4,
       $dum5,
       $dum6,
       $lowflag,
       $dum7,
       $dum8,
       $dum9,
       $dum10,
       $crc) = unpack("xCA63a4a4CxNnCxNNNNnCx14NnCCN",$buf);
    $crc >>= 16;  #the CRC itself is in the first two bytes
    if($self->{Debug}) {
        print "Filename = $filename\nType = $type\nCreator = $creator\n";
        print "Data Fork Length = $datalength\nResource Fork Length = $reslength\n";
        printf("CRC = %x\n",$crc);
    }
    my $testcrc = Convert::BinHex::macbinary_crc(substr($buf,0,124));
    $testcrc &= 0xffff;
    printf "Warning: checksum mismatch, %x, %x\n", $crc, $testcrc
        unless $crc == $testcrc;
    ($lname,$ldir) = fileparse($file);

    my $outname = uniqify($ldir,$filename);

    $data = FileHandle->new;
    $data->open($outname,"w") or croak("Unable to open the data fork of $outname");
    my $counter = 0;
    my $tdatalength = $datalength;
#
#  Since both the data and resouce forks are null padded to 128 byte boundaries,
#  I need to be careful to read a multiple of 128 from the MacBinary file, but
#  write only what is actually necessary to the native Mac file
#
    my $tdatarem = $datalength % 128;
    if($datalength) {
        my $datacount = int($datalength/2048);
        for($i = 0;$i < $datacount;$i++) {
            $n = read($macb,$buf,2048);
            syswrite($data,$buf,$n);
            $counter += $n;
            $tdatalength -= $n;
        }
        my $left = $tdatalength + (128 - $tdatarem);
        read($macb,$buf,$left);
        syswrite($data,$buf,$tdatalength);
        $counter += $tdatalength;
    }
    $data->close;
    croak("Data length written $counter != MacBinary data length $datalength")
        unless $counter == $datalength;
#
# Now do the resource fork
#
    my $resfork = POSIX::open($outname,
        &POSIX::O_WRONLY|&Fcntl::O_RSRC |&POSIX::O_CREAT)
        or croak("Unable to open the resource fork of $outname");
    $counter = 0;
#
#  There's no need to worry about the null padding of the resource fork
#  because the resource fork is the last thing in the MacBinary file.
#  Simply read as many bytes as I need.
#
    my $treslength = $reslength;
    if($reslength) {
        my $rescount = int($reslength/2048);
        for($i = 0;$i < $rescount;$i++) {
            $n = read($macb,$buf,2048);
            POSIX::write($resfork,$buf,$n);
            $counter += $n;
            $treslength -= $n;
        }
        read($macb,$buf,$treslength);
        POSIX::write($resfork,$buf,$treslength);
        $counter += $treslength;
    }
    POSIX::close($resfork) or croak("Unable to close $outname");
    croak("Resource length written $counter != MacBinary resource length $reslength")
        unless $counter == $reslength;
    my $has = FSpGetCatInfo($outname);
    my $finfo = $has->ioFlFndrInfo;
    my $flag = (($highflag & 0xffff) << 8) + $lowflag;
    $finfo->fdFlags($flag & 0xfeff); #turn off inited bit
    $finfo->fdType($type || "????");
    $finfo->fdCreator($creator || "????");
    $has->ioFlFndrInfo($finfo);
    FSpSetCatInfo($outname,$has)
        or croak "Unable to set catalog info $^E";
    $macb->close;
    if($self->{Remove}) {
        unlink($file) or warn("Unable to remove $file");
    }
}

sub hex2macb {
#
# BinHex to MacBinary
#
    my ($bhex,$macb);
    my ($data, $testlength, $length,$lname,$ldir,$fd,$buf,$i);

    my $self = shift;
    my $file = shift || croak("No filename given $!");

    $bhex = FileHandle->new;
    $bhex->open($file,"r") || croak("Unable to open $file: $!");

    my $hqx = Convert::BinHex->open(FH => $bhex);

    $hqx->read_header;
    my $outname = $hqx->filename;
    ($lname,$ldir) = fileparse($file);
    $outname = uniqify($ldir,$outname,"bin");

    my $reslength = $hqx->resource_length;
    my $datalength = $hqx->data_length;

    $macb = FileHandle->new;
    $macb->open($outname,"w")  or croak("Unable to open $outname");
    $buf = pack("xCa63a4a4CxNnCxNNNNnCx14NnCC",
                length($hqx->filename),
                $hqx->filename,
                $hqx->type,
                $hqx->creator,
                ($hqx->flags & 0xfe00) >> 8,
                0,
                0,
                0,
                $datalength,
                $reslength,
                0,
                0,
                0,
                $hqx->flags & 0x00ff,
                0,
                0,
                129,
                129);
    syswrite $macb, $buf, 124;
    my $crc = 0;
    $crc = Convert::BinHex::macbinary_crc($buf,$crc);
    $crc &= 0xffff;
    printf("MacBinary CRC: %x\n",$crc) if $self->{Debug};
    $crc <<= 16;
    syswrite $macb, pack("N",$crc), 4;

    $testlength = 0;
    while(defined($data = $hqx->read_data)) {
        $length = length($data);
        syswrite($macb,$data,$length)
          or croak("Couldn't write $length bytes: $!");
        $testlength += $length;
    }
    croak("Data fork length mismatch, expected $datalength, wrote $testlength")
        if $datalength != $testlength;
    my $excess = $testlength % 128;
    if($excess) {
        $excess = 128 - $excess;
        $buf = pack("x$excess");
        $length = syswrite $macb, $buf, $excess;
    }

    $testlength = 0;
    if($reslength) {
        while(defined($data = $hqx->read_resource)) {
            $length = length($data);
            syswrite($macb,$data,$length)
                  or croak "Couldn't write $length bytes: $!";
            $testlength += $length;
        }
        croak("Resource fork length mismatch, expected $reslength, wrote $testlength")
            if $testlength != $reslength;
    }
    $excess = $testlength % 128;
    if($excess) {
        $excess = 128 - $excess;
        $buf = pack("x$excess");
        $length = syswrite $macb, $buf, $excess;
    }

    $macb->close;
    $bhex->close;

    if($self->{Remove}) {
        unlink($file) or warn("Unable to remove $file");
    }
}

sub macb2hex {
#
#  Take a MacBinary file and convert it to BinHex using Convert::BinHex.
#
    my ($bhex,$macb,$tdata,$tres);
    my ($buf,$n,$i,$ldir,$lname);

    my $self = shift;
    my $file = shift or croak("No filename given $!");

    $macb = FileHandle->new;
    $macb->open($file,"r") || croak("Unable to open $file: $!");
    $n = read($macb,$buf,128);
	croak("Headerless MacBinary file, that shouldn't be!") unless $n == 128;
    my($namelength,
       $filename,
       $type,
       $creator,
       $highflag,
       $dum1,
       $dum2,
       $dum3,
       $datalength,
       $reslength,
       $dum4,
       $dum5,
       $dum6,
       $lowflag,
       $dum7,
       $dum8,
       $dum9,
       $dum10,
       $crc) = unpack("xCA63a4a4CxNnCxNNNNnCx14NnCCN",$buf);
    $crc >>= 16;  #the CRC itself is in the first two bytes
    if($self->{Debug}) {
        print "Filename = $filename\nType = $type\nCreator = $creator\n";
        print "Data Fork Length = $datalength\nResource Fork Length = $reslength\n";
        printf("CRC = %x\n",$crc);
    }
    my $testcrc = Convert::BinHex::macbinary_crc(substr($buf,0,124));
    $testcrc &= 0xffff;
    printf "Warning: checksum mismatch, %x, %x\n",$crc, $testcrc
        unless $crc == $testcrc;
    my $hqx = Convert::BinHex->new;
    ($lname,$ldir) = fileparse($file);
    my $outname = uniqify($ldir,$filename,"hqx");

#
#  Simplest way to do this with the tools available is to first create
#  two temporary files, one with the data fork, one with the resource fork
#
    my $tdataname = uniqify($ldir,$filename,"datat");
    $tdata = FileHandle->new;
    $tdata->open($tdataname,"w") or croak("Unable to open $tdataname");
    my $counter = 0;
    my $tdatalength = $datalength;
#
#  Since both the data and resouce forks are null padded to 128 byte boundaries,
#  I need to be careful to read a multiple of 128 from the MacBinary file, but
#  write only what is actually necessary to the temporary.
#
    my $tdatarem = $datalength % 128;
    if($datalength) {
        my $datacount = int($datalength/2048);
        for($i = 0;$i < $datacount;$i++) {
            $n = read($macb,$buf,2048);
            syswrite($tdata,$buf,$n);
            $counter += $n;
            $tdatalength -= $n;
        }
        my $left = $tdatalength + (128 - $tdatarem);
        read($macb,$buf,$left);
        syswrite($tdata,$buf,$tdatalength);
        $counter += $tdatalength;
    }
    $tdata->close;
    croak("Data length written $counter != MacBinary data length $datalength")
        unless $counter == $datalength;
    my $tresname = uniqify($ldir,$filename,"rsrct");
    $tres = FileHandle->new;
    $tres->open($tresname,"w");
    $counter = 0;
#
#  There's no need to worry about the null padding of the resource fork
#  because the resource fork is the last thing in the MacBinary file.
#  Simply read as many bytes as I need.
#
    my $treslength = $reslength;
    if($reslength) {
        my $rescount = int($reslength/2048);
        for($i = 0;$i < $rescount;$i++) {
            $n = read($macb,$buf,2048);
            syswrite($tres,$buf,$n);
            $counter += $n;
            $treslength -= $n;
        }
        read($macb,$buf,$treslength);
        syswrite($tres,$buf,$treslength);
        $counter += $treslength;
    }
    $tres->close;
    croak("Resource length written $counter != MacBinary resource length $reslength")
        unless $counter == $reslength;

    $hqx->filename($filename);
    $hqx->creator($creator);
    $hqx->type($type);
    my $flag = (($highflag & 0xffff) << 8) + $lowflag;
    $hqx->flags($flag);
    $hqx->data->length($datalength);
    $hqx->resource->length($reslength);
    $hqx->resource(Path => $tresname);
    $hqx->data(Path => $tdataname);
    $bhex = FileHandle->new;
    $bhex->open($outname,"w");
    $hqx->encode($bhex);

    unlink($tresname);
    unlink($tdataname);
    $bhex->close;
    $macb->close;

    if($self->{Remove}) {
        unlink($file) or warn("Unable to remove $file");
    }
}

sub uniqify ($$;$) {
    my ($dir,$name,$ext) = @_;
    my $i;
    my $j = defined($ext) ? (length($ext) + 1) : 0;
    $name = substr($name,(-31 + $j)) if (length($name) > (31 - $j));
    my $fullname = $j ? $dir.$name.".$ext" : $dir.$name;
    if(-e $fullname) {
        my $newname;
        for($i = 1;$i <= 100;$i++) {
            $newname = $j ? "$name.$i.$ext" : "$name.$i";
            $newname = substr($newname,-31) if length($newname) > 31;
            last unless (-e $dir.$newname);
        }
        return $dir.$newname;
    }
    return $fullname;
}


1;
__END__

=head1 NAME

Mac::Conversions - A package for common MacOS file encoding/decoding tasks

=head1 SYNOPSIS

    use Mac::Conversions qw(binhex debinhex macbinary demacbinary macb2hex hex2macb);
    $converter = Mac::Conversions->new;

    $converter->binhex("path:to:MacPerl");
    $converter->debinhex("path:to:MacPerl.hqx");

    $converter->macbinary("path:to:Shuck");
    $converter->demacbinary("path:to:Shuck.bin");

    $converter->macb2hex("path:to:MacPerl.hqx");
    $converter->hex2macb("path:to:MacPerl.bin");

=head1 DESCRIPTION

C<Mac::Conversions> is a class implementing converters for the types
of file encoding/decoding routinely done when using MacOS.  All of these rely
on the presence of the C<Convert::BinHex> module, and C<Mac::Conversions> will
not run if C<Convert::BinHex> is not installed.

The conversions are:

=over 4

=item C<binhex($path)>

Take the native Macintosh file pointed to by $path and create a BinHex file 
in the same folder.  If the native Macintosh file is named "name", the 
BinHex file is named "name.hqx", unless "name.hqx" already exists.  Then 
C<binhex> will attempt to find a unique name by inserting integers in the 
name, "name.0.hqx", "name.1.hqx", etc.

=item C<debinhex($path)>

Take the BinHex file pointed to by $path and decode it to reconstruct the 
native Macintosh file.  The name of the file will be that encoded into the 
BinHex file if a file of that name doesn't exist.  Otherwise, a unique name 
will be constructed by adding integers after the name.

=item C<macbinary($path)>

Take the native Macintosh file pointed to by $path and create a MacBinaryII 
file.  The name of the MacBinary file will be "name.bin" if the native file 
is called "name", but C<macbinary> will try to find a unique name in the 
same way that C<binhex> does if a file "name.bin" already exists.

=item C<demacbinary($path)>

The MacBinary II file pointed to by $path will be decoded to a native 
Macintosh file.  The name of the file will be that encoded into the 
MacBinary file, except a unique name will be constructed if a file of
that name already exists.

=item C<hex2macb($path)>

The BinHex file $path is converted to a MacBinary file.  The name will be 
"name.bin", where name is the name of the file encoded in the BinHex file,
with the usual caveat.

=item C<macb2hex($path)>

The MacBinary II file $path is converted to BinHex.

=item C<new>

The constructor for the class.  If new is called with Debug => 1

$c = Mac::Conversions->new(Debug => 1);

then semi-useful debugging information will be printed to standard output.  
If Remove => 1 is set, then the original BinHex or MacBinary (but never a 
native Mac file) will be unlinked.  (Note this means that it doesn't simply 
get moved to the Trash but disappears forever.)

=back

=head1 SEE ALSO

See the documentation for C<Convert::BinHex>, where all the heavy lifting is really done.

=head1 COPYRIGHT

  Copyright 1999, Paul J. Schinder

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
