GSM/SMS/Support/RTTTL2MIDI.pm

   1 package GSM::SMS::Support::RTTTL2MIDI;
   2
   3 use strict;
   4 use vars qw(@ISA @EXPORT $VERSION $error_rtttl %rtl_props @rtl_notes $rtl_name);
   5 require Exporter;
   6
   7 @ISA = qw(Exporter);
   8 @EXPORT = qw(Rtttl2Midi);
   9 $VERSION = 0.1;
  10
  11 $rtl_name  = "";
  12 %rtl_props = ();
  13 @rtl_notes = ();
  14 $error_rtttl = "Yaketysax:d=4,o=5,b=125:8d.,16e,8g,8g,16e,16d,16a4,16b4,16d,16b4,";
  15 $error_rtttl .="8e,16d,16b4,16a4,16b4,8a4,16a4,16a#4,16b4,16d,16e,16d,g,p,16d,16e,";
  16 $error_rtttl .="16d,8g,8g,16e,16d,16a4,16b4,16d,16b4,8e,16d,16b4,16a4,16b4,8d,16d,";
  17 $error_rtttl .="16d,16f#,16a,8f,d,p,16d,16e,16d,8g,16g,16g,8g,16g,16g,8g,8g,16e,8e.,";
  18 $error_rtttl .="8c,8c,8c,8c,16e,16g,16a,16g,16a#,8g,16a,16b,16a#,16b,16a,16b,8d6,16a,";
  19 $error_rtttl .="16b,16d6,8b,8g,8d,16e6,16b,16b,16d,8a,8g,g";
  20
  21
  22 sub Rtttl2Midi {
  23         my($xrtttl,$program) = @_;
  24            $program = 1 unless defined $program;
  25         my $status = pharse_rtttl($xrtttl);
  26         if ($status == 0) {
  27                 $rtl_name  = "";
  28                 %rtl_props = ();
  29                 @rtl_notes = ();
  30
  31                 $xrtttl = $error_rtttl;
  32                 pharse_rtttl($xrtttl);
  33         }
  34
  35         my ($head, $track_data, $track_head, $midi);
  36
  37         $head        = mf_write_header_chunk(0,1,384);
  38         $track_data  = copy_right();
  39         $track_data .= track_name("MIDI by RTTTL2MIDI");
  40         $track_data .= volumeup();
  41         $track_data .= mf_write_tempo($rtl_props{b});
  42         $track_data .= add_program($program);
  43         $track_data .= notes2midi();
  44         $track_data .= end_track();
  45         $track_head  = mf_write_track_chunk($track_data);
  46         $midi        = $head . $track_head . $track_data;
  47         return($midi);
  48 }
  49
  50 sub clean_spaces {
  51         my ($str) = @_;
  52             $str =~ s/\s//g;
  53         return($str);
  54 }
  55
  56 sub pharse_rtttl {
  57         my ($str) = @_;
  58         my ($name,$defaults,$notes) = split /:/, $str;
  59         unless($name=~/[a-zA-Z0-9]/ && length($name) < 32) { return 0; }
  60     map { my($n,$v) = split /=/, $_; $rtl_props{$n} = $v; } split /,/, $defaults;
  61         unless($rtl_props{d} =~ /\d+/) { return 0; }
  62         unless($rtl_props{o} =~ /\d+/) { return 0; }
  63         unless($rtl_props{b} =~ /\d+/) { return 0; }
  64         my($dotted, $i, $r) = 0;
  65         my @nts = split /,/, clean_spaces($notes);
  66         for($i=0; $i < @nts; $i++) {
  67                 my($d,$n,$s,$x) = ($nts[$i] =~ /(\d*)([a-z]#?)(\d*)(\.?)/);
  68                 #duration, note, oktav, dot
  69                 unless($d =~ /\d*/)     { return 0; }
  70                 unless($n =~ /[a-z]#?/) { return 0; }
  71                 unless($s =~ /\d*/)     { return 0; }
  72                 unless($x =~ /\.?/)     { return 0; }
  73                 $dotted = ($x eq ".") ? 1:0;
  74                 $d = $rtl_props{d} if($d == "");
  75                 $s = $rtl_props{o} if($s == "");
  76                 $rtl_notes[$i] = ([$d,$n,$s,$dotted]);
  77                 $r = 1;
  78         }
  79         return($r);
  80 }
  81
  82 sub eputc {
  83         my($input) = @_;
  84         return(chr($input));
  85 }
  86
  87 sub write32bit  {
  88         my ($data) = @_;
  89         my $r;
  90         $r .= eputc((($data >> 24) & 0xff));
  91         $r .= eputc((($data >> 16) & 0xff));
  92         $r .= eputc((($data >> 8 ) & 0xff));
  93         $r .= eputc(($data & 0xff));
  94         return($r);
  95 }
  96
  97 sub write16bit {
  98         my ($data) = @_;
  99         my $r;
 100         $r .= eputc((($data & 0xff00) >> 8));
 101         $r .= eputc(($data & 0xff));
 102         return($r);
 103 }
 104
 105 sub mf_write_header_chunk {
 106         my ($format, $ntracks, $division) = @_;
 107         my $ident = 0x4d546864;
 108         my $length = 6;
 109         my $r;
 110            $r .= write32bit($ident);
 111            $r .= write32bit($length);
 112            $r .= write16bit($format);
 113            $r .= write16bit($ntracks);
 114            $r .= write16bit($division);
 115         return($r);
 116 }
 117
 118 sub mf_write_track_chunk {
 119         my ($track) = @_;
 120         my $trkhdr = 0x4d54726b;
 121         my $r;
 122            $r .= write32bit($trkhdr);
 123            $r .= write32bit(length($track));
 124         return($r);
 125 }
 126
 127 sub WriteVarLen {
 128         my ($value) = @_;
 129         my $buffer=0;
 130         my $r;
 131            $buffer = $value & 0x7f;
 132            while(($value >>= 7) > 0) {
 133                   $buffer <<= 8;
 134                   $buffer |= 0x80;
 135                   $buffer += ($value & 0x7f);
 136            }
 137            while(1) {
 138                   $r .= eputc(($buffer & 0xff));
 139                         if($buffer & 0x80) {
 140                            $buffer >>= 8;
 141                         } else {
 142                         return($r);
 143                         }
 144            }
 145 }
 146
 147 sub mf_write_tempo {
 148         my ($t) = @_;
 149         my $tempo  = (60000000.0 / ($t));
 150         my $r;
 151            $r .= eputc(0);
 152            $r .= eputc(0xff);
 153            $r .= eputc(0x51);
 154            $r .= eputc(3);
 155            $r .= eputc((0xff & ($tempo >> 16)));
 156            $r .= eputc((0xff & ($tempo >> 8)));
 157            $r .= eputc((0xff & $tempo));
 158         return($r);
 159 }
 160
 161 sub mf_write_midi_event {
 162         my ($delta_time, $type, $chan, @data) = @_;
 163         my $i;
 164         my $c = 0;
 165         my $r = WriteVarLen($delta_time);
 166            $c = $type | $chan;
 167            $r .= eputc($c);
 168             for($i = 0; $i < @data; $i++) {
 169                 $r .= eputc($data[$i]);
 170             }
 171         return($r);
 172 }
 173
 174 sub data {
 175         my($p1,$p2) = @_;
 176         my @r;
 177            $r[0] = $p1;
 178            $r[1] = $p2;
 179         return @r;
 180 }
 181
 182 sub data1 {
 183         my($p1)=@_;
 184         my @r;
 185            $r[0] = $p1;
 186         return @r;
 187 }
 188
 189 sub end_track {
 190         my $r;
 191         $r .= eputc(0);
 192         $r .= eputc(0xFF);
 193         $r .= eputc(0x2f);
 194         $r .= eputc(0);
 195         return($r);
 196 }
 197
 198 sub add_program {
 199         my ($prg) = @_;
 200         my $r;
 201            $r = mf_write_midi_event(0,0xc0,0,data1($prg));
 202         return($r);
 203 }
 204
 205 sub note {
 206         my($s, $d, $p, $td) = @_;
 207         my $r;
 208            $r .= mf_write_midi_event($s,0x90,0,data($p,100));
 209            $r .= mf_write_midi_event($d,0x80,0,data($p,0));
 210            return($r);
 211 }
 212
 213 sub volume {
 214         my $r = "";
 215         return($r);
 216 }
 217
 218 sub copy_right {
 219         my $c = "Rtttl2Midi CopyRight under GPL written by sanalCell.com 2001";
 220         my $r;
 221            $r .= eputc(0);
 222            $r .= eputc(0xff);
 223            $r .= eputc(0x02);
 224            $r .= eputc(length($c));
 225            $r .= $c;
 226         return($r);
 227 }
 228
 229 sub track_name {
 230         my($c) = @_;
 231         my $r;
 232            $r .= eputc(0);
 233            $r .= eputc(0xff);
 234            $r .= eputc(0x03);
 235            $r .= eputc(length($c));
 236            $r .= $c;
 237         return($r);
 238 }
 239
 240 sub volumeup() {
 241         my $r;
 242            $r = mf_write_midi_event(0,0xB0,0,data(0x07,127));
 243         return($r);
 244 }
 245
 246 sub get_pitch {
 247         my($nt,$oc) = @_;
 248            $nt = lc(clean_spaces($nt));
 249         my $r =0;
 250         my %n =("p"     =>  -1,
 251                 "c"     =>   0,
 252                 "c#"    =>   1,
 253                 "d"     =>   2,
 254                 "d#"    =>   3,
 255                 "e"     =>   4,
 256                 "f"     =>   5,
 257                 "f#"    =>   6,
 258                 "g"     =>   7,
 259                 "g#"    =>   8,
 260                 "a"     =>   9,
 261                 "a#"    =>  10,
 262                 "b"     =>  11);
 263                 #h=b
 264         $r = $n{$nt};
 265         if($r != -1) {
 266               $r = 12 + (12*$oc) + $r;
 267         }
 268         return($r);
 269 }
 270
 271 sub get_time {
 272         my($t, $isd) = @_;
 273         my $r = 0;
 274         my %d =("1"     =>      1536,
 275                 "2"     =>      768,
 276                 "4"     =>      384,
 277                 "8"     =>      192,
 278                 "16"    =>      96,
 279                 "32"    =>      48,
 280                 "64"    =>      24);
 281         $r = $d{$t};
 282         if($isd) {
 283                 $r = $r + ($r/2);
 284         }
 285         return($r);
 286 }
 287
 288 sub notes2midi {
 289         my ($r,$alldata);
 290         my ($a, $pt, $tm, $rest) = 0;
 291         for($a = 0; $a != @rtl_notes; $a++) {
 292                 $pt = get_pitch($rtl_notes[$a][1],$rtl_notes[$a][2]-1);
 293                 $tm = get_time($rtl_notes[$a][0],$rtl_notes[$a][3]);
 294
 295                 if($pt == -1) {
 296                         $rest = $tm;
 297                 } else {
 298                         $alldata .= note($rest,$tm,$pt,$r);
 299                         $rest = 0;
 300                 }
 301         }
 302         return($alldata);
 303 }
 304
 305 1;
 306
 307 =head1 NAME
 308
 309 GSM::SMS::Support::RTTTL2MIDI
 310
 311 =head1 SYNOPSIS
 312
 313  use GSM::SMS::Support::RTTTL2MIDI;
 314
 315  print "Content-type: audio/x-midi\n\n";
 316  print Rtttl2Midi($rtttl_string, $piano);
 317
 318 =head1 DESCRIPTION
 319
 320 Converts rtttl strings to midi sound. Also you can set piano
 321 like Hammod Organ (17) and Grand Piano (1).
 322
 323 =head1 METHODS
 324
 325 =head2 Rtttl2Midi($strRTTTL, $piano)
 326
 327 Generate a binary midi stream from $strRTTTL, using $piano as the
 328 instrument.
 329
 330 =head1 AUTHOR
 331
 332 Ethem Evlice <webmaster@tuzluk.com>