File Coverage

blib/lib/Test2/Tools/MIDI.pm

Criterion	Covered	Total	%
statement	247	247	100.0
branch	140	146	95.8
condition			n/a
subroutine	24	24	100.0
pod	16	16	100.0
total	427	433	98.6

# -*- Perl -*-
#
# A module to test MIDI file contents.

package Test2::Tools::MIDI;
our $VERSION = '0.02';
use 5.10.0;
use strict;
use warnings;
use Carp 'confess';
use Test2::API 'context';

use base 'Exporter';
our @EXPORT = qw(
  midi_aftertouch midi_channel_aftertouch midi_control_change midi_eof
  midi_footer midi_header midi_note_off midi_note_on midi_patch
  midi_pitch_wheel midi_skip midi_skip_dtime midi_tempo midi_text midi_track
);

sub _failure ($$\@) {
    my $result = 1;
    if ( @{ $_[2] } ) {
        $_[0]->fail( $_[1], join ' ',
            map { "$_->[0] [$_->[1],$_->[2]]" } @{ $_[2] } );
        $result = 0;
    } else {
        $_[0]->pass( $_[1] );
    }
    $_[0]->release;
    return $result;
}

# note_on, note_off and a few others share this pattern, though you may
# need to squint a little to make the "controller" and "value" of
# control_change fit the pitch and velocity fields
sub _dpv ($$$$$$$) {
    my ( $fh, $dtime, $channel, $pitch, $velocity, $want_code, $name ) =
      @_;

    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $track, 3;
    confess "$name read $!" unless defined $amount;
    if ( $amount != 3 ) {
        push @failure, [ length => $amount, 3 ];
        goto FAIL_DPV;
    }
    my ( $pa, $re, $ci ) = unpack CCC => $track;
    my ( $ch, $code ) = ( $pa & 0xF, $pa & 0xF0 );
    if ( $ch != $channel ) {
        push @failure, [ channel => $ch, $channel ];
    }
    if ( $code != $want_code ) {
        push @failure, [ code => $ch, $want_code ];
    }
    if ( $re != $pitch ) {
        push @failure, [ pitch => $re, $pitch ];
    }
    if ( $ci != $velocity ) {
        push @failure, [ velocity => $ci, $velocity ];
    }
  FAIL_DPV:
    _failure( context(), $name, @failure );
}

sub midi_aftertouch ($$$$$) {
    push @_, 0xA0, 'MIDI key_after_touch';
    goto &_dpv;
}

sub midi_channel_aftertouch ($$$$) {
    my ( $fh, $dtime, $channel, $velocity ) = @_;
    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $track, 2;
    confess "midi_channel_aftertouch read $!" unless defined $amount;
    if ( $amount != 2 ) {
        push @failure, [ length => $amount, 2 ];
        goto FAIL_CHAFT;
    }
    my ( $pa, $velo ) = unpack CC => $track;
    my ( $ch, $code ) = ( $pa & 0xF, $pa & 0xF0 );
    if ( $ch != $channel ) {
        push @failure, [ channel => $ch, $channel ];
    }
    if ( $code != 0xD0 ) {
        push @failure, [ code => $code, 0xD0 ];
    }
    if ( $velo != $velocity ) {
        push @failure, [ velocity => $velo, $velocity ];
    }
  FAIL_CHAFT:
    _failure( context(), 'MIDI channel_aftertouch', @failure );
}

sub midi_control_change ($$$$$) {
    push @_, 0xB0, 'MIDI control_change';
    goto &_dpv;
}

sub midi_eof ($) {
    my $eof    = eof $_[0];
    my $ctx    = context();
    my $result = 1;
    if ($eof) {
        $ctx->pass('MIDI EOF');
    } else {
        $ctx->fail('MIDI EOF');
        $result = 0;
    }
    $ctx->release;
    return $result;
}

sub midi_footer ($$) {
    my ( $fh, $dtime ) = @_;
    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $footer, 3;
    confess "midi_footer read $!" unless defined $amount;
    if ( $amount != 3 ) {
        push @failure, [ length => $amount, 3 ];
        goto FAIL_FOOTER;
    }
    my $expect = "\xFF\x2F\x00";
    if ( $footer ne $expect ) {
        push @failure,
          [ footer => map { sprintf '%vx', $_ } $footer, $expect ];
    }
  FAIL_FOOTER:
    _failure( context(), 'MIDI footer', @failure );
}

