#!/usr/local/bin/perl -w
#
#	$Id: appledouble,v 1.1 2003/05/28 21:30:57 sjh Exp sjh $
##
#	'appledouble'		
#
#	Description:	
#
#	Author:			Broc Seib
#	       			Purdue University Computing Center
#	Date:			Wed Mar 13 18:09:59 EST 2002
##


# Here is the appledouble conversion script I'm working with. I run it with 
# the following command line:

# appledouble -v2 -r92 -s -f file.ad file1.ad

# The file.ad arg is the original apple double file and the result goes
# into file1.ad.

use Data::Dumper;

use Getopt::Std;

my $USAGE = qq{
usage: appledouble [-bcmfs] [-v 1|2] [-r rec_order] infile outfile
  This tool reads in "infile", reorders the header records in the order
  you specfy, then writes to "outfile". If you specify a <<rec_order>>
  with a subset of the record present, it will drop those extra records
  and not write them out to the outfile. It is crude.

  The -r rec_order option lets you reorder, or drop sections of the file
  when it is rewritten to the outfile. This arg is just a comglomeration
  of characters in the set [1-9A-Fa-f]. If you do not pass this arg, it
  will preserve all the sections. The output file will then be a valid
  appledouble in-spec file, but it may be different than the original.
  NFS/Share left "holes" filled with noise in their version.

  The -b option will align all records to be written out on 4-byte
  boundaries.

  The -c option will read in records 8 and 10 and combine them into
  a record 7. It will be as if the file you read in had a record 7
  instead of an 8 and 10.

  The -v option will let you force the output file being written as
  version 1 or 2. (just forces the 4-byte version field value...)

  The -m option engages timestamp correction. It causes timestamps
  in record 8 to be converted from Mac 1904 epoch timestamps into
  midnght 2000 GMT epoch signed timestamps (per AppleDouble spec.)
  NFS/Share timestamps in record 8 are 1904 based.

  The -f option forces records to have pre-computed fixed values for
  their offsets. (Netatalk does this.) This will allow you to build
  records identical to how netatalk would. The constants used in this
  tool match what the purdue-modified netatalk expects. This will force
  the presence of records that did not exist in the source file (you
  still have to specify them). The values used for such records will
  be what our netatalk writes (namely zero length, or zero padded
  data chunks).

  The -s option forces the filename string to be written out as a
  "C" string. (NFS/Share stored it as a pascal string.)

};

## get the command line options
$opt_b = 0;
$opt_c = 0;
$opt_h = 0;
$opt_r = 0;
$opt_v = 0;
$opt_m = 0;
$opt_f = 0;
$opt_s = 0;
getopts('bchr:v:mfs');

die $USAGE if $opt_h;
$opt_v = 0 if ( $opt_v  and  $opt_v !~ m/^1|2$/ );

my $order;
if ( $opt_r ) {
	$nums = uc ( $opt_r );
	unless ( $nums =~ m/^[1-9A-F]+$/ ) {
		die $USAGE;
	}
	$order = get_order($nums);
}

my $infile  = shift @ARGV  or die $USAGE;
my $outfile = shift @ARGV  or die $USAGE;


my $ad = new AppleDouble($infile,$opt_c,$opt_m,$opt_s,$opt_f);
#print Dumper $ad;
#print "\n";

$ad->reorder_header($order); ## if $order is undef, it will default to "same"
#print Dumper $ad;
#print "\n";
#print "Calling write_file\n";

$ad->write_file($outfile);


