!/usr/bin/perl

sflist - what instruments does a soundfont file contain?

use 5.36.0;

use File::Format::RIFF;

my $show_header;

if ( @ARGV == 2 and $ARGV[0] eq '-h' ) {

$show_header = 1;

shift;

}

die "Usage: sflist [-h] soundfont-file\n" unless @ARGV == 1;

open my $fh, '<', $ARGV[0] or die "open failed '$ARGV[0]': $!\n";

my $ffr;

eval {

$ffr = File::Format::RIFF->read($fh);

1;

} or do {

die "sflist: unable to parse '$ARGV[0]'\n";

};

if ($show_header) {

my %info = (

    ICMT => 'Rem',

    ICRD => 'Date',

    IENG => 'Author',

    INAM => 'Name',

    IPRD => 'Product',

    ISFT => 'Tool',

    ifil => 'SFv',

    irom => 'ROM',

    isng => 'Engine',

    iver => 'ROMv',

);

my $list = getchunk( 3, sfbk => $ffr, 0 );

my $type = $list->type;

die "sflist: expected INFO chunk (got '$type')\n"

  unless $type eq 'INFO';

my $count = $list->numChunks;

die "sflist: unexpected INFO count $count\n" if $count <= 0;

my $copyright;

for my $i ( 0 .. $count - 1 ) {

    my $chunk = $list->at($i);

    my $id    = $chunk->id;

    if ( $id eq 'ifil' or $id eq 'iver' ) {

        my ( $major, $minor ) = unpack 'vv', $chunk->data;

        say "$info{$id}\t$major.$minor";

    } elsif ( $id eq 'ICOP' ) {

        # this one can spam the terminal so is shown last

        $copyright = unpack 'Z*', $chunk->data;

    } elsif ( $id =~ m/^(?:INAM|isng|IENG|ISFT|ICMT|IPRD|ICRD|irom)$/ ) {

        my $s = unpack 'Z*', $chunk->data;

        say "$info{$id}\t", $s if length $s;

    } else {

        say '??? ', $chunk->dump( $chunk->size );    # TODO

    }

}

say "\n", $copyright if defined $copyright and length $copyright;

exit;

}

my $pdta = getchunk( 3, sfbk => $ffr, 2 );

my $phdr = getchunk( 9, pdta => $pdta, 0 );

my $id = $phdr->id;

die "sflist: unknown PHDR ID '$id' (want 'phdr')\n" if $id ne 'phdr';

my $phdr_size = $phdr->size;

die "sflist: invalid PHDR size $phdr_size\n"

if $phdr_size < 76

or $phdr_size % 38 != 0;

my %presets;

my $data = $phdr->data;

$phdr_size -= 38; # last header is a "End Of Presets" terminator

my $offset = 0;

while ( $offset < $phdr_size ) {

# full record is Z20vvvVVV

my ( $name, $preset, $bank ) = unpack "x${offset}Z20vv", $data;

$presets{$bank}{$preset} = $name;

$offset += 38;

}

say "BANKS ", scalar keys %presets;

for my $bank ( sort { $a <=> $b } keys %presets ) {

print "BNK $bank";

my $ref = $presets{$bank};

for my $preset ( sort { $a <=> $b } keys %$ref ) {

    say "\t$preset\t$ref->{$preset}";

}

}

sub getchunk ( $wantcount, $wanttype, $object, $index ) {

my $type = $object->type;

die "sflist: unexpected type '$type' (want '$wanttype')\n"

  if $type ne $wanttype;

my $count = $object->numChunks;

die "sflist: unexpected count $count (want $wantcount)\n"

  if $count != $wantcount;

return $object->at($index);

}