sub midi_header ($$$$) {
    my ( $fh, $want_format, $want_tracks, $want_division ) = @_;

    my $amount = read $fh, my $header, 14;
    confess "midi_header read $!" unless defined $amount;
    my @failure;
    if ( $amount != 14 ) {
        push @failure, [ byte_count => $amount, 14 ];
        goto FAIL_HEADER;
    }
    my ( $mthd, $header_len, $format, $tracks, $division ) =
      unpack a4Nnnn => $header;
    if ( $mthd ne 'MThd' ) {
        push @failure, [ id => $mthd, 'MThd' ];
    }
    if ( $header_len != 6 ) {
        push @failure, [ header_length => $header_len, 6 ];
    }
    if ( $format != $want_format ) {
        push @failure, [ format => $format, $want_format ];
    }
    if ( $tracks != $want_tracks ) {
        push @failure, [ tracks => $tracks, $want_tracks ];
    }
    if ( $division != $want_division ) {
        push @failure, [ division => $division, $want_division ];
    }
  FAIL_HEADER:
    _failure( context(), 'MIDI header', @failure );
}

sub midi_note_off ($$$$$) {
    push @_, 0x80, 'MIDI note_off';
    goto &_dpv;
}

sub midi_note_on ($$$$$) {
    push @_, 0x90, 'MIDI note_on';
    goto &_dpv;
}

# TODO probably need to support some more events around about here

sub midi_patch ($$$$) {
    my ( $fh, $dtime, $channel, $want_patch ) = @_;
    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $track, 2;
    confess "midi_patch read $!" unless defined $amount;
    if ( $amount != 2 ) {
        push @failure, [ length => $amount, 2 ];
        goto FAIL_PATCH;
    }
    my ( $pa, $patch ) = unpack CC => $track;
    my ( $ch, $code )  = ( $pa & 0xF, $pa & 0xF0 );
    if ( $ch != $channel ) {
        push @failure, [ channel => $ch, $channel ];
    }
    if ( $code != 0xC0 ) {
        push @failure, [ code => $code, 0xC0 ];
    }
    if ( $patch != $want_patch ) {
        push @failure, [ patch => $patch, $want_patch ];
    }
  FAIL_PATCH:
    _failure( context(), 'MIDI patch', @failure );
}

sub midi_pitch_wheel ($$$$) {
    my ( $fh, $dtime, $channel, $wheel ) = @_;
    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $track, 3;
    if ( $amount != 3 ) {
        push @failure, [ length => $amount, 3 ];
        goto FAIL_WHEEL;
    }
    my ( $pa, $high, $low ) = unpack CCC => $track;
    my ( $ch, $code ) = ( $pa & 0xF, $pa & 0xF0 );
    if ( $ch != $channel ) {
        push @failure, [ channel => $ch, $channel ];
    }
    if ( $code != 0xE0 ) {
        push @failure, [ code => $code, 0xE0 ];
    }
    my $value = $high | ( $low << 7 ) - 0x2000;
    if ( $value != $wheel ) {
        push @failure, [ wheel => $value, $wheel ];
    }
  FAIL_WHEEL:
    _failure( context(), 'MIDI pitch_wheel', @failure );
}

sub midi_skip ($$) {
    my ( $fh, $size ) = @_;
    my $amount = read $fh, my ($unused), $size;
    confess "midi_skip read $!" unless defined $amount;
    my @failure;
    if ( $amount != $size ) {
        push @failure, [ byte_count => $amount, $size ];
    }
    _failure( context(), 'MIDI skip', @failure );
}

sub midi_skip_dtime ($$) {
    read_vlq( $_[0] );
    goto &midi_skip;
}