sub get_order {
	my $nums = shift;
	my @list = split(//,$nums);
	my $order = [];
	my $hash = {};

	for (@list) {
		unless ( $hash->{$_} ) {
			$num = $_;
			if ( $_ =~ /^[A-F]$/ ) {
				$num = ord($_) - ord('A') + 10;
			}
			push @$order, $num;
			$hash->{$_}++;
		}
	}

	return $order;
}


package AppleDouble;
use Data::Dumper;

##
#	these are other constants needed here
##
our $RECTYPES = {
		1	=>	'DataFork',
		2	=>	'ResourceFork',
		3	=>	'RealName',
		4	=>	'Comment',
		5	=>	'IconBW',
		6	=>	'IconColor',
		8	=>	'FileDatesInfo',
		9	=>	'FinderInfo',
		10	=>	'MacintoshFileInfo',
		11	=>	'ProDOSFileInfo',
		12	=>	'MSDOSFileInfo',
		13	=>	'ShortName',
		14	=>	'AFPFileName',
		15	=>	'DirectoryID',
};




sub new {
	my $class = shift;
	my $filename = shift;   ## pass in a mac meta-data-file filename
	my $convert7 = shift;
	my $convert_ts = shift;
	my $convert_str = shift;
	my $convert_fixed = shift;

	unless ( -r $filename ) {
		warn "Can't read file $filename.\n";
		return undef 
	}
	my $self = {
		'filename' => $filename,
		'error'    => undef,
		'convert7' => $convert7,
		'convert_ts' => $convert_ts,
		'convert_str' => $convert_str,
		'convert_fixed' => $convert_fixed,
		'recdefs'  => {
			'2'		=>	[ 0x0299, undef, undef ],
			'3'		=>  [ 0x0086, 0xff,  0xff  ],
			'4'		=>	[ 0x0185, 0xc8,  0x00  ],
			'8'		=>	[ 0x024d, 0x10,  0x10  ],
			'9'		=>	[ 0x025d, 0x20,  0x20  ],
			'15'	=>	[ 0x027d, 0x04,  0x04  ],
			'14'	=>	[ 0x0281, 0x04,  0x04  ],
			'13'	=>	[ 0x0285, 0x0c,  0x00  ],
			'11'	=>	[ 0x0291, 0x08,  0x08  ],
		},
	};
	$self->{'recdefs'}{'f'} = $self->{'recdefs'}{'15'};
	$self->{'recdefs'}{'e'} = $self->{'recdefs'}{'14'};
	$self->{'recdefs'}{'d'} = $self->{'recdefs'}{'13'};
	$self->{'recdefs'}{'b'} = $self->{'recdefs'}{'11'};
	bless $self, $class;

	my $info = $self->read_file();
	die $self->error() unless $info;

	$self->{'info'} = $info;
	return $self;
}

sub error {
	my $self = shift;
	my $err = shift;

	if ( defined($err) ) {
		$self->{'error'} = $err;
	}
	return $self->{'error'};
}

sub reorder_header {
	my $self = shift;
	my $i = $self->{'info'};
	my $order = shift || $i->{'order'}; ## list ref to desired order

	my $end = 4 + 4 + 16 + 2 + (scalar @$order) * 12;

	my $exists_order = [];
	for ( @$order ) {
		## make sure the ones they are asking for actually exist! Drop
		## those that don't
		next unless (exists($i->{'entry'}{$_}));
		push @$exists_order, $_;

		if ( $main::opt_b) {
			$end += ( $end * (4-1) ) % 4 ; ## round on or up to nearest 4
		}
		if ( ! $self->{'convert_fixed'} ) {
			$i->{'entry'}{$_}{'_offset'} = $end;
		}
		$end += $i->{'entry'}{$_}{'_len_phys'};
	}

	$i->{'entries'} = scalar @$order;
	$i->{'order'} = $exists_order;
}

sub write_file {
    my $self = shift;
    my $file = shift || $self->{'filename'};
    my $i = $self->{'info'};

    my $fh = 'OUTFILE';
    my $err;

    ## update version number?
    if ( $main::opt_v ) {
	$i->{'version'} = 0x00010000  if ( 1 == $main::opt_v );
	$i->{'version'} = 0x00020000  if ( 2 == $main::opt_v );
    }

    ## Ok, I had to look in /usr/include/sys/fcntl.h to get these. It
    ## Seems when Fcntl was built, something was wrong...
    ##
    ## O_RDONLY = 0x0000
    ## O_RDWR   = 0x0002
    ## O_CREAT  = 0x0100
    ## O_TRUNC  = 0x0200
    ##
    if ( $err = sysopen($fh,$file, 0x0200|0x0100|0x0002 ) ) {
	PutNum($i->{'magic'},   $fh,4);
	PutNum($i->{'version'}, $fh,4);
	PutBuf($i->{'filler'},  $fh,16);
	PutNum($i->{'entries'}, $fh,2);
	
	## if any _len values were changed, recalc them before we write out
        #  $self->reorder_header();
	
	for my $type ( @{$i->{'order'}} ) {
            # print Dumper $i->{'entry'}{$type};
            # print "rec=$type\n";

	    # skip this whole thing if the content is undefined, but the length > 0
            # modified by mthole
            next if ( (! defined ($i->{'entry'}{$type}{'_content'})) && 
                    ( ($i->{'entry'}{$type}{'_len_head'}) > 0));
            
	    PutNum($type,                            $fh,4);
	    PutNum($i->{'entry'}{$type}{'_offset'},  $fh,4);
	    PutNum($i->{'entry'}{$type}{'_len_head'},$fh,4);
	}
	for my $type ( @{$i->{'order'}} ) {
	    my $offset = $i->{'entry'}{$type}{'_offset'};
	    my $len    = $i->{'entry'}{$type}{'_len_phys'};
	    my $cont   = $i->{'entry'}{$type}{'_content'};
	    next unless ( $len > 0 );
	    if ( $type == 13  or  $type == 2 ) {
		my $cont_len = length unpack('a*',$cont);
		if ( $cont_len != $len ) {
		    $len = $cont_len;
		    
                    #DEBUG:	print STDERR "rec $type content length will be $cont_len\n";
		}
	    }
	    print "Calling PutBuf('cont', $fh, $len, $offset)\n";
	    PutBuf($cont,$fh,$len,$offset);
	}
	close $fh;
    } else {
	warn("Can't open file $file for write (err=$err)");
    }

    return undef;
}

sub read_file {
    my $self = shift;
    my $file = $self->{'filename'};

    my $info = {};	## hash ref to info in file.
    my $fh = 'FH';
    if ( sysopen($fh,$file,0) ) {	## 0 mode means read-only
	my $magic = GetNum($fh,4);
	if ($magic != 0x00051607) {
	    ## this is not a apple double format file!
	    warn("Not Apple Double Format file!: $file");
	    close $fh;
	    return undef;
	}
	$info->{'magic'} = $magic;
	$info->{'version'} = GetNum($fh,4);
	$info->{'filler'}  = GetBuf($fh,16);
	$info->{'entries'} = GetNum($fh,2);
	my $i;
	my $has3  = 0; ## real filename
	my $has8  = 0;
	my $has10 = 0;
	for ($i=0;$i<$info->{'entries'};$i++) {
	    my $type   = GetNum($fh,4);
	    my $offset = GetNum($fh,4);
	    my $len    = GetNum($fh,4);
	    $has3  = $type  if ( $type == 3  );
	    $has8  = $type  if ( $type == 8  );
	    $has10 = $type  if ( $type == 10 );
	    push @{$info->{'order'}}, $type;
	    $info->{'entry'}{$type}{'_offset'}  = $offset;
	    $info->{'entry'}{$type}{'_len_phys'}= $len;
	    $info->{'entry'}{$type}{'_len_head'}= $len;
	    
	    ## this is the only record that has no fixed length.
	    ## so record it when we see it.
	    if ( $type == 2 ) {
		$self->{'recdefs'}{'2'}[1] = $len; ## phys rec length 
		$self->{'recdefs'}{'2'}[2] = $len; ## rec len says header
	    }
	}
	
#print Dumper $info;
	for my $type ( keys %{$info->{'entry'}} ) {
	    my $offset = $info->{'entry'}{$type}{'_offset'};
	    my $len    = $info->{'entry'}{$type}{'_len_phys'};
	    

#DEBUG:	    print "type=$type offset=$offset len=$len\n";
	    my $content = GetBuf($fh,$len,$offset); # if $len is 0 this will
				                    # return undef.

            # commented out by mthole
            # if( defined($content)) { # this if statement added by SJH
            # 	$content =~ s/(.)/sprintf("%02x", ord($1))/eg;
            # }

            # added by mthole
            if(!defined($content)) {
                $content="";
            }

	    $info->{'entry'}{$type}{'_content'} = $content;
	}
	
	## if converting timestamps in record 8, do it now (before 'convert7')
	if ( $self->{'convert_ts'}  and  $has8 ) {
	    my @ts = unpack('LLLL',$info->{'entry'}{$has8}{'_content'});
	    my @nts;
	    for ( @ts ) {
		## Yeah, um, 0xb492f400 is the number of seconds between
		## midnight Jan 1, 1904 GMT and midnight Jan 1, 2000 GMT
		push @nts, ( $_ - 0xb492f400 );
		printf("%08x\n",$_);
	    }
	    $info->{'entry'}{$has8}{'_content'} = pack('llll',@nts);
	}
	
	## if converting record 7, look for recs 8 and 10 and convert them
	## into a record 7 by rereading them from the file w/ special GetBuf
	if ( $self->{'convert7'}  and  $has8  and  $has10 ) {
	    my $offset8  = $info->{'entry'}{$has8}{'_offset'};
	    my $len8     = $info->{'entry'}{$has8}{'_len_phys'};
	    
	    my $offset10 = $info->{'entry'}{$has10}{'_offset'};
	    my $len10    = $info->{'entry'}{$has10}{'_len_phys'};
	    
	    my $content = GetBuf($fh,$len8-4,$offset8,$len10,$offset10);
	    $info->{'entry'}{'7'} = $info->{'entry'}{$has8};
	    $info->{'entry'}{'7'}{'_content'} = $content;
	    
	    ## remove 8 and 10
	    delete $info->{'entry'}{$has8};
	    delete $info->{'entry'}{$has10};
	    
	    ## fixup "order"
	    my @neworder;
	    for ( @{$info->{'order'}} ) {
		if ( $_ == 8 ) {
		    push @neworder, '7';
		} elsif ( $_ == 10 ) {
		    next;
		} else {
		    push @neworder, $_;
		}
	    }
	    
	    $info->{'entries'} = scalar @neworder;
	    $info->{'order'} = \@neworder;
	}
	
	## if forcing fixed offsets and records, fill in missing records
	if ( $self->{'convert_fixed'} ) {
	    my $rd = $self->{'recdefs'};
	    for ( keys %{$self->{'recdefs'}} ) {
		next if ( /^[a-f]$/i );
		
		if ( !exists($info->{'entry'}{$_}) ) {
		    push @{$info->{'order'}}, $_;
		    
		    ## if there was no rec 2, then set lengths to 0
		    if ( $_ == 2 ) {
			$self->{'recdefs'}{'2'}[1] = 0; ## phys rec length 
			$self->{'recdefs'}{'2'}[2] = 0; ## rec len says header
		    }
		}
		
		if ( !exists($info->{'entry'}{$_}{'_content'})  and
		     defined($rd->{$_}[1]) ) {
		    $info->{'entry'}{$_}{'_content'}=pack("a$rd->{$_}[1]",'');
		}
		$info->{'entry'}{$_}{'_offset'} = $rd->{$_}[0];
		$info->{'entry'}{$_}{'_len_phys'} = $rd->{$_}[1];
		$info->{'entry'}{$_}{'_len_head'} = $rd->{$_}[2];
		
	    }
	    $info->{'entries'} = scalar @{$info->{'order'}};
	}
	
	## if converting pascal -> C String
	if ( $self->{'convert_str'}  and  $has3 ) {
	    my $len = unpack('C',$info->{'entry'}{$has3}{'_content'});
	    my $str="";
            if(defined($len) && $len > 0) {	# added by mthole
                ($len,$str) = unpack("Ca$len",$info->{'entry'}{$has3}{'_content'});
                #print "len=$len\n";
                #print "str=$str\n";
                
                my $bufsz;
                if ( $self->{'convert_fixed'} ) {
                    $bufsz = $self->{'recdefs'}{'3'}[1]; ## should be 255
                } else {
                    $bufsz = $len;
                }
                $info->{'entry'}{$has3}{'_content'} = pack("a$bufsz",$str);
                $info->{'entry'}{$has3}{'_len_phys'} = $bufsz;
                $info->{'entry'}{$has3}{'_len_head'} = $len;
                }
	}
	
	close $fh;
	return $info;
    } else {
	warn("Can't open file $file.");
    }

    return undef;
}



sub GetRecType {
	my $i = shift;
	if (exists($RECTYPES->{$i})) {
		return $RECTYPES->{$i};
	} else {
		return $i;
	}
}


sub GetNum {
	my $fh    = shift;		## the filehandle (string)
	my $bytes = shift;
	my $offset = shift || undef;
	my $buf = GetBuf($fh,$bytes,$offset);
	my $num;
	if ($bytes == 4) {
		$num = unpack('l',$buf);
	} elsif ($bytes == 2) {
		$num = unpack('S',$buf);
	} else {
		$num = undef;
	}
	return $num;
}

#sub GetStr {
#	my $fh    = shift;		## the filehandle (string)
#	my $bytes = shift;
#	my $offset = shift || undef;
#	my $buf = GetBuf($fh,$bytes,$offset);
#	my $str = unpack("a$bytes",$buf);
#	return $str;
#}

sub GetBuf {
    my $fh    = shift;		## the filehandle (string)
    my $bytes = shift;
    my $offset = shift || undef;
    my $b2 = shift;
    my $o2 = shift; ## special case to read two parts of file and cat them

    if (defined($offset)) {
	## user wants to lseek to different spot in file
	seek($fh,$offset,0); ## offset from beginning of file.
    }
    my $bytes_requested = $bytes;
    my $buf_index = 0;
    my $buf;
    
    # it doesn't make sense to read 0 bytes (added by SJH)
    if ( $bytes_requested <= 0 ) {
	return undef;
    }
    do {
	my $len = sysread($fh,$buf,$bytes_requested,$buf_index);
	if ( ! defined($len) ) {
	    die "sysread returned error. $!";
	    $bytes_requested = $len = 0;
	} elsif ( $len == 0 ) {
	    die "sysread reached end-of-file before expected.";
	    $bytes_requested = $len = 0;
	}
	$bytes_requested -= $len;
	$buf_index += $len;
    } while ($bytes_requested > 0);

    if ( $b2 ) {
	if (defined($o2)) {
	    ## user wants to lseek to different spot in file
	    seek($fh,$o2,0); ## offset from beginning of file.
	}
	my $bytes_requested = $b2;
	do {
	    my $len = sysread($fh,$buf,$bytes_requested,$buf_index);
	    if ( ! defined($len) ) {
		die "sysread returned error. $!";
		$bytes_requested = $len = 0;
	    } elsif ( $len == 0 ) {
		die "sysread reached end-of-file early.";
		$bytes_requested = $len = 0;
	    }
	    $bytes_requested -= $len;
	    $buf_index += $len;
	} while ($bytes_requested > 0);
    }

    return $buf;
}

sub PutNum {
	my $val   = shift;
	unless (defined($val)) {
		my $i = 0;
		while ( @x = caller($i++) ) {
			print "$x[3], line $x[2]\n";
		}
		die;
	}

	my $fh     = shift;		## the filehandle (string)
	my $bytes  = shift;
	my $offset = shift || undef;

	my $buf;
	if ($bytes == 4) {
		$buf = pack('l',$val);
	} elsif ($bytes == 2) {
		$buf = pack('S',$val);
	} else {
		$buf = undef;
	}

	$val = PutBuf($buf,$fh,$bytes,$offset);
	return $val;
}

sub PutBuf {
	my $val    = shift;
	unless (defined($val)) {
		my $i = 0;
		while ( @x = caller($i++) ) {
			print "$x[3], line $x[2]\n";
		}
		die;
	}

	my $fh     = shift;		## the filehandle (string)
	my $bytes  = shift;
	my $offset = shift || undef;

	if (defined($offset)) {
		## user wants to lseek to different spot in file
		seek($fh,$offset,0); ## offset from beginning of file.
	}
	my $bytes_requested = $bytes;
	my $buf_index = 0;
	do {
		my $len = syswrite($fh,$val,$bytes_requested,$buf_index);
		#print "len=$len\n";
		die "write error!" unless($len);
		$bytes_requested -= $len;
		$buf_index += $len;
	} while ($bytes_requested > 0);
	return $val;
}


1;


##
#	EOF
##