| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  |  | 
| 2 |  |  |  |  |  |  | # Time-stamp: "2010-12-23 10:00:01 conklin" | 
| 3 |  |  |  |  |  |  | require 5; | 
| 4 |  |  |  |  |  |  | package MIDI::Opus; | 
| 5 | 11 |  |  | 11 |  | 421 | use strict; | 
|  | 11 |  |  |  |  | 27 |  | 
|  | 11 |  |  |  |  | 1254 |  | 
| 6 | 11 |  |  | 11 |  | 58 | use vars qw($Debug $VERSION); | 
|  | 11 |  |  |  |  | 182 |  | 
|  | 11 |  |  |  |  | 1103 |  | 
| 7 | 11 |  |  | 11 |  | 66 | use Carp; | 
|  | 11 |  |  |  |  | 20 |  | 
|  | 11 |  |  |  |  | 44463 |  | 
| 8 |  |  |  |  |  |  |  | 
| 9 |  |  |  |  |  |  | $Debug = 0; | 
| 10 |  |  |  |  |  |  | $VERSION = 0.83; | 
| 11 |  |  |  |  |  |  |  | 
| 12 |  |  |  |  |  |  | =head1 NAME | 
| 13 |  |  |  |  |  |  |  | 
| 14 |  |  |  |  |  |  | MIDI::Opus -- functions and methods for MIDI opuses | 
| 15 |  |  |  |  |  |  |  | 
| 16 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 17 |  |  |  |  |  |  |  | 
| 18 |  |  |  |  |  |  | use MIDI; # uses MIDI::Opus et al | 
| 19 |  |  |  |  |  |  | foreach $one (@ARGV) { | 
| 20 |  |  |  |  |  |  | my $opus = MIDI::Opus->new({ 'from_file' => $one, 'no_parse' => 1 }); | 
| 21 |  |  |  |  |  |  | print "$one has ", scalar( $opus->tracks ) " tracks\n"; | 
| 22 |  |  |  |  |  |  | } | 
| 23 |  |  |  |  |  |  | exit; | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 26 |  |  |  |  |  |  |  | 
| 27 |  |  |  |  |  |  | MIDI::Opus provides a constructor and methods for objects | 
| 28 |  |  |  |  |  |  | representing a MIDI opus (AKA "song").  It is part of the MIDI suite. | 
| 29 |  |  |  |  |  |  |  | 
| 30 |  |  |  |  |  |  | An opus object has three attributes: a format (0 for MIDI Format 0), a | 
| 31 |  |  |  |  |  |  | tick parameter (parameter "division" in L), and a list | 
| 32 |  |  |  |  |  |  | of tracks objects that are the real content of that opus. | 
| 33 |  |  |  |  |  |  |  | 
| 34 |  |  |  |  |  |  | Be aware that options specified for the encoding or decoding of an | 
| 35 |  |  |  |  |  |  | opus may not be documented in I module's documentation, as they | 
| 36 |  |  |  |  |  |  | may be (and, in fact, generally are) options just passed down to the | 
| 37 |  |  |  |  |  |  | decoder/encoder in MIDI::Event -- so see L for an | 
| 38 |  |  |  |  |  |  | explanation of most of them, actually. | 
| 39 |  |  |  |  |  |  |  | 
| 40 |  |  |  |  |  |  | =head1 CONSTRUCTOR AND METHODS | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  | MIDI::Opus provides... | 
| 43 |  |  |  |  |  |  |  | 
| 44 |  |  |  |  |  |  | =over | 
| 45 |  |  |  |  |  |  |  | 
| 46 |  |  |  |  |  |  | =cut | 
| 47 |  |  |  |  |  |  |  | 
| 48 |  |  |  |  |  |  | ########################################################################### | 
| 49 |  |  |  |  |  |  |  | 
| 50 |  |  |  |  |  |  | =item the constructor MIDI::Opus->new({ ...options... }) | 
| 51 |  |  |  |  |  |  |  | 
| 52 |  |  |  |  |  |  | This returns a new opus object.  The options, which are optional, is | 
| 53 |  |  |  |  |  |  | an anonymous hash.  By default, you get a new format-0 opus with no | 
| 54 |  |  |  |  |  |  | tracks and a tick parameter of 96.  There are six recognized options: | 
| 55 |  |  |  |  |  |  | C, to set the MIDI format number (generally either 0 or 1) of | 
| 56 |  |  |  |  |  |  | the new object; C, to set its ticks parameter; C, which | 
| 57 |  |  |  |  |  |  | sets the tracks of the new opus to the contents of the list-reference | 
| 58 |  |  |  |  |  |  | provided; C, which is an exact synonym of C; | 
| 59 |  |  |  |  |  |  | C, which reads the opus from the given filespec; and | 
| 60 |  |  |  |  |  |  | C, which reads the opus from the the given filehandle | 
| 61 |  |  |  |  |  |  | reference (e.g., C<*STDIN{IO}>), after having called binmode() on that | 
| 62 |  |  |  |  |  |  | handle, if that's a problem. | 
| 63 |  |  |  |  |  |  |  | 
| 64 |  |  |  |  |  |  | If you specify either C or C, you probably | 
| 65 |  |  |  |  |  |  | don't want to specify any of the other options -- altho you may well | 
| 66 |  |  |  |  |  |  | want to specify options that'll get passed down to the decoder in | 
| 67 |  |  |  |  |  |  | MIDI::Events, such as 'include' => ['sysex_f0', 'sysex_f7'], just for | 
| 68 |  |  |  |  |  |  | example. | 
| 69 |  |  |  |  |  |  |  | 
| 70 |  |  |  |  |  |  | Finally, the option C can be used in conjuction with either | 
| 71 |  |  |  |  |  |  | C or C, and, if true, will block MTrk tracks' | 
| 72 |  |  |  |  |  |  | data from being parsed into MIDI events, and will leave them as track | 
| 73 |  |  |  |  |  |  | data (i.e., what you get from $track->data).  This is useful if you | 
| 74 |  |  |  |  |  |  | are just moving tracks around across files (or just counting them in | 
| 75 |  |  |  |  |  |  | files, as in the code in the Synopsis, above), without having to deal | 
| 76 |  |  |  |  |  |  | with any of the events in them.  (Actually, this option is implemented | 
| 77 |  |  |  |  |  |  | in code in MIDI::Track, but in a routine there that I've left | 
| 78 |  |  |  |  |  |  | undocumented, as you should access it only thru here.) | 
| 79 |  |  |  |  |  |  |  | 
| 80 |  |  |  |  |  |  | =cut | 
| 81 |  |  |  |  |  |  |  | 
| 82 |  |  |  |  |  |  | sub new { | 
| 83 |  |  |  |  |  |  | # Make a new MIDI opus object. | 
| 84 | 11 |  |  | 11 | 1 | 2009088 | my $class = shift; | 
| 85 | 11 | 50 | 33 |  |  | 150 | my $options_r = (defined($_[0]) and ref($_[0]) eq 'HASH') ? $_[0] : {}; | 
| 86 |  |  |  |  |  |  |  | 
| 87 | 11 |  |  |  |  | 41 | my $this = bless( {}, $class ); | 
| 88 |  |  |  |  |  |  |  | 
| 89 | 11 | 50 |  |  |  | 56 | print "New object in class $class\n" if $Debug; | 
| 90 |  |  |  |  |  |  |  | 
| 91 | 11 | 50 |  |  |  | 64 | return $this if $options_r->{'no_opus_init'}; # bypasses all init. | 
| 92 | 11 |  |  |  |  | 68 | $this->_init( $options_r ); | 
| 93 |  |  |  |  |  |  |  | 
| 94 | 11 | 100 | 66 |  |  | 145 | if( | 
|  |  | 50 | 66 |  |  |  |  | 
|  |  |  | 33 |  |  |  |  | 
|  |  |  | 33 |  |  |  |  | 
| 95 |  |  |  |  |  |  | exists( $options_r->{'from_file'} ) && | 
| 96 |  |  |  |  |  |  | defined( $options_r->{'from_file'} ) && | 
| 97 |  |  |  |  |  |  | length( $options_r->{'from_file'} ) | 
| 98 |  |  |  |  |  |  | ){ | 
| 99 | 9 |  |  |  |  | 50 | $this->read_from_file( $options_r->{'from_file'}, $options_r ); | 
| 100 |  |  |  |  |  |  | } elsif( | 
| 101 |  |  |  |  |  |  | exists( $options_r->{'from_handle'} ) && | 
| 102 |  |  |  |  |  |  | defined( $options_r->{'from_handle'} ) && | 
| 103 |  |  |  |  |  |  | length( $options_r->{'from_handle'} ) | 
| 104 |  |  |  |  |  |  | ){ | 
| 105 | 0 |  |  |  |  | 0 | $this->read_from_handle( $options_r->{'from_handle'}, $options_r ); | 
| 106 |  |  |  |  |  |  | } | 
| 107 | 11 |  |  |  |  | 53 | return $this; | 
| 108 |  |  |  |  |  |  | } | 
| 109 |  |  |  |  |  |  | ########################################################################### | 
| 110 |  |  |  |  |  |  |  | 
| 111 |  |  |  |  |  |  | =item the method $new_opus = $opus->copy | 
| 112 |  |  |  |  |  |  |  | 
| 113 |  |  |  |  |  |  | This duplicates the contents of the given opus, and returns | 
| 114 |  |  |  |  |  |  | the duplicate.  If you are unclear on why you may need this function, | 
| 115 |  |  |  |  |  |  | read the documentation for the C method in L. | 
| 116 |  |  |  |  |  |  |  | 
| 117 |  |  |  |  |  |  | =cut | 
| 118 |  |  |  |  |  |  |  | 
| 119 |  |  |  |  |  |  | sub copy { | 
| 120 |  |  |  |  |  |  | # Duplicate a given opus.  Even dupes the tracks. | 
| 121 |  |  |  |  |  |  | # Call as $new_one = $opus->copy | 
| 122 | 0 |  |  | 0 | 1 | 0 | my $opus = shift; | 
| 123 |  |  |  |  |  |  |  | 
| 124 | 0 |  |  |  |  | 0 | my $new = bless( { %{$opus} }, ref $opus ); | 
|  | 0 |  |  |  |  | 0 |  | 
| 125 |  |  |  |  |  |  | # a first crude dupe. | 
| 126 |  |  |  |  |  |  | # yes, bless it into whatever class the original came from | 
| 127 |  |  |  |  |  |  |  | 
| 128 | 0 |  |  |  |  | 0 | $new->{'tracks'} =  # Now dupe the tracks. | 
| 129 |  |  |  |  |  |  | [ map( $_->copy, | 
| 130 | 0 | 0 |  |  |  | 0 | @{ $new->{'tracks'} } | 
| 131 |  |  |  |  |  |  | ) | 
| 132 |  |  |  |  |  |  | ] if $new->{'tracks'}; # (which should always be true anyhoo) | 
| 133 |  |  |  |  |  |  |  | 
| 134 | 0 |  |  |  |  | 0 | return $new; | 
| 135 |  |  |  |  |  |  | } | 
| 136 |  |  |  |  |  |  |  | 
| 137 |  |  |  |  |  |  | sub _init { | 
| 138 |  |  |  |  |  |  | # Init a MIDI object -- (re)set it with given parameters, or defaults | 
| 139 | 11 |  |  | 11 |  | 25 | my $this = shift; | 
| 140 | 11 | 50 |  |  |  | 48 | my $options_r = ref($_[0]) eq 'HASH' ? $_[0] : {}; | 
| 141 |  |  |  |  |  |  |  | 
| 142 | 11 | 50 |  |  |  | 43 | print "_init called against $this\n" if $Debug; | 
| 143 | 11 | 50 |  |  |  | 35 | if($Debug) { | 
| 144 | 0 | 0 |  |  |  | 0 | if(%$options_r) { | 
| 145 | 0 |  |  |  |  | 0 | print "Parameters: ", map("<$_>", %$options_r), "\n"; | 
| 146 |  |  |  |  |  |  | } else { | 
| 147 | 0 |  |  |  |  | 0 | print "Null parameters for opus init\n"; | 
| 148 |  |  |  |  |  |  | } | 
| 149 |  |  |  |  |  |  | } | 
| 150 | 11 | 100 |  |  |  | 91 | $this->{'format'} = | 
| 151 |  |  |  |  |  |  | defined($options_r->{'format'}) ? $options_r->{'format'} : 1; | 
| 152 | 11 | 100 |  |  |  | 74 | $this->{'ticks'}  = | 
| 153 |  |  |  |  |  |  | defined($options_r->{'ticks'}) ? $options_r->{'ticks'} : 96; | 
| 154 |  |  |  |  |  |  |  | 
| 155 | 11 | 50 | 33 |  |  | 69 | $options_r->{'tracks'} = $options_r->{'tracks_r'} | 
| 156 |  |  |  |  |  |  | if( exists( $options_r->{'tracks_r'} ) and not | 
| 157 |  |  |  |  |  |  | exists( $options_r->{'tracks'} ) | 
| 158 |  |  |  |  |  |  | ); | 
| 159 |  |  |  |  |  |  | # so tracks_r => [ @tracks ] is a synonym for | 
| 160 |  |  |  |  |  |  | #    tracks   => [ @tracks ] | 
| 161 |  |  |  |  |  |  | # as on option for new() | 
| 162 |  |  |  |  |  |  |  | 
| 163 | 11 | 100 | 66 |  |  | 141 | $this->{'tracks'}  = | 
| 164 |  |  |  |  |  |  | ( defined($options_r->{'tracks'}) | 
| 165 |  |  |  |  |  |  | and ref($options_r->{'tracks'}) eq 'ARRAY' ) | 
| 166 |  |  |  |  |  |  | ? $options_r->{'tracks'} : [] | 
| 167 |  |  |  |  |  |  | ; | 
| 168 | 11 |  |  |  |  | 28 | return; | 
| 169 |  |  |  |  |  |  | } | 
| 170 |  |  |  |  |  |  | ######################################################################### | 
| 171 |  |  |  |  |  |  |  | 
| 172 |  |  |  |  |  |  | =item the method $opus->tracks( @tracks ) | 
| 173 |  |  |  |  |  |  |  | 
| 174 |  |  |  |  |  |  | Returns the list of tracks in the opus, possibly after having set it | 
| 175 |  |  |  |  |  |  | to @tracks, if specified and not empty.  (If you happen to want to set | 
| 176 |  |  |  |  |  |  | the list of tracks to an empty list, for whatever reason, you have to | 
| 177 |  |  |  |  |  |  | use "$opus->tracks_r([])".) | 
| 178 |  |  |  |  |  |  |  | 
| 179 |  |  |  |  |  |  | In other words: $opus->tracks(@tracks) is how to set the list of | 
| 180 |  |  |  |  |  |  | tracks (assuming @tracks is not empty), and @tracks = $opus->tracks is | 
| 181 |  |  |  |  |  |  | how to read the list of tracks. | 
| 182 |  |  |  |  |  |  |  | 
| 183 |  |  |  |  |  |  | =cut | 
| 184 |  |  |  |  |  |  |  | 
| 185 |  |  |  |  |  |  | sub tracks { | 
| 186 | 12 |  |  | 12 | 1 | 36 | my $this = shift; | 
| 187 | 12 | 50 |  |  |  | 51 | $this->{'tracks'} = [ @_ ] if @_; | 
| 188 | 12 |  |  |  |  | 21 | return @{ $this->{'tracks'} }; | 
|  | 12 |  |  |  |  | 48 |  | 
| 189 |  |  |  |  |  |  | } | 
| 190 |  |  |  |  |  |  |  | 
| 191 |  |  |  |  |  |  | =item the method $opus->tracks_r( $tracks_r ) | 
| 192 |  |  |  |  |  |  |  | 
| 193 |  |  |  |  |  |  | Returns a reference to the list of tracks in the opus, possibly after | 
| 194 |  |  |  |  |  |  | having set it to $tracks_r, if specified.  "$tracks_r" can actually be | 
| 195 |  |  |  |  |  |  | any listref, whether it comes from a scalar as in C<$some_tracks_r>, | 
| 196 |  |  |  |  |  |  | or from something like C<[@tracks]>, or just plain old C<\@tracks> | 
| 197 |  |  |  |  |  |  |  | 
| 198 |  |  |  |  |  |  | Originally $opus->tracks was the only way to deal with tracks, but I | 
| 199 |  |  |  |  |  |  | added $opus->tracks_r to make possible 1) setting the list of tracks | 
| 200 |  |  |  |  |  |  | to (), for whatever that's worth, 2) parallel structure between | 
| 201 |  |  |  |  |  |  | MIDI::Opus::tracks[_r] and MIDI::Tracks::events[_r] and 3) so you can | 
| 202 |  |  |  |  |  |  | directly manipulate the opus's tracks, without having to I the | 
| 203 |  |  |  |  |  |  | list of tracks back and forth.  This way, you can say: | 
| 204 |  |  |  |  |  |  |  | 
| 205 |  |  |  |  |  |  | $tracks_r = $opus->tracks_r(); | 
| 206 |  |  |  |  |  |  | @some_stuff = splice(@$tracks_r, 4, 6); | 
| 207 |  |  |  |  |  |  |  | 
| 208 |  |  |  |  |  |  | But if you don't know how to deal with listrefs like that, that's OK, | 
| 209 |  |  |  |  |  |  | just use $opus->tracks. | 
| 210 |  |  |  |  |  |  |  | 
| 211 |  |  |  |  |  |  | =cut | 
| 212 |  |  |  |  |  |  |  | 
| 213 |  |  |  |  |  |  | sub tracks_r { | 
| 214 | 25 |  |  | 25 | 1 | 43 | my $this = shift; | 
| 215 | 25 | 100 |  |  |  | 185 | $this->{'tracks'} = $_[0] if ref($_[0]); | 
| 216 | 25 |  |  |  |  | 119 | return $this->{'tracks'}; | 
| 217 |  |  |  |  |  |  | } | 
| 218 |  |  |  |  |  |  |  | 
| 219 |  |  |  |  |  |  | =item the method $opus->ticks( $tick_parameter ) | 
| 220 |  |  |  |  |  |  |  | 
| 221 |  |  |  |  |  |  | Returns the tick parameter from $opus, after having set it to | 
| 222 |  |  |  |  |  |  | $tick_parameter, if provided. | 
| 223 |  |  |  |  |  |  |  | 
| 224 |  |  |  |  |  |  | =cut | 
| 225 |  |  |  |  |  |  |  | 
| 226 |  |  |  |  |  |  | sub ticks { | 
| 227 | 10 |  |  | 10 | 1 | 4559 | my $this = shift; | 
| 228 | 10 | 100 |  |  |  | 45 | $this->{'ticks'} = $_[0] if defined($_[0]); | 
| 229 | 10 |  |  |  |  | 74 | return $this->{'ticks'}; | 
| 230 |  |  |  |  |  |  | } | 
| 231 |  |  |  |  |  |  |  | 
| 232 |  |  |  |  |  |  | =item the method $opus->format( $format ) | 
| 233 |  |  |  |  |  |  |  | 
| 234 |  |  |  |  |  |  | Returns the MIDI format for $opus, after having set it to | 
| 235 |  |  |  |  |  |  | $format, if provided. | 
| 236 |  |  |  |  |  |  |  | 
| 237 |  |  |  |  |  |  | =cut | 
| 238 |  |  |  |  |  |  |  | 
| 239 |  |  |  |  |  |  | sub format { | 
| 240 | 10 |  |  | 10 | 1 | 21 | my $this = shift; | 
| 241 | 10 | 100 |  |  |  | 40 | $this->{'format'} = $_[0] if defined($_[0]); | 
| 242 | 10 |  |  |  |  | 45 | return $this->{'format'}; | 
| 243 |  |  |  |  |  |  | } | 
| 244 |  |  |  |  |  |  |  | 
| 245 |  |  |  |  |  |  | sub info { # read-only | 
| 246 |  |  |  |  |  |  | # Hm, do I really want this routine?  For ANYTHING at all? | 
| 247 | 0 |  |  | 0 | 0 | 0 | my $this = shift; | 
| 248 |  |  |  |  |  |  | return ( | 
| 249 | 0 |  |  |  |  | 0 | 'format' => $this->{'format'},# I want a scalar | 
| 250 |  |  |  |  |  |  | 'ticks'  => $this->{'ticks'}, # I want a scalar | 
| 251 |  |  |  |  |  |  | 'tracks' => $this->{'tracks'} # I want a ref to a list | 
| 252 |  |  |  |  |  |  | ); | 
| 253 |  |  |  |  |  |  | } | 
| 254 |  |  |  |  |  |  |  | 
| 255 |  |  |  |  |  |  | =item the method $new_opus = $opus->quantize | 
| 256 |  |  |  |  |  |  |  | 
| 257 |  |  |  |  |  |  | This grid quantizes an opus.  It simply calls MIDI::Score::quantize on | 
| 258 |  |  |  |  |  |  | every track.  See docs for MIDI::Score::quantize.  Original opus is | 
| 259 |  |  |  |  |  |  | destroyed, use MIDI::Opus::copy if you want to take a copy first. | 
| 260 |  |  |  |  |  |  |  | 
| 261 |  |  |  |  |  |  | =cut | 
| 262 |  |  |  |  |  |  |  | 
| 263 |  |  |  |  |  |  | sub quantize { | 
| 264 | 1 |  |  | 1 | 1 | 10 | my $this = $_[0]; | 
| 265 | 1 | 50 |  |  |  | 12 | my $options_r = ref($_[1]) eq 'HASH' ? $_[1] : {}; | 
| 266 | 1 |  |  |  |  | 2 | my $grid = $options_r->{grid}; | 
| 267 | 1 | 50 |  |  |  | 5 | if ($grid < 1) {carp "bad grid $grid in MIDI::Opus::quantize!"; return;} | 
|  | 0 |  |  |  |  | 0 |  | 
|  | 0 |  |  |  |  | 0 |  | 
| 268 | 1 | 50 |  |  |  | 4 | return if ($grid eq 1); # no quantizing to do | 
| 269 | 1 |  |  |  |  | 7 | my $qd = $options_r->{durations}; # quantize durations? | 
| 270 | 1 |  |  |  |  | 2 | my $new_tracks_r = []; | 
| 271 | 1 |  |  |  |  | 3 | foreach my $track ($this->tracks) { | 
| 272 | 1 |  |  |  |  | 5 | my $score_r = MIDI::Score::events_r_to_score_r($track->events_r); | 
| 273 | 1 |  |  |  |  | 7 | my $new_score_r = MIDI::Score::quantize($score_r,{grid=>$grid,durations=>$qd}); | 
| 274 | 1 |  |  |  |  | 13 | my $events_r = MIDI::Score::score_r_to_events_r($new_score_r); | 
| 275 | 1 |  |  |  |  | 6 | my $new_track = MIDI::Track->new({events_r=>$events_r}); | 
| 276 | 1 |  |  |  |  | 2 | push @{$new_tracks_r}, $new_track; | 
|  | 1 |  |  |  |  | 13 |  | 
| 277 |  |  |  |  |  |  | } | 
| 278 | 1 |  |  |  |  | 5 | $this->tracks_r($new_tracks_r); | 
| 279 |  |  |  |  |  |  | } | 
| 280 |  |  |  |  |  |  |  | 
| 281 |  |  |  |  |  |  | ########################################################################### | 
| 282 |  |  |  |  |  |  |  | 
| 283 |  |  |  |  |  |  | =item the method $opus->dump( { ...options...} ) | 
| 284 |  |  |  |  |  |  |  | 
| 285 |  |  |  |  |  |  | Dumps the opus object as a bunch of text, for your perusal.  Options | 
| 286 |  |  |  |  |  |  | include: C, if true, will have each event in the opus as a | 
| 287 |  |  |  |  |  |  | tab-delimited line -- or as delimited with whatever you specify with | 
| 288 |  |  |  |  |  |  | option C; I, dump the data as Perl code that, if | 
| 289 |  |  |  |  |  |  | run, would/should reproduce the opus.  For concision's sake, the track data | 
| 290 |  |  |  |  |  |  | isn't dumped, unless you specify the option C as true. | 
| 291 |  |  |  |  |  |  |  | 
| 292 |  |  |  |  |  |  | =cut | 
| 293 |  |  |  |  |  |  |  | 
| 294 |  |  |  |  |  |  | sub dump { # method; read-only | 
| 295 | 0 |  |  | 0 | 1 | 0 | my $this = $_[0]; | 
| 296 | 0 |  |  |  |  | 0 | my %info = $this->info(); | 
| 297 | 0 | 0 |  |  |  | 0 | my $options_r = ref($_[1]) eq 'HASH' ? $_[1] : {}; | 
| 298 |  |  |  |  |  |  |  | 
| 299 | 0 | 0 |  |  |  | 0 | if($options_r->{'flat'}) { # Super-barebones dump mode | 
| 300 | 0 |  | 0 |  |  | 0 | my $d = $options_r->{'delimiter'} || "\t"; | 
| 301 | 0 |  |  |  |  | 0 | foreach my $track ($this->tracks) { | 
| 302 | 0 |  |  |  |  | 0 | foreach my $event (@{ $track->events_r }) { | 
|  | 0 |  |  |  |  | 0 |  | 
| 303 | 0 |  |  |  |  | 0 | print( join($d, @$event), "\n" ); | 
| 304 |  |  |  |  |  |  | } | 
| 305 |  |  |  |  |  |  | } | 
| 306 | 0 |  |  |  |  | 0 | return; | 
| 307 |  |  |  |  |  |  | } | 
| 308 |  |  |  |  |  |  |  | 
| 309 | 0 |  |  |  |  | 0 | print "MIDI::Opus->new({\n", | 
| 310 |  |  |  |  |  |  | "  'format' => ", &MIDI::_dump_quote($this->{'format'}), ",\n", | 
| 311 |  |  |  |  |  |  | "  'ticks'  => ", &MIDI::_dump_quote($this->{'ticks'}), ",\n"; | 
| 312 |  |  |  |  |  |  |  | 
| 313 | 0 |  |  |  |  | 0 | my @tracks = $this->tracks; | 
| 314 | 0 | 0 |  |  |  | 0 | if( $options_r->{'dump_tracks'} ) { | 
| 315 | 0 |  |  |  |  | 0 | print "  'tracks' => [   # ", scalar(@tracks), " tracks...\n\n"; | 
| 316 | 0 |  |  |  |  | 0 | foreach my $x (0 .. $#tracks) { | 
| 317 | 0 |  |  |  |  | 0 | my $track = $tracks[$x]; | 
| 318 | 0 |  |  |  |  | 0 | print "    # Track \#$x ...\n"; | 
| 319 | 0 | 0 |  |  |  | 0 | if(ref($track)) { | 
| 320 | 0 |  |  |  |  | 0 | $track->dump($options_r); | 
| 321 |  |  |  |  |  |  | } else { | 
| 322 | 0 |  |  |  |  | 0 | print "    # \[$track\] is not a reference!!\n"; | 
| 323 |  |  |  |  |  |  | } | 
| 324 |  |  |  |  |  |  | } | 
| 325 | 0 |  |  |  |  | 0 | print "  ]\n"; | 
| 326 |  |  |  |  |  |  | } else { | 
| 327 | 0 |  |  |  |  | 0 | print "  'tracks' => [ ],  # ", scalar(@tracks), " tracks (not dumped)\n"; | 
| 328 |  |  |  |  |  |  | } | 
| 329 | 0 |  |  |  |  | 0 | print "});\n"; | 
| 330 | 0 |  |  |  |  | 0 | return 1; | 
| 331 |  |  |  |  |  |  | } | 
| 332 |  |  |  |  |  |  |  | 
| 333 |  |  |  |  |  |  | ########################################################################### | 
| 334 |  |  |  |  |  |  | # And now the real fun... | 
| 335 |  |  |  |  |  |  | ########################################################################### | 
| 336 |  |  |  |  |  |  |  | 
| 337 |  |  |  |  |  |  | =item the method $opus->write_to_file('filespec', { ...options...} ) | 
| 338 |  |  |  |  |  |  |  | 
| 339 |  |  |  |  |  |  | Writes $opus as a MIDI file named by the given filespec. | 
| 340 |  |  |  |  |  |  | The options hash is optional, and whatever you specify as options | 
| 341 |  |  |  |  |  |  | percolates down to the calls to MIDI::Event::encode -- which see. | 
| 342 |  |  |  |  |  |  | Currently this just opens the file, calls $opus->write_to_handle | 
| 343 |  |  |  |  |  |  | on the resulting filehandle, and closes the file. | 
| 344 |  |  |  |  |  |  |  | 
| 345 |  |  |  |  |  |  | =cut | 
| 346 |  |  |  |  |  |  |  | 
| 347 |  |  |  |  |  |  | sub write_to_file { # method | 
| 348 |  |  |  |  |  |  | # call as $opus->write_to_file("../../midis/stuff1.mid", { ..options..} ); | 
| 349 | 2 |  |  | 2 | 1 | 211 | my $opus = $_[0]; | 
| 350 | 2 |  |  |  |  | 4 | my $destination = $_[1]; | 
| 351 | 2 | 50 |  |  |  | 10 | my $options_r = ref($_[2]) eq 'HASH' ?  $_[2] : {}; | 
| 352 |  |  |  |  |  |  |  | 
| 353 | 2 | 50 |  |  |  | 8 | croak "No output file specified" unless length($destination); | 
| 354 | 2 | 50 |  |  |  | 347 | unless(open(OUT_MIDI, ">$destination")) { | 
| 355 | 0 |  |  |  |  | 0 | croak "Can't open $destination for writing\: \"$!\"\n"; | 
| 356 |  |  |  |  |  |  | } | 
| 357 | 2 |  |  |  |  | 15 | $opus->write_to_handle( *OUT_MIDI{IO}, $options_r); | 
| 358 | 2 | 50 |  |  |  | 223 | close(OUT_MIDI) | 
| 359 |  |  |  |  |  |  | || croak "Can't close filehandle for $destination\: \"$!\"\n"; | 
| 360 | 2 |  |  |  |  | 18 | return; # nothing useful to return | 
| 361 |  |  |  |  |  |  | } | 
| 362 |  |  |  |  |  |  |  | 
| 363 |  |  |  |  |  |  | sub read_from_file { # method, surprisingly enough | 
| 364 |  |  |  |  |  |  | # $opus->read_from_file("ziz1.mid", {'stuff' => 1}). | 
| 365 |  |  |  |  |  |  | #  Overwrites the contents of $opus with the contents of the file ziz1.mid | 
| 366 |  |  |  |  |  |  | #  $opus is presumably newly initted. | 
| 367 |  |  |  |  |  |  | #  The options hash is optional. | 
| 368 |  |  |  |  |  |  | #  This is currently meant to be called by only the | 
| 369 |  |  |  |  |  |  | #   MIDI::Opus->new() constructor. | 
| 370 |  |  |  |  |  |  |  | 
| 371 | 9 |  |  | 9 | 0 | 22 | my $opus = $_[0]; | 
| 372 | 9 |  |  |  |  | 20 | my $source = $_[1]; | 
| 373 | 9 | 50 |  |  |  | 60 | my $options_r = ref($_[2]) eq 'HASH' ?  $_[2] : {}; | 
| 374 |  |  |  |  |  |  |  | 
| 375 | 9 | 50 |  |  |  | 42 | croak "No source file specified" unless length($source); | 
| 376 | 9 | 50 |  |  |  | 493 | unless(open(IN_MIDI, "<$source")) { | 
| 377 | 0 |  |  |  |  | 0 | croak "Can't open $source for reading\: \"$!\"\n"; | 
| 378 |  |  |  |  |  |  | } | 
| 379 | 9 |  |  |  |  | 109 | my $size = -s $source; | 
| 380 | 9 | 50 |  |  |  | 35 | $size = undef unless $size; | 
| 381 |  |  |  |  |  |  |  | 
| 382 | 9 |  |  |  |  | 71 | $opus->read_from_handle(*IN_MIDI{IO}, $options_r, $size); | 
| 383 |  |  |  |  |  |  | # Thanks to the EFNet #perl cabal for helping me puzzle out "*IN_MIDI{IO}" | 
| 384 | 9 | 50 |  |  |  | 218 | close(IN_MIDI) || | 
| 385 |  |  |  |  |  |  | croak "error while closing filehandle for $source\: \"$!\"\n"; | 
| 386 |  |  |  |  |  |  |  | 
| 387 | 9 |  |  |  |  | 42 | return $opus; | 
| 388 |  |  |  |  |  |  | } | 
| 389 |  |  |  |  |  |  |  | 
| 390 |  |  |  |  |  |  | =item the method $opus->write_to_handle(IOREF, { ...options...} ) | 
| 391 |  |  |  |  |  |  |  | 
| 392 |  |  |  |  |  |  | Writes $opus as a MIDI file to the IO handle you pass a reference to | 
| 393 |  |  |  |  |  |  | (example: C<*STDOUT{IO}>). | 
| 394 |  |  |  |  |  |  | The options hash is optional, and whatever you specify as options | 
| 395 |  |  |  |  |  |  | percolates down to the calls to MIDI::Event::encode -- which see. | 
| 396 |  |  |  |  |  |  | Note that this is probably not what you'd want for sending music | 
| 397 |  |  |  |  |  |  | to C, since MIDI files are not MIDI-on-the-wire. | 
| 398 |  |  |  |  |  |  |  | 
| 399 |  |  |  |  |  |  | =cut | 
| 400 |  |  |  |  |  |  |  | 
| 401 |  |  |  |  |  |  | ########################################################################### | 
| 402 |  |  |  |  |  |  | sub write_to_handle { # method | 
| 403 |  |  |  |  |  |  | # Call as $opus->write_to_handle( *FH{IO}, { ...options... }); | 
| 404 | 2 |  |  | 2 | 1 | 6 | my $opus = $_[0]; | 
| 405 | 2 |  |  |  |  | 4 | my $fh = $_[1]; | 
| 406 | 2 | 50 |  |  |  | 18 | my $options_r = ref($_[2]) eq 'HASH' ?  $_[2] : {}; | 
| 407 |  |  |  |  |  |  |  | 
| 408 | 2 |  |  |  |  | 15 | binmode($fh); | 
| 409 |  |  |  |  |  |  |  | 
| 410 | 2 |  |  |  |  | 13 | my $tracks = scalar( $opus->tracks ); | 
| 411 | 2 | 50 |  |  |  | 9 | carp "Writing out an opus with no tracks!\n" if $tracks == 0; | 
| 412 |  |  |  |  |  |  |  | 
| 413 | 2 |  |  |  |  | 2 | my $format; | 
| 414 | 2 | 50 |  |  |  | 9 | if( defined($opus->{'format'}) ) { | 
| 415 | 2 |  |  |  |  | 15 | $format = $opus->{'format'}; | 
| 416 |  |  |  |  |  |  | } else { # Defaults | 
| 417 | 0 | 0 |  |  |  | 0 | if($tracks == 0) { | 
|  |  | 0 |  |  |  |  |  | 
| 418 | 0 |  |  |  |  | 0 | $format = 2; # hey, why not? | 
| 419 |  |  |  |  |  |  | } elsif ($tracks == 1) { | 
| 420 | 0 |  |  |  |  | 0 | $format = 0; | 
| 421 |  |  |  |  |  |  | } else { | 
| 422 | 0 |  |  |  |  | 0 | $format = 1; | 
| 423 |  |  |  |  |  |  | } | 
| 424 |  |  |  |  |  |  | } | 
| 425 | 2 | 50 |  |  |  | 8 | my $ticks = | 
| 426 |  |  |  |  |  |  | defined($opus->{'ticks'}) ? $opus->{'ticks'} : 96 ; | 
| 427 |  |  |  |  |  |  | # Ninety-six ticks per quarter-note seems a pleasant enough default. | 
| 428 |  |  |  |  |  |  |  | 
| 429 | 2 |  |  |  |  | 48 | print $fh ( | 
| 430 |  |  |  |  |  |  | "MThd\x00\x00\x00\x06", # header; 6 bytes follow | 
| 431 |  |  |  |  |  |  | pack('nnn', $format, $tracks, $ticks) | 
| 432 |  |  |  |  |  |  | ); | 
| 433 | 2 |  |  |  |  | 7 | foreach my $track (@{ $opus->{'tracks'} }) { | 
|  | 2 |  |  |  |  | 7 |  | 
| 434 | 2 |  |  |  |  | 6 | my $data = ''; | 
| 435 | 2 |  |  |  |  | 10 | my $type = substr($track->{'type'} . "\x00\x00\x00\x00", 0, 4); | 
| 436 |  |  |  |  |  |  | # Force it to be 4 chars long. | 
| 437 | 2 |  |  |  |  | 4 | $data =  ${ $track->encode( $options_r ) }; | 
|  | 2 |  |  |  |  | 13 |  | 
| 438 |  |  |  |  |  |  | # $track->encode will handle the issue of whether | 
| 439 |  |  |  |  |  |  | #  to use the track's data or its events | 
| 440 | 2 |  |  |  |  | 42 | print $fh ($type, pack('N', length($data)), $data); | 
| 441 |  |  |  |  |  |  | } | 
| 442 | 2 |  |  |  |  | 9 | return; | 
| 443 |  |  |  |  |  |  | } | 
| 444 |  |  |  |  |  |  |  | 
| 445 |  |  |  |  |  |  | ############################################################################ | 
| 446 |  |  |  |  |  |  | sub read_from_handle { # a method, surprisingly enough | 
| 447 |  |  |  |  |  |  | # $opus->read_from_handle(*STDIN{IO}, {'stuff' => 1}). | 
| 448 |  |  |  |  |  |  | #  Overwrites the contents of $opus with the contents of the MIDI file | 
| 449 |  |  |  |  |  |  | #   from the filehandle you're passing a reference to. | 
| 450 |  |  |  |  |  |  | #  $opus is presumably newly initted. | 
| 451 |  |  |  |  |  |  | #  The options hash is optional. | 
| 452 |  |  |  |  |  |  |  | 
| 453 |  |  |  |  |  |  | #  This is currently meant to be called by only the | 
| 454 |  |  |  |  |  |  | #   MIDI::Opus->new() constructor. | 
| 455 |  |  |  |  |  |  |  | 
| 456 | 9 |  |  | 9 | 0 | 21 | my $opus = $_[0]; | 
| 457 | 9 |  |  |  |  | 21 | my $fh = $_[1]; | 
| 458 | 9 | 50 |  |  |  | 45 | my $options_r = ref($_[2]) eq 'HASH' ?  $_[2] : {}; | 
| 459 | 9 |  |  |  |  | 16 | my $file_size_left; | 
| 460 | 9 | 50 |  |  |  | 77 | $file_size_left = $_[3] if defined $_[3]; | 
| 461 |  |  |  |  |  |  |  | 
| 462 | 9 |  |  |  |  | 51 | binmode($fh); | 
| 463 |  |  |  |  |  |  |  | 
| 464 | 9 |  |  |  |  | 25 | my $in = ''; | 
| 465 |  |  |  |  |  |  |  | 
| 466 | 9 |  |  |  |  | 24 | my $track_size_limit; | 
| 467 | 9 | 50 |  |  |  | 41 | $track_size_limit = $options_r->{'track_size'} | 
| 468 |  |  |  |  |  |  | if exists $options_r->{'track_size'}; | 
| 469 |  |  |  |  |  |  |  | 
| 470 | 9 | 50 |  |  |  | 298 | croak "Can't even read the first 14 bytes from filehandle $fh" | 
| 471 |  |  |  |  |  |  | unless read($fh, $in, 14); | 
| 472 |  |  |  |  |  |  | # 14 = The expected header length. | 
| 473 |  |  |  |  |  |  |  | 
| 474 | 9 | 50 |  |  |  | 38 | if(defined $file_size_left) { | 
| 475 | 9 |  |  |  |  | 23 | $file_size_left -= 14; | 
| 476 |  |  |  |  |  |  | } | 
| 477 |  |  |  |  |  |  |  | 
| 478 | 9 |  |  |  |  | 80 | my($id, $length, $format, $tracks_expected, $ticks) = unpack('A4Nnnn', $in); | 
| 479 |  |  |  |  |  |  |  | 
| 480 | 9 | 50 |  |  |  | 37 | croak "data from handle $fh doesn't start with a MIDI file header" | 
| 481 |  |  |  |  |  |  | unless $id eq 'MThd'; | 
| 482 | 9 | 50 |  |  |  | 60 | croak "Unexpected MTHd chunk length in data from handle $fh" | 
| 483 |  |  |  |  |  |  | unless $length == 6; | 
| 484 | 9 |  |  |  |  | 23 | $opus->{'format'} = $format; | 
| 485 | 9 |  |  |  |  | 23 | $opus->{'ticks'}  = $ticks;   # ...which may be a munged 'negative' number | 
| 486 | 9 |  |  |  |  | 23 | $opus->{'tracks'} = []; | 
| 487 |  |  |  |  |  |  |  | 
| 488 | 9 | 50 |  |  |  | 50 | print "file header from handle $fh read and parsed fine.\n" if $Debug; | 
| 489 | 9 |  |  |  |  | 17 | my $track_count = 0; | 
| 490 |  |  |  |  |  |  |  | 
| 491 |  |  |  |  |  |  | Track_Chunk: | 
| 492 | 9 |  |  |  |  | 194 | until( eof($fh) ) { | 
| 493 | 15 |  |  |  |  | 41 | ++$track_count; | 
| 494 | 15 | 50 |  |  |  | 50 | print "Reading Track \# $track_count into a new track\n" if $Debug; | 
| 495 |  |  |  |  |  |  |  | 
| 496 | 15 | 50 |  |  |  | 45 | if(defined $file_size_left) { | 
| 497 | 15 |  |  |  |  | 24 | $file_size_left -= 2; | 
| 498 | 15 | 50 |  |  |  | 48 | croak "reading further would exceed file_size_limit" | 
| 499 |  |  |  |  |  |  | if $file_size_left < 0; | 
| 500 |  |  |  |  |  |  | } | 
| 501 |  |  |  |  |  |  |  | 
| 502 | 15 |  |  |  |  | 27 | my($header, $data); | 
| 503 | 15 | 50 |  |  |  | 81 | croak "Can't read header for track chunk \#$track_count" | 
| 504 |  |  |  |  |  |  | unless read($fh, $header, 8); | 
| 505 | 15 |  |  |  |  | 59 | my($type, $length) = unpack('A4N', $header); | 
| 506 |  |  |  |  |  |  |  | 
| 507 | 15 | 50 | 33 |  |  | 57 | if(defined $track_size_limit and $track_size_limit > $length) { | 
| 508 | 0 |  |  |  |  | 0 | croak "Track \#$track_count\'s length ($length) would" | 
| 509 |  |  |  |  |  |  | . " exceed track_size_limit $track_size_limit"; | 
| 510 |  |  |  |  |  |  | } | 
| 511 |  |  |  |  |  |  |  | 
| 512 | 15 | 50 |  |  |  | 55 | if(defined $file_size_left) { | 
| 513 | 15 |  |  |  |  | 22 | $file_size_left -= $length; | 
| 514 | 15 | 50 |  |  |  | 43 | croak "reading track \#$track_count (of length $length) " | 
| 515 |  |  |  |  |  |  | . "would exceed file_size_limit" | 
| 516 |  |  |  |  |  |  | if $file_size_left < 0; | 
| 517 |  |  |  |  |  |  | } | 
| 518 |  |  |  |  |  |  |  | 
| 519 | 15 |  |  |  |  | 70 | read($fh, $data, $length);   # whooboy, actually read it now | 
| 520 |  |  |  |  |  |  |  | 
| 521 | 15 | 50 |  |  |  | 53 | if($length == length($data)) { | 
| 522 | 15 |  |  |  |  | 101 | push( | 
| 523 | 15 |  |  |  |  | 23 | @{ $opus->{'tracks'} }, | 
| 524 |  |  |  |  |  |  | &MIDI::Track::decode( $type, \$data, $options_r ) | 
| 525 |  |  |  |  |  |  | ); | 
| 526 |  |  |  |  |  |  | } else { | 
| 527 | 0 |  |  |  |  | 0 | croak | 
| 528 |  |  |  |  |  |  | "Length of track \#$track_count is off in data from $fh; " | 
| 529 |  |  |  |  |  |  | . "I wanted $length\, but got " | 
| 530 |  |  |  |  |  |  | . length($data); | 
| 531 |  |  |  |  |  |  | } | 
| 532 |  |  |  |  |  |  | } | 
| 533 |  |  |  |  |  |  |  | 
| 534 |  |  |  |  |  |  | carp | 
| 535 | 9 | 50 |  |  |  | 58 | "Header in data from $fh says to expect $tracks_expected tracks, " | 
| 536 |  |  |  |  |  |  | . "but $track_count were found\n" | 
| 537 |  |  |  |  |  |  | unless $tracks_expected == $track_count; | 
| 538 | 9 | 50 |  |  |  | 832 | carp "No tracks read in data from $fh\n" if $track_count == 0; | 
| 539 |  |  |  |  |  |  |  | 
| 540 | 9 |  |  |  |  | 33 | return $opus; | 
| 541 |  |  |  |  |  |  | } | 
| 542 |  |  |  |  |  |  | ########################################################################### | 
| 543 |  |  |  |  |  |  |  | 
| 544 |  |  |  |  |  |  | =item the method $opus->draw({ ...options...}) | 
| 545 |  |  |  |  |  |  |  | 
| 546 |  |  |  |  |  |  | This currently experimental method returns a new GD image object that's | 
| 547 |  |  |  |  |  |  | a graphic representation of the notes in the given opus.  Options include: | 
| 548 |  |  |  |  |  |  | C -- the width of the image in pixels (defaults to 600); | 
| 549 |  |  |  |  |  |  | C -- a six-digit hex RGB representation of the background color | 
| 550 |  |  |  |  |  |  | for the image (defaults to $MIDI::Opus::BG_color, currently '000000'); | 
| 551 |  |  |  |  |  |  | C -- a reference to a list of colors (in six-digit hex RGB) | 
| 552 |  |  |  |  |  |  | to use for representing notes on given channels. | 
| 553 |  |  |  |  |  |  | Defaults to @MIDI::Opus::Channel_colors. | 
| 554 |  |  |  |  |  |  | This list is a list of pairs of colors, such that: | 
| 555 |  |  |  |  |  |  | the first of a pair (color N*2) is the color for the first pixel in a | 
| 556 |  |  |  |  |  |  | note on channel N; and the second (color N*2 + 1) is the color for the | 
| 557 |  |  |  |  |  |  | remaining pixels of that note.  If you specify only enough colors for | 
| 558 |  |  |  |  |  |  | channels 0 to M, notes on a channels above M will use 'recycled' | 
| 559 |  |  |  |  |  |  | colors -- they will be plotted with the color for channel | 
| 560 |  |  |  |  |  |  | "channel_number % M" (where C<%> = the MOD operator). | 
| 561 |  |  |  |  |  |  |  | 
| 562 |  |  |  |  |  |  | This means that if you specify | 
| 563 |  |  |  |  |  |  |  | 
| 564 |  |  |  |  |  |  | channel_colors => ['00ffff','0000ff'] | 
| 565 |  |  |  |  |  |  |  | 
| 566 |  |  |  |  |  |  | then all the channels' notes will be plotted with an aqua pixel followed | 
| 567 |  |  |  |  |  |  | by blue ones; and if you specify | 
| 568 |  |  |  |  |  |  |  | 
| 569 |  |  |  |  |  |  | channel_colors => ['00ffff','0000ff', 'ff00ff','ff0000'] | 
| 570 |  |  |  |  |  |  |  | 
| 571 |  |  |  |  |  |  | then all the I channels' notes will be plotted with an aqua | 
| 572 |  |  |  |  |  |  | pixel followed by blue ones, and all the I channels' notes will | 
| 573 |  |  |  |  |  |  | be plotted with a purple pixel followed by red ones. | 
| 574 |  |  |  |  |  |  |  | 
| 575 |  |  |  |  |  |  | As to what to do with the object you get back, you probably want | 
| 576 |  |  |  |  |  |  | something like: | 
| 577 |  |  |  |  |  |  |  | 
| 578 |  |  |  |  |  |  | $im = $chachacha->draw; | 
| 579 |  |  |  |  |  |  | open(OUT, ">$gif_out"); binmode(OUT); | 
| 580 |  |  |  |  |  |  | print OUT $im->gif; | 
| 581 |  |  |  |  |  |  | close(OUT); | 
| 582 |  |  |  |  |  |  |  | 
| 583 |  |  |  |  |  |  | Using this method will cause a C if it can't successfully C | 
| 584 |  |  |  |  |  |  |  | 
| 585 |  |  |  |  |  |  | I emphasise that C is expermental, and, in any case, is only meant | 
| 586 |  |  |  |  |  |  | to be a crude hack.  Notably, it does not address well some basic problems: | 
| 587 |  |  |  |  |  |  | neither volume nor patch-selection (nor any notable aspects of the | 
| 588 |  |  |  |  |  |  | patch selected) | 
| 589 |  |  |  |  |  |  | are represented; pitch-wheel changes are not represented; | 
| 590 |  |  |  |  |  |  | percussion (whether on percussive patches or on channel 10) is not | 
| 591 |  |  |  |  |  |  | specially represented, as it probably should be; | 
| 592 |  |  |  |  |  |  | notes overlapping are not represented at all well. | 
| 593 |  |  |  |  |  |  |  | 
| 594 |  |  |  |  |  |  | =cut | 
| 595 |  |  |  |  |  |  |  | 
| 596 |  |  |  |  |  |  | sub draw { # method | 
| 597 | 0 |  |  | 0 | 1 |  | my $opus = $_[0]; | 
| 598 | 0 | 0 |  |  |  |  | my $options_r = ref($_[1]) ? $_[1] : {}; | 
| 599 |  |  |  |  |  |  |  | 
| 600 | 0 |  |  |  |  |  | &use_GD(); # will die at runtime if we call this function but it can't use GD | 
| 601 |  |  |  |  |  |  |  | 
| 602 | 0 |  |  |  |  |  | my $opus_time = 0; | 
| 603 | 0 |  |  |  |  |  | my @scores = (); | 
| 604 | 0 |  |  |  |  |  | foreach my $track ($opus->tracks) { | 
| 605 | 0 |  |  |  |  |  | my($score_r, $track_time) = MIDI::Score::events_r_to_score_r( | 
| 606 |  |  |  |  |  |  | $track->events_r ); | 
| 607 | 0 | 0 |  |  |  |  | push(@scores, $score_r) if @$score_r; | 
| 608 | 0 | 0 |  |  |  |  | $opus_time = $track_time if $track_time > $opus_time; | 
| 609 |  |  |  |  |  |  | } | 
| 610 |  |  |  |  |  |  |  | 
| 611 | 0 |  | 0 |  |  |  | my $width = $options_r->{'width'} || 600; | 
| 612 |  |  |  |  |  |  |  | 
| 613 | 0 | 0 |  |  |  |  | croak "opus can't be drawn because it takes no time" unless $opus_time; | 
| 614 | 0 |  |  |  |  |  | my $pixtix = $opus_time / $width; # Number of ticks a pixel represents | 
| 615 |  |  |  |  |  |  |  | 
| 616 | 0 |  |  |  |  |  | my $im = GD::Image->new($width,127); | 
| 617 |  |  |  |  |  |  | # This doesn't handle pitch wheel, nor does it tread things on channel 10 | 
| 618 |  |  |  |  |  |  | #  (percussion) as specially as it probably should. | 
| 619 |  |  |  |  |  |  | # The problem faced here is how to map onto pixel color all the | 
| 620 |  |  |  |  |  |  | #  characteristics of a note (say, Channel, Note, Volume, and Patch). | 
| 621 |  |  |  |  |  |  | # I'll just do it for channels.  Rewrite this on your own if you want | 
| 622 |  |  |  |  |  |  | #  something different. | 
| 623 |  |  |  |  |  |  |  | 
| 624 | 0 | 0 |  |  |  |  | my $bg_color = | 
| 625 |  |  |  |  |  |  | $im->colorAllocate(unpack('C3', pack('H2H2H2',unpack('a2a2a2', | 
| 626 |  |  |  |  |  |  | ( length($options_r->{'bg_color'}) ? $options_r->{'bg_color'} | 
| 627 |  |  |  |  |  |  | : $MIDI::Opus::BG_color) | 
| 628 |  |  |  |  |  |  | ))) ); | 
| 629 | 0 | 0 |  |  |  |  | @MIDI::Opus::Channel_colors = ( '00ffff' , '0000ff' ) | 
| 630 |  |  |  |  |  |  | unless @MIDI::Opus::Channel_colors; | 
| 631 | 0 |  |  |  |  |  | my @colors = | 
| 632 |  |  |  |  |  |  | map( $im->colorAllocate( | 
| 633 |  |  |  |  |  |  | unpack('C3', pack('H2H2H2',unpack('a2a2a2',$_))) | 
| 634 |  |  |  |  |  |  | ), # convert 6-digit hex to a scalar tuple | 
| 635 |  |  |  |  |  |  | ref($options_r->{'channel_colors'}) ? | 
| 636 | 0 | 0 |  |  |  |  | @{$options_r->{'channel_colors'}} : @MIDI::Opus::Channel_colors | 
| 637 |  |  |  |  |  |  | ); | 
| 638 | 0 |  |  |  |  |  | my $channels_in_palette = int(@colors / 2); | 
| 639 | 0 |  |  |  |  |  | $im->fill(0,0,$bg_color); | 
| 640 | 0 |  |  |  |  |  | foreach my $score_r (@scores) { | 
| 641 | 0 |  |  |  |  |  | foreach my $event_r (@$score_r) { | 
| 642 | 0 | 0 |  |  |  |  | next unless $event_r->[0] eq 'note'; | 
| 643 | 0 |  |  |  |  |  | my($time, $duration, $channel, $note, $volume) = @{$event_r}[1,2,3,4,5]; | 
|  | 0 |  |  |  |  |  |  | 
| 644 | 0 |  |  |  |  |  | my $y = 127 - $note; | 
| 645 | 0 |  |  |  |  |  | my $start_x = $time / $pixtix; | 
| 646 | 0 |  |  |  |  |  | $im->line($start_x, $y, ($time + $duration) / $pixtix, $y, | 
| 647 |  |  |  |  |  |  | $colors[1 + ($channel % $channels_in_palette)] ); | 
| 648 | 0 |  |  |  |  |  | $im->setPixel($start_x , $y, $colors[$channel % $channels_in_palette] ); | 
| 649 |  |  |  |  |  |  | } | 
| 650 |  |  |  |  |  |  | } | 
| 651 | 0 |  |  |  |  |  | return $im; # Returns the GD object, which the user then dumps however | 
| 652 |  |  |  |  |  |  | } | 
| 653 |  |  |  |  |  |  |  | 
| 654 |  |  |  |  |  |  | #-------------------------------------------------------------------------- | 
| 655 |  |  |  |  |  |  | { # Closure so we can use this wonderful variable: | 
| 656 |  |  |  |  |  |  | my $GD_used = 0; | 
| 657 |  |  |  |  |  |  | sub use_GD { | 
| 658 | 0 | 0 |  | 0 | 0 |  | return if $GD_used; | 
| 659 | 0 | 0 |  |  |  |  | eval("use GD;"); croak "You don't seem to have GD installed." if $@; | 
|  | 0 |  |  |  |  |  |  | 
| 660 | 0 |  |  |  |  |  | $GD_used = 1; return; | 
|  | 0 |  |  |  |  |  |  | 
| 661 |  |  |  |  |  |  | } | 
| 662 |  |  |  |  |  |  | # Why use GD at runtime like this, instead of at compile-time like normal? | 
| 663 |  |  |  |  |  |  | # So we can still use everything in this module except &draw even if we | 
| 664 |  |  |  |  |  |  | # don't have GD on this system. | 
| 665 |  |  |  |  |  |  | } | 
| 666 |  |  |  |  |  |  |  | 
| 667 |  |  |  |  |  |  | ###################################################################### | 
| 668 |  |  |  |  |  |  | # This maps channel number onto colors for draw(). It is quite unimaginative, | 
| 669 |  |  |  |  |  |  | #  and reuses colors two or three times.  It's a package global.  You can | 
| 670 |  |  |  |  |  |  | #  change it by assigning to @MIDI::Simple::Channel_colors. | 
| 671 |  |  |  |  |  |  |  | 
| 672 |  |  |  |  |  |  | @MIDI::Opus::Channel_colors = | 
| 673 |  |  |  |  |  |  | ( | 
| 674 |  |  |  |  |  |  | 'c0c0ff', '6060ff',  # start / sustain color, channel 0 | 
| 675 |  |  |  |  |  |  | 'c0ffc0', '60ff60',  # start / sustain color, channel 1, etc... | 
| 676 |  |  |  |  |  |  | 'ffc0c0', 'ff6060',  'ffc0ff', 'ff60ff',  'ffffc0', 'ffff60', | 
| 677 |  |  |  |  |  |  | 'c0ffff', '60ffff', | 
| 678 |  |  |  |  |  |  |  | 
| 679 |  |  |  |  |  |  | 'c0c0ff', '6060ff',  'c0ffc0', '60ff60',  'ffc0c0', 'ff6060', | 
| 680 |  |  |  |  |  |  | 'c0c0c0', '707070', # channel 10 | 
| 681 |  |  |  |  |  |  |  | 
| 682 |  |  |  |  |  |  | 'ffc0ff', 'ff60ff',  'ffffc0', 'ffff60',  'c0ffff', '60ffff', | 
| 683 |  |  |  |  |  |  | 'c0c0ff', '6060ff',  'c0ffc0', '60ff60',  'ffc0c0', 'ff6060', | 
| 684 |  |  |  |  |  |  | ); | 
| 685 |  |  |  |  |  |  | $MIDI::Opus::BG_color = '000000'; # Black goes with everything, you know. | 
| 686 |  |  |  |  |  |  |  | 
| 687 |  |  |  |  |  |  | ########################################################################### | 
| 688 |  |  |  |  |  |  |  | 
| 689 |  |  |  |  |  |  | =back | 
| 690 |  |  |  |  |  |  |  | 
| 691 |  |  |  |  |  |  | =head1 WHERE'S THE DESTRUCTOR? | 
| 692 |  |  |  |  |  |  |  | 
| 693 |  |  |  |  |  |  | Because MIDI objects (whether opuses or tracks) do not contain any | 
| 694 |  |  |  |  |  |  | circular data structures, you don't need to explicitly destroy them in | 
| 695 |  |  |  |  |  |  | order to deallocate their memory.  Consider this code snippet: | 
| 696 |  |  |  |  |  |  |  | 
| 697 |  |  |  |  |  |  | use MIDI; | 
| 698 |  |  |  |  |  |  | foreach $one (@ARGV) { | 
| 699 |  |  |  |  |  |  | my $opus = MIDI::Opus->new({ 'from_file' => $one, 'no_parse' => 1 }); | 
| 700 |  |  |  |  |  |  | print "$one has ", scalar( $opus->tracks ) " tracks\n"; | 
| 701 |  |  |  |  |  |  | } | 
| 702 |  |  |  |  |  |  |  | 
| 703 |  |  |  |  |  |  | At the end of each iteration of the foreach loop, the variable $opus | 
| 704 |  |  |  |  |  |  | goes away, along with its contents, a reference to the opus object. | 
| 705 |  |  |  |  |  |  | Since no other references to it exist (i.e., you didn't do anything like | 
| 706 |  |  |  |  |  |  | push(@All_opuses,$opus) where @All_opuses is a global), the object is | 
| 707 |  |  |  |  |  |  | automagically destroyed and its memory marked for recovery. | 
| 708 |  |  |  |  |  |  |  | 
| 709 |  |  |  |  |  |  | If you wanted to explicitly free up the memory used by a given opus | 
| 710 |  |  |  |  |  |  | object (and its tracks, if those tracks aren't used anywhere else) without | 
| 711 |  |  |  |  |  |  | having to wait for it to pass out of scope, just replace it with a new | 
| 712 |  |  |  |  |  |  | empty object: | 
| 713 |  |  |  |  |  |  |  | 
| 714 |  |  |  |  |  |  | $opus = MIDI::Opus->new; | 
| 715 |  |  |  |  |  |  |  | 
| 716 |  |  |  |  |  |  | or replace it with anything at all -- or even just undef it: | 
| 717 |  |  |  |  |  |  |  | 
| 718 |  |  |  |  |  |  | undef $opus; | 
| 719 |  |  |  |  |  |  |  | 
| 720 |  |  |  |  |  |  | Of course, in the latter case, you can't then use $opus as an opus | 
| 721 |  |  |  |  |  |  | object anymore, since it isn't one. | 
| 722 |  |  |  |  |  |  |  | 
| 723 |  |  |  |  |  |  | =head1 NOTE ON TICKS | 
| 724 |  |  |  |  |  |  |  | 
| 725 |  |  |  |  |  |  | If you want to use "negative" values for ticks (so says the spec: "If | 
| 726 |  |  |  |  |  |  | division is negative, it represents the division of a second | 
| 727 |  |  |  |  |  |  | represented by the delta-times in the file,[...]"), then it's up to | 
| 728 |  |  |  |  |  |  | you to figure out how to represent that whole ball of wax so that when | 
| 729 |  |  |  |  |  |  | it gets C'd as an "n", it comes out right.  I think it'll involve | 
| 730 |  |  |  |  |  |  | something like: | 
| 731 |  |  |  |  |  |  |  | 
| 732 |  |  |  |  |  |  | $opus->ticks(  (unpack('C', pack('c', -25)) << 8) & 80  ); | 
| 733 |  |  |  |  |  |  |  | 
| 734 |  |  |  |  |  |  | for bit resolution (80) at 25 f/s. | 
| 735 |  |  |  |  |  |  |  | 
| 736 |  |  |  |  |  |  | But I've never tested this.  Let me know if you get it working right, | 
| 737 |  |  |  |  |  |  | OK?  If anyone I get it working right, and tells me how, I'll | 
| 738 |  |  |  |  |  |  | try to support it natively. | 
| 739 |  |  |  |  |  |  |  | 
| 740 |  |  |  |  |  |  | =head1 NOTE ON WARN-ING AND DIE-ING | 
| 741 |  |  |  |  |  |  |  | 
| 742 |  |  |  |  |  |  | In the case of trying to parse a malformed MIDI file (which is not a | 
| 743 |  |  |  |  |  |  | common thing, in my experience), this module (or MIDI::Track or | 
| 744 |  |  |  |  |  |  | MIDI::Event) may warn() or die() (Actually, carp() or croak(), but | 
| 745 |  |  |  |  |  |  | it's all the same in the end).  For this reason, you shouldn't use | 
| 746 |  |  |  |  |  |  | this suite in a case where the script, well, can't warn or die -- such | 
| 747 |  |  |  |  |  |  | as, for example, in a CGI that scans for text events in a uploaded | 
| 748 |  |  |  |  |  |  | MIDI file that may or may not be well-formed.  If this I the kind | 
| 749 |  |  |  |  |  |  | of task you or someone you know may want to do, let me know and I'll | 
| 750 |  |  |  |  |  |  | consider some kind of 'no_die' parameter in future releases. | 
| 751 |  |  |  |  |  |  | (Or just trap the die in an eval { } around your call to anything you | 
| 752 |  |  |  |  |  |  | think you could die.) | 
| 753 |  |  |  |  |  |  |  | 
| 754 |  |  |  |  |  |  | =head1 COPYRIGHT | 
| 755 |  |  |  |  |  |  |  | 
| 756 |  |  |  |  |  |  | Copyright (c) 1998-2002 Sean M. Burke. All rights reserved. | 
| 757 |  |  |  |  |  |  |  | 
| 758 |  |  |  |  |  |  | This library is free software; you can redistribute it and/or | 
| 759 |  |  |  |  |  |  | modify it under the same terms as Perl itself. | 
| 760 |  |  |  |  |  |  |  | 
| 761 |  |  |  |  |  |  | =head1 AUTHORS | 
| 762 |  |  |  |  |  |  |  | 
| 763 |  |  |  |  |  |  | Sean M. Burke C (until 2010) | 
| 764 |  |  |  |  |  |  |  | 
| 765 |  |  |  |  |  |  | Darrell Conklin C (from 2010) | 
| 766 |  |  |  |  |  |  |  | 
| 767 |  |  |  |  |  |  | =cut | 
| 768 |  |  |  |  |  |  |  | 
| 769 |  |  |  |  |  |  | 1; | 
| 770 |  |  |  |  |  |  | __END__ |