#!/usr/bin/perl
use warnings;
use strict;
require 5;
use strict;
use warnings;
use constant DEBUG => 0;
use MIDI;

# by sburke@cpan.org 2004-12-02 

$ARGV[0] = $1 / $2 if $ARGV[0] and $ARGV[0] =~ m[^(\d+)/(\d+)$]s;

my ( $scale, $in, $out ) = @ARGV;
die "Usage:  scaletempo scalefactor infile.mid outfile.mid 
scalefactor = how much faster to make it. 
2 = twice as fast 
6/7 = slow it down to 6/7ths of its current speed 
.5 = slow it down to half of its current speed 
"
  unless @ARGV == 3
  and $scale =~ m/^(?: (?: \d*\.\d+ ) | \d+ )$/sx
  and $scale != 0
  and length($in)
  and length($out)
  and -e $in
  and -r $in;

my $opus = MIDI::Opus->new( { 'from_file' => $in } );

DEBUG and print "$in contains ", scalar( $opus->tracks ), " tracks.\n"
+;

my $tweaked = 0;
foreach my $t ( $opus->tracks ) {
    DEBUG and print " Tweaking track $t\n";
    foreach my $e ( @{ $t->events_r || next } ) {
        if ( $e->[0] eq 'set_tempo' ) {
            $tweaked = 1;
            DEBUG > 1 and print " event @$e\n";
            $e->[2] = int( .5 + $e->[2] / $scale );
            DEBUG > 1 and print "    => @$e\n";
        }
    }
}

unless ($tweaked) {
    DEBUG and print "No track events found.  Faking it.\n";
    my $new_ev = [ 'set_tempo', 0, int( .5 + 500_000 / $scale ) ];
    if ( $opus->tracks == 1 ) {
        DEBUG and print "Prepending [@$new_ev] to the one track.\n";
        unshift @{ $opus->tracks_r->[0]->events_r
              || die "No events in track 0?!" }, $new_ev;
    }
    else {
        DEBUG and print "Prepending a [@$new_ev] tempo-track.\n";
        unshift @{ $opus->tracks_r },
          MIDI::Track->new( { 'events' => [$new_ev], } );
    }
}

DEBUG and print "Writing $out\n";
$opus->write_to_file($out);
DEBUG and print "Done.\n";
exit;
__END__
[download]