=head1 NAME

Data::Plist::BinaryWriter - write binary property lists
from Perl data structures

=head1 SYNOPSIS

 # Create new
 my $write = Data::Plist::BinaryWriter->new();

 # Writing to a string ($ret is binary output)
 my $ret = $write->write($data);

 # Writing to a file C<$filename>
 $write->write($filename, $data);

=head1 DESCRIPTION

C<Data::Plist::BinaryWriter> takes perl data structures,
serializes them (see L<Data::Plist/SERIALIZED DATA>) and
recursively writes to a given filehandle in Apple's binary
property list format.

=cut

package Data::Plist::BinaryWriter;

use strict;
use warnings;
use Storable;
use Math::BigInt;
use Digest::MD5;

use base qw/Data::Plist::Writer/;

=head1 METHODS

=head2 write_fh $fh, $data

Takes a perl data structure C<$data>, serializes it (see
L<Data::Plist/SERIALIZED DATA>) and writes it to the given
filehandle C<$fh> in Apple's binary property list format.

The format starts with "bplist00" and contains a 32-byte
trailer. The 32-byte trailer consists of the size of the
offset objects in the offset table, the size of the indices
of the offset table, the number of objects in the binary
file, the index of top object in the binary file and the
offset table offset.

=cut

sub write_fh {
    my $self = shift;
    $self = $self->new() unless ref $self;

    my ( $fh, $object ) = @_;
    $object = $self->serialize($object) if ( $self->{serialize} );
    binmode $fh;
    $self->{fh}       = $fh;
    $self->{index}    = [];
    $self->{size}     = $self->count($object);
    $self->{objcache} = {};
    if ( $self->{size} >= 2**8 ) {
        $self->{refsize} = 2;
    } else {
        $self->{refsize} = 1;
    }
    print $fh "bplist00";
    my $top_index    = $self->dispatch($object);
    my $offset_size  = $self->bytes( $self->{index}->[-1] );
    my $table_offset = tell $fh;
    for ( @{ $self->{index} } ) {
        my $value = pack $self->pack_in( $offset_size - 1 ), $_;
        if ( $offset_size == 3 ) {
            $value = substr $value, -3;
        }
        print $fh $value;
    }
    print $fh ( pack "x6CC", ($offset_size), $self->{refsize} );
    print $fh ( pack "x4N", scalar keys %{ $self->{objcache} } );
    print $fh ( pack "x4N", $top_index );
    print $fh ( pack "x4N", $table_offset );
    close $fh;
    return 1;
}

=head2 dispatch $data

Takes serialized data structure C<$data> (see
L<Data::Plist/SERIALIZED DATA>) and checks its type. Checks
the object against previously written objects. If no match
is found, calls the appropriate write_ method. Returns the
index into the offset table of the offset object that
points to the data's position in the binary file.

=cut

sub dispatch {
    my $self       = shift;
    my ($arrayref) = @_;
    my $type       = $arrayref->[0];
    my $method     = "write_" . $type;
    local $Storable::canonical = 1;
    my $digest = eval { Digest::MD5::md5_hex( Storable::freeze($arrayref) ) };
    die "Can't $method" unless $self->can($method);
    $self->{objcache}{$digest} = $self->$method( $arrayref->[1] )
        unless ( exists $self->{objcache}{$digest} );
    return $self->{objcache}{$digest};
}

=head2 make_type $type, $length

Takes a string representing the object's type C<$type> and an
integer indicating its size C<$length>. Returns their binary
representation.

Each object in the binary file is preceded by a byte - the
higher nybble denoting its type and the lower its size. For
objects whose size is equal to or great than 15, the lower
byte contains an f and an integer object is added right
after the first byte containing the object's actual size.

=cut

sub make_type {
    my $self = shift;
    my ( $type, $len ) = @_;
    my $ans = "";

    my $optint = "";
    if ( $len < 15 ) {
        $type .= sprintf( "%x", $len );
    } else {
        $type .= "f";
        my $optlen = $self->power($len);
        $optint = pack( "C" . $self->pack_in($optlen), hex( "1" . $optlen ),
            $len );
    }
    $ans = pack( "H*", $type ) . $optint;

    return $ans;
}

=head2 write_integer $int, $type

Takes an integer C<$int> and an optional type C<$type>
(used for writing UIDs, since they're essentially the
same). Returns the index into the offset table of the
offset object that points to the integer's location in the
binary file.

=cut

sub write_integer {
    my $self = shift;
    my ( $int, $type ) = @_;
    my $fmt;
    my $obj;

    unless ( defined $type ) {
        $type = "1";
    }
    my $len = $self->power($int);

    if ( $len == 3 ) {
        if ( $int < 0 ) {
            $int += Math::BigInt->new(2)->bpow(64);
        }
        my $hw = Math::BigInt->new($int);
        $hw->brsft(32);
        my $lw = Math::BigInt->new($int);
        $lw->band( Math::BigInt->new("4294967295") );

        $obj
            = $self->make_type( $type, $len )
            . pack( "N", $hw )
            . pack( "N", $lw );
    } else {
        $fmt = $self->pack_in($len);
        $obj = pack( "C" . $fmt, hex( $type . $len ), $int );
    }
    return $self->binary_write($obj);
}

=head2 write_string $string

Takes a string C<$string> and returns the index into the offset table
of the offset object that points to its location in the binary file.
It is encoded in the file using UTF-8.

=cut

sub write_string {
    my $self     = shift;
    my ($string) = @_;
    my $type     = $self->make_type( "5", length($string) );
    my $obj      = $type . $string;
    return $self->binary_write($obj);
}

=head2 write_ustring $ustring

Takes a string C<$ustring> and returns the index into the offset table
of the offset object that points to its location in the binary file.

While C<ustrings> are technically supposed to be stored in UTF-16,
there is no known reason for them to not be written as UTF-8 encoded
C<string>s instead; thus, for simplicity, all C<ustring>s are written
as C<string>s.

=cut

sub write_ustring {
    my $self = shift;
    return $self->write_string(@_);
}

=head2 write_dict $dict

Takes a hash reference C<$dict> and recursively processes
each of its keys and values. Stores indices into the offset
table of the offset objects pointing to its keys and values
in the binary file. Returns the index into the offset table
of the offset object that points to its location in the
binary file.

=cut

sub write_dict {
    my $self   = shift;
    my $fh     = $self->{fh};
    my ($hash) = @_;
    my @keys;
    my @values;
    for my $key ( keys %$hash ) {
        push @keys, $self->dispatch( [ "string", $key ] );
        push @values, $self->dispatch( $hash->{$key} );
    }
    my $current = tell $self->{fh};
    print $fh $self->make_type( "d", scalar keys(%$hash) );
    my $packvar = $self->pack_in( $self->{refsize} - 1 );
    print $fh pack $packvar, $_ for @keys, @values;
    push @{ $self->{index} }, $current;
    return ( @{ $self->{index} } - 1 );
}

=head2 write_array $array

Take an array reference C<$array> and recursively processes
its contents. Stores the indices into the offset table of
the offset objects pointing to its value. Returns the index
into the offset table of the offset object that points to
its location in the binary file.

=cut

sub write_array {
    my $self    = shift;
    my $fh      = $self->{fh};
    my ($array) = @_;
    my $size    = @$array;
    my @values;
    for (@$array) {
        push @values, $self->dispatch($_);
    }
    my $current = tell $self->{fh};
    print $fh $self->make_type( "a", $size );
    my $packvar = $self->pack_in( $self->{refsize} - 1 );
    print $fh pack $packvar, $_ for @values;
    push @{ $self->{index} }, $current;
    return ( @{ $self->{index} } - 1 );
}

=head2 write_UID $id

Takes a UID C<$id> and returns the index into the offset
table of the offset object that points to its location in
the binary file. Passes the UID off to L</write_integer> for
actual writing, since they're processed in the same manner,
simply with different types.

=cut

sub write_UID {
    my $self = shift;
    my ($id) = @_;
    return $self->write_integer( $id, "8" );
}

=head2 write_real $real, $type

Takes a float C<$real> and an optional type C<$type>
(used for writing dates, since they're essentially the
same), and returns the index into the
offset table of the offset object that points to its
location in the binary file. The bytes of the float are
packed in reverse.

=cut

sub write_real {
    my $self    = shift;
    my ($float, $type) = @_;
    unless ( defined $type ) {
        $type = "2";
    }
    my $obj     = $self->make_type( $type, 3 ) . reverse( pack( "d", $float ) );
    return $self->binary_write($obj);
}

=head2 write_date $date

Takes a date C<$date> and returns the index into the offset
table of the offset object that points to its location in
the binary file. Passes the date off to L</write_real> for
actual writing, since they're processed in the same manner,
simply with different types.

=cut

sub write_date {
    my $self   = shift;
    my ($date) = @_;
    return $self->write_real($date, "3");
}

=head2 write_null $null

Takes a null C<$null> and passes it to L</write_misc>, along
with an integer indicating what type of misc it is. The
null belongs to the misc category (see L</write_misc>).

=cut

sub write_null {
    my $self = shift;
    return $self->write_misc( 0 );
}

=head2 write_false $false

Takes a false C<$false> and passes it to L</write_misc>, along with an
integer indicating what type of misc it is. The false
belongs to the misc category (see L</write_misc>).

=cut

sub write_false {
    my $self = shift;
    return $self->write_misc( 8 );
}

=head2 write_true $true

Takes a true C<$true> and passes it to L</write_misc>, along with an
integer indicating what type of misc it is. The true
belongs to the misc category (see L</write_misc>).

=cut

sub write_true {
    my $self = shift;
    return $self->write_misc( 9 );
}

=head2 write_fill $fill

Takes a fill C<$fill> and passes it to L</write_misc>, along with an
integer indicating what type of misc it is. The fill
belongs to the misc category (see L</write_misc>).

=cut

sub write_fill {
    my $self = shift;
    return $self->write_misc( 15 );
}

=head2 write_misc $type

Takes an integer indicating an object belonging to the misc
category C<$type> (false, null, true or fill) and returns
the index into the offset table of the offset object that
points to its location in the file.

Miscs are a group of data types not easily represented in Perl, and
they are written with the only header byte containing a 0 to indicate
that they are a misc and their misc type.

=cut

sub write_misc {
    my $self = shift;
    my ( $type ) = @_;
    my $obj = $self->make_type( "0", $type );
    return $self->binary_write($obj);
}

=head2 write_data $data

Takes some binary data C<$data> and returns the index into the
offset table of the offset object that points to its
location in the file. Doesn't attempt to process the data
at all.

=cut

sub write_data {
    my $self = shift;
    my ($data) = @_;
    use bytes;
    my $len = length $data;
    my $obj = $self->make_type( 4, $len ) . $data;
    return $self->binary_write($obj);
}

=head2 count $data

Recursively counts the number of objects in a serialized
data structure C<$data>. Does not take into account
duplicates, so this number might be slightly higher than
the number of objects that is indicated in the 32-byte
trailer.

=cut

sub count {

    # this might be slightly over, since it doesn't take into account duplicates
    my $self       = shift;
    my ($arrayref) = @_;
    my $type       = $arrayref->[0];
    my $value;
    if ( $type eq "dict" ) {
        my @keys = ( keys %{ $arrayref->[1] } );
        $value = 1 + @keys;
        $value += $_ for map { $self->count( $arrayref->[1]->{$_} ) } @keys;
        return $value;
    } elsif ( $type eq "array" ) {
        $value = 1;
        $value += $_ for map { $self->count($_) } @{ $arrayref->[1] };
        return $value;
    } else {
        return 1;
    }
}

=head2 binary_write $obj

Does the actual writing to the binary file. Takes some
binary data C<$obj> and writes it to the filehandle. Also
adds the location of the binary data to the offset table
and returns the index into the offset table of the current
object.

=cut

sub binary_write {
    my $self    = shift;
    my $fh      = $self->{fh};
    my ($obj)   = @_;
    my $current = tell $self->{fh};
    print $fh $obj;
    push @{ $self->{index} }, $current;
    return ( @{ $self->{index} } - 1 );
}

=head2 power $int

Calculates the number of bytes necessary to encode an
integer C<$int>. Returns a power of 2 indicating the number
of bytes.

=cut

sub power {
    my $self = shift;
    my ($int) = @_;
    if ( $int > 4294967295 ) {
        return 3;

        # actually refers to 2^3 bytes
    } elsif ( $int > 65535 ) {
        return 2;

        # actually refers to 2^2 bytes
    } elsif ( $int > 255 ) {
        return 1;

        # I'm sure you see the trend
    } elsif ( $int < 0 ) {
        return 3;
    } else {
        return 0;
    }
}

=head2 bytes $int

Calculates the number of bytes necessary to encode an
integer C<$int>. Returns the actual number of bytes.

=cut

sub bytes {
    my $self = shift;
    my ($int) = @_;
    if ( $int >= 2**24 ) {
        return 4;

        # actually refers to 4 bytes
    } elsif ( $int >= 2**16 ) {
        return 3;

        # actually refers to 3 bytes
    } elsif ( $int >= 256 ) {
        return 2;

        # I'm sure you see the trend
    } else {
        return 1;
    }
}

=head2 pack_in $int

Takes either a power of 2 or a number of bytes C<$int> and
returns the format pack() needs for encoding.

=cut

sub pack_in {

    # can be used with powers or bytes
    my $self  = shift;
    my ($int) = @_;
    my $fmt   = [ "C", "n", "N", "N" ]->[$int];
    return $fmt;
}

1;