sub midi_tempo ($$$) {
    my ( $fh, $dtime, $tempo_want ) = @_;
    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $track, 6;
    confess "midi_tempo read $!" unless defined $amount;
    if ( $amount != 6 ) {
        push @failure, [ length => $amount, 6 ];
        goto FAIL_TEMPO;
    }
    my ( $code, $high, $low ) = unpack Z3Cn => $track;
    my $expect = "\xFF\x51\x03";
    if ( $code ne $expect ) {
        push @failure,
          [ tempo_code => map { sprintf '%vx', $_ } $code, $expect ];
    }
    my $tempo = ( $high << 16 ) | $low;
    if ( $tempo != $tempo_want ) {
        push @failure, [ tempo => $tempo, $tempo_want ];
    }
  FAIL_TEMPO:
    _failure( context(), 'MIDI tempo', @failure );
}

sub midi_text ($$$$) {
    my ( $fh, $dtime, $type, $want_string ) = @_;
    my $code;
    if ( $type eq 'text' ) {
        $code = "\xFF\x01";
    } elsif ( $type eq 'copyright' ) {
        $code = "\xFF\x02";
    } elsif ( $type eq 'name' ) {
        $code = "\xFF\x03";
    } elsif ( $type eq 'instrument' ) {
        $code = "\xFF\x04";
    } elsif ( $type eq 'lyric' ) {
        $code = "\xFF\x05";
    } elsif ( $type eq 'marker' ) {
        $code = "\xFF\x06";
    } elsif ( $type eq 'cue' ) {
        $code = "\xFF\x07";
    } elsif ( $type eq 'text8' ) {
        $code = "\xFF\x08";
    } elsif ( $type eq 'text9' ) {
        $code = "\xFF\x09";
    } elsif ( $type eq 'texta' ) {
        $code = "\xFF\x0A";
    } elsif ( $type eq 'textb' ) {
        $code = "\xFF\x0B";
    } elsif ( $type eq 'textc' ) {
        $code = "\xFF\x0C";
    } elsif ( $type eq 'textd' ) {
        $code = "\xFF\x0D";
    } elsif ( $type eq 'texte' ) {
        $code = "\xFF\x0E";
    } elsif ( $type eq 'textf' ) {
        $code = "\xFF\x0F";
    } else {
        confess "unknown type '$type'";
    }
    my @failure;
    my $q = read_vlq($fh);
    if ( $q != $dtime ) {
        push @failure, [ dtime => $q, $dtime ];
    }
    my $amount = read $fh, my $track, 2;
    confess "midi_text read $!" unless defined $amount;
    if ( $amount != 2 ) {
        push @failure, [ code_length => $amount, 2 ];
        goto FAIL_TEXT;
    }
    if ( $track ne $code ) {
        push @failure,
          [ text_code => map { sprintf '%vx', $_ } $track, $code ];
    }
    my $string_length = read_vlq($fh);
    $amount = read $fh, $track, $string_length;
    if ( $amount != $string_length ) {
        push @failure, [ text_length => $amount, $string_length ];
        goto FAIL_TEXT;
    }
    if ( $track ne $want_string ) {
        push @failure, [ text => $track, $want_string ];
    }
  FAIL_TEXT:
    _failure( context(), "MIDI text_$type", @failure );
}

sub midi_track ($$) {
    my ( $fh, $want_length ) = @_;

    my $amount = read $fh, my $track, 8;
    confess "midi_track read $!" unless defined $amount;
    my @failure;
    if ( $amount != 8 ) {
        push @failure, [ byte_count => $amount, 8 ];
        goto FAIL_TRACK;
    }
    my ( $mtrk, $track_len ) = unpack a4N => $track;
    if ( $mtrk ne 'MTrk' ) {
        push @failure, [ id => $mtrk, 'MTrk' ];
    }
    if ( $track_len != $want_length ) {
        push @failure, [ track_length => $track_len, $want_length ];
        goto FAIL_TRACK;
    }
  FAIL_TRACK:
    _failure( context(), 'MIDI track', @failure );
}

sub read_vlq ($) {
    my $q = 0;
    while (1) {
        my $r = read $_[0], my $byte, 1;
        confess "read_vlq read $!" unless defined $r;
        confess "read_vlq eof" if $r == 0;
        my $n = unpack C => $byte;
        $q = ( $q << 7 ) | ( $n & 0x7f );
        if ( $n < 0x80 ) {
            confess "read_vlq range $q" if $q > 0xFFFFFFF;
            return $q;
        }
    }
}

1;
__END__