File Coverage

blib/lib/Net/DAAP/DMAP.pm

Criterion	Covered	Total	%
statement	70	162	43.2
branch	19	56	33.9
condition	4	15	26.6
subroutine	9	18	50.0
pod	0	12	0.0
total	102	263	38.7

package Net::DAAP::DMAP;
use strict;
our $NOISY = 0;
our $VERSION = '1.27';

=pod

=head1 NAME

Net::DAAP::DMAP - Perl module for reading and writing DAAP structures

=head2 SYNOPSIS

  use Net::DAAP::DMAP qw(:all);

  $hash_ref = dmap_to_hash_ref($dmap);       # crude
  $array_ref = dmap_to_array_ref($dmap);     # crude

  $array_ref = dmap_unpack($dmap);           # knows about data types
  $node      = dmap_seek($array_ref, $path);

  $flattened = dmap_flatten($array_ref);     # convert to path = data formta
  $flat_list = dmap_flat_list($array_ref);   # convert to [ path, data ] format
  $xml       = dmap_to_xml($dmap);           # convert to XML fragment
  $dmap      = dmap_pack($dmap);             # convert to DMAP packet
  update_content_codes($unpacked_content_codes_response);

=head1 DESCRIPTION

=head2 WARNING!

Until 2.0, I reserve the right to change the interface.  In
particular, I think C, C, and
C are likely to disappear.  And I suspect the hive
brain of Perl can come up with a better data structure than I have.

=head2 Back to the Description

A DMAP structure is a binary record used in Apple's DAAP protocol.  A
DMAP structure may contain other DMAP structures.  Fields in a DMAP
structure are identified by a short name ("msdc").  The short name is
what's in the binary record, but a content codes list gives a long
name ("dmap.databasescount") and a data type for the record (32-bit
integer).

A parsed DMAP structure is built out of arrays.  For example:

  [
    [
      'dmap.loginresponse',
      [
         [
           'dmap.status',
           200
         ],
         [
           'dmap.sessionid',
            2393
         ]
      ]
    ]
  ]

(C returns this kind of structure)

There are two rules here: a field is wrapped in an array, and
a container's values are wrapped in an array.  So the structure
is programmatically built as:

  $status_field = [ 'dmap.status', 200 ];
  $session_id_field = [ 'dmap.sessionid', 2393 ];
  $response_value = [ $status_field, $session_id_field ];
  $login_response_field = [ 'dmap.loginresponse', $response_value ];
  $entire_response = [ $login_response_field ];

The outer array is necessary because not every response has only one
top-level container as this does.

In XML you'd write the response as:


      200
      2393


This is what C returns.

A much more convenient structure for representing this data would
be:

  {
    'dmap.loginresponse' => {
      { 'dmap.status' => 200,
        'dmap.sessionid' => 2393,
      },
  }

This is the output of C, but beware!  This isn't
suitable for every response.  The hash is indexed by field name and a
structure may contain many elements of the same name.  For example,
requesting the content codes list gives you a list of records that
have the field name C.

The array structure returned by C is complex, but
the C function makes it easier.  This takes a structure and
a path expressed as a slash-separated list of field names:

  dmap.loginresponse/dmap.sessionid

The return value is the the value of the first C found
in the first C structure.  In the case of the
sample record above, it would be 2393.

Another way to handle these complex arrays is to C them.
This returns an array of "I = value" lines, where I is
a slash-separated path.  For example:

  [
    '/dmap.loginresponse/dmap.status = 200',
    '/dmap.loginresponse/dmap.sessionid = 2393'
  ]

You can use C and regexps to find data if that's the way your
mind works.

C has a similar looking cousin called C,
which returns an array of "I => I" pairs.  For example:


  [
    '/dmap.loginresponse/dmap.status' => 200,
    '/dmap.loginresponse/dmap.sessionid' => 2393,
  ]

You can then turn this into a hash (which may of course lose you the
first elements), or iterate over it in pairs, if that's easier.

You can, but don't have to, update the tables of field names ("content
codes") and data types.  DAAP offers a request that returns a packet
of content codes.  Feed that packet to C.

=head2 Implementation Details

It's all implementation details.  Here are the various data types.

 1, 3, 5, 7 = ints, size 8,16,32,64 bit
 9 = string, 10 = time_t-style time
 11 = version (two 16-bit ints, I think)
 12 = container

This uses Math::BigInt for 64-bit quantities, as not every platform
has 64-bit int support available.

There's no support for types 2, 4, 6, 8 yet because nobody'd found
examples of them in the field: are they endian changes, or signedness
changes.  The assumption is that all numbers are unsigned (why allow
the possibility of a negative number of songs?).

=head1 AUTHOR

Nathan Torkington, .  For support, join the
DAAP developers mailing list by sending mail to
develooper.com>.

Richard Clamp  is the current maintainer, and
took over in July 2004.

=cut

use Exporter;
use Math::BigInt;
use Carp;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(dmap_to_hash_ref dmap_to_array_ref update_content_codes
                    dmap_unpack dmap_to_xml dmap_seek dmap_flatten dmap_flat_list dmap_pack );
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

our $Types;
my %Type_To_Unpack;
my $Container_Type;

# initialize the types and their unpack() equivalents
init();

sub init {
    local $/;
    $Types = eval ;

    $Container_Type = 12;

    %Type_To_Unpack = (
                       1 => 'c',
                       3 => 'n',
                       5 => 'N',
                       7 => 'Q',
                       9 => 'a*',  # utf-8 encoded
                       10 => 'N',
                       11 => 'nn',
                       42 => 'a*', # this is a local invention - 9 is
                                   # getting handled as utf-8, but for
                                   # dpap.picturedata that would be
                                   # bad m'kay
                       );
}

sub dmap_to_hash_ref {
    my $buf = shift;
    my %tags;

    while (length $buf) {
        my ($tag, $len) = unpack("a4N", $buf);
        if (!defined($len) or length $buf < 8+$len) {
            return;
          }
        my $data = substr($buf, 8, $len);
        # try to unpack--if we can, assume it was a container
        my $data2 = dmap_to_hash_ref($data);
        $tags{$tag} = $data2 ? $data2 : $data;
        substr($buf, 0, 8+$len) = '';
      }
    return \%tags;
}

sub dmap_flatten {
    my $struct = shift;
    my $arrayref = [];

    flatten_traverse($arrayref, "", $struct);
    return $arrayref;
}

sub flatten_traverse {
    my ($array_ref, $prefix, $struct) = @_;

    foreach my $ref (@$struct) {
        for (my $i=0; $i < @$ref; $i+=2) {
            my ($tag, $data) = ($ref->[$i], $ref->[$i+1]);

            if (ref $data eq 'ARRAY') {
                flatten_traverse($array_ref, "$prefix/$tag", $data);
            } else {
                push @$array_ref, "$prefix/$tag = $data";
            }
        }
    }
}

sub dmap_flat_list {
    return @{ flat_list_traverse([], "", shift) };
}

sub flat_list_traverse {
    my ($list, $prefix, $struct) = @_;
    foreach my $ref (@$struct) {
        for (my $i=0; $i < @$ref; $i+=2) {
            my ($tag, $data) = ($ref->[$i], $ref->[$i+1]);

            if (ref $data eq 'ARRAY') {
                flat_list_traverse($list, "$prefix/$tag", $data);
            } else {
                push @$list, "$prefix/$tag", $data;
            }
        }
    }
    return $list;
}


sub dmap_unpack {
    my $buf = shift;
    my @tags;

    while (length $buf) {
        my ($tag, $len) = unpack("a4N", $buf);
        my $data = substr($buf, 8, $len);
        substr($buf, 0, 8+$len) = '';
        my $type = $Types->{$tag}{TYPE};
        unless ($type) {
            carp "'$tag' unknown, can't unpack" if $NOISY;
            next;
        }

        if ($type == 12) {
            $data = dmap_unpack($data);
        } elsif ($type == 7) {
            my ($n1, $n2) = unpack("N2", $data);
            $data = new Math::BigInt(new Math::BigInt($n1)->blsft(32));
            $data += $n2;
            $data = "$data";
        } else {
            $data = unpack($Type_To_Unpack{$type}, $data);
        }
        # type 9 is really utf-8 encoded, so if we can, show that it is
        if ($type == 9 && eval { require Encode; 1 }) {
            $data = Encode::decode('utf-8', $data);
        }
        push @tags, [ $Types->{$tag}{NAME}, $data ];
    }

    return \@tags;
}

sub dmap_to_xml {
    my $buf = shift;
    my $xml = '';

    while (length $buf) {
        my ($tag, $len) = unpack("a4N", $buf);
        my $data = substr($buf, 8, $len);
        my $type = $Types->{$tag}{TYPE};

        if ($type == 12) {
            $data = dmap_to_xml($data);
        } else {
            $data = unpack($Type_To_Unpack{$type}, $data);
        }
        $xml .= sprintf("<%s>\n  %s\n\n", $tag, $data, $tag);
        substr($buf, 0, 8+$len) = '';
      }
    return $xml;
}

sub dmap_to_array_ref {
    my $buf = shift;
    my @tags;

    while (length $buf) {
        my ($tag, $len) = unpack("a4N", $buf);
        if (!defined($len) or length $buf < 8+$len) {
            return;
          }
        my $data = substr($buf, 8, $len);
        # try to unpack, assume it was a container if it succeeded
        my $data2 = dmap_to_array_ref($data);
        push @tags, [ $tag,  $data2 ? $data2 : $data ];
        substr($buf, 0, 8+$len) = '';
      }
    return \@tags;
}

sub dmap_seek {
    my($struct, $to_find) = @_;

    CHUNK: while (defined($to_find) && length($to_find)) {
        my $top;
        ($top, $to_find) = split m{/}, $to_find, 2;

      ELEMENT: foreach my $elt (@$struct) {

          if ($elt->[0] eq $top) {
                $struct = $elt->[1];
                next CHUNK;
            }
        }
        return;  # NOT FOUND
    }
    return $struct;
}

sub update_content_codes {
  my $array = shift;
  my $short;

  my $mccr = dmap_seek($array, "dmap.contentcodesresponse");
  die "Couldn't find mccr" unless defined $mccr;

  foreach my $mdcl_rec (@$mccr) {
    next unless $mdcl_rec->[0] eq 'dmap.dictionary';
    my @fields = @{$mdcl_rec->[1]};
    my ($name, $id, $type);
    foreach my $f (@fields) {
      if ($f->[0] eq 'dmap.contentcodesnumber') { $id = $f->[1] }
      if ($f->[0] eq 'dmap.contentcodesname') { $name = $f->[1] }
      if ($f->[0] eq 'dmap.contentcodestype') { $type = $f->[1] }
    }
    if ($id eq 'mcnm') { $type = 9  } # string names please
    if ($id eq 'pfdt') { $type = 42 } # and straight binary pictures
    my $record = { NAME => $name, ID => $id, TYPE => $type };
    $short->{$id} = $record;
  }

  $Types = $short;
}

sub dmap_pack {
    my $struct = shift;
    my $out = '';

    my %by_name = map { %{$_} ? ( $_->{NAME} => $_ ) : () } values %$Types;
    for my $pair (@$struct) {
        my ($name, $value) = @$pair;
        # dmap_unpack doesn't populate the name when its decoded
        # something it doesn't know the content-code of, like aeSV
        # which is new to 4.5
        unless ($name) {
            carp "element without a name - skipping" if $NOISY;
            next;
        }
        # or, it may be we don't know what kind of thing this is
        unless ($by_name{ $name }) {
            carp "$name has unknown type - skipping" if $NOISY;
            next;
        }

        my $tag  = $by_name{ $name }{ID};
        my $type = $by_name{ $name }{TYPE};
        #print "$name => $tag $type $Type_To_Unpack{$type}\n";
        #$SIG{__WARN__} = sub { die @_ };
        if ($type == 9 && eval { require Encode; 1 }) {
            $value = Encode::encode('utf-8', $value);
        }
        if ($type == 12) { # container
            $value = dmap_pack( $value );
        }
        elsif ($type == 7) { # 64-bit
            my $high = Math::BigInt->new( $value )->brsft(32)."";
            my $low  = Math::BigInt->new( $value )->band(0xFFFFFFFF)."";
            $value = pack( "N2", $high, $low );
        }
        else {
            no warnings 'uninitialized';
            $value = pack( $Type_To_Unpack{$type}, $value );
        }
        my $length = do { use bytes; length $value };
        $out .= $tag . pack("N", $length) . $value;
    }
    return $out;
}

1;

__DATA__