| File: | blib/lib/Music/NWC2MusicXML/Parser.pm |
| Coverage: | 80.3% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package Music::NWC2MusicXML::Parser; | |||||
| 2 | ||||||
| 3 | 14 14 14 | 112616 6 93 | use strict; | |||
| 4 | 14 14 14 | 10 7 229 | use warnings; | |||
| 5 | 14 14 14 | 188 7030 30 | use autodie qw(:all); | |||
| 6 | ||||||
| 7 | our $VERSION = '0.001.1'; | |||||
| 8 | ||||||
| 9 | 14 14 14 | 25498 12 214 | use Carp qw(croak carp); | |||
| 10 | 14 14 14 | 270 2040 174 | use Readonly; | |||
| 11 | 14 14 14 | 416 17879 161 | use Params::Validate::Strict qw(validate_strict); | |||
| 12 | 14 14 14 | 268 4121 125 | use Params::Get; | |||
| 13 | 14 14 14 | 1344 13 116 | use Music::NWC2MusicXML::Score; | |||
| 14 | 14 14 14 | 16 5 57 | use Music::NWC2MusicXML::Staff; | |||
| 15 | 14 14 14 | 10 7 15893 | use Music::NWC2MusicXML::Event; | |||
| 16 | ||||||
| 17 | # --------------------------------------------------------------------------- | |||||
| 18 | # Constants | |||||
| 19 | # --------------------------------------------------------------------------- | |||||
| 20 | ||||||
| 21 | # Maximum number of records to parse before deciding the file is pathological. | |||||
| 22 | Readonly::Scalar my $MAX_RECORDS => 1_000_000; | |||||
| 23 | ||||||
| 24 | # The NWCTXT header line prefix | |||||
| 25 | Readonly::Scalar my $HEADER_PREFIX => '!NoteWorthyComposer('; | |||||
| 26 | ||||||
| 27 | # Dynamic markings recognised by NWC | |||||
| 28 | Readonly::Hash my %VALID_DYNAMICS => map { $_ => 1 } | |||||
| 29 | qw(pppp ppp pp p mp mf f ff fff ffff); | |||||
| 30 | ||||||
| 31 | # Clef names recognised by NWC and their canonical spellings | |||||
| 32 | Readonly::Hash my %VALID_CLEFS => map { $_ => 1 } | |||||
| 33 | qw(Treble Bass Alto Tenor Percussion Tab); | |||||
| 34 | ||||||
| 35 | # NWC lists key-signature accidentals in the standard circle-of-fifths order. | |||||
| 36 | # Signature:F#,C# = 2 sharps = D major (fifths +2) | |||||
| 37 | # Signature:Bb = 1 flat = F major (fifths -1) | |||||
| 38 | # We compute the fifths value by counting the accidentals rather than using | |||||
| 39 | # a lookup table, which handles any combination and avoids the common mistake | |||||
| 40 | # of confusing the tonic name with the signature accidental list. | |||||
| 41 | ||||||
| 42 | # The 'C' signature token means no accidentals (C major / A minor = fifths 0). | |||||
| 43 | Readonly::Scalar my $KEY_SIG_NATURAL => 'C'; | |||||
| 44 | ||||||
| 45 | # Pitch step letters recognised in NWC note records | |||||
| 46 | Readonly::Hash my %VALID_STEPS => map { $_ => 1 } qw(A B C D E F G); | |||||
| 47 | ||||||
| 48 | Readonly::Hash my %MESSAGES => ( | |||||
| 49 | error_empty_input => 'NWCTXT input is empty or undefined', | |||||
| 50 | error_no_header => 'NWCTXT does not begin with expected header', | |||||
| 51 | error_too_many_records=> 'Input exceeds maximum record limit (%d)', | |||||
| 52 | error_bad_record => 'Malformed NWCTXT record at line %d: %s', | |||||
| 53 | error_no_staff => 'Musical event %s encountered before any AddStaff record', | |||||
| 54 | error_internal => 'Internal error: %s', | |||||
| 55 | warn_unknown_record => 'Unknown NWCTXT record type %s at line %d -- stored as UnsupportedEvent', | |||||
| 56 | warn_bad_value => 'Unrecognised value for %s: %s at line %d', | |||||
| 57 | ); | |||||
| 58 | ||||||
| 59 - 104 | =head1 NAME Music::NWC2MusicXML::Parser - NWCTXT text parser producing an internal score representation. =head1 VERSION 0.001.1 =head1 SYNOPSIS use Music::NWC2MusicXML::Parser; my $parser = Music::NWC2MusicXML::Parser->new; my $score = $parser->parse($nwctxt); =head1 DESCRIPTION C<Music::NWC2MusicXML::Parser> accepts the NWCTXT string produced by C<Music::NWC2MusicXML::NWC> and returns a C<Music::NWC2MusicXML::Score> object. The internal representation is completely independent of MusicXML so that parsing and MusicXML generation can be tested separately. =head2 NWCTXT record structure Each record occupies one line and begins with C<|>: |RecordType|Field1:Value1|Field2:Value2|... Fields are pipe-delimited. Values may be: =over 4 =item * unquoted single tokens =item * double-quoted strings (which may contain C<|> and C<:>) =item * comma-separated lists =back The parser does B<not> use C<split(/[|]/)> because quoted values and escape sequences require a proper tokeniser. =cut | |||||
| 105 | ||||||
| 106 | # --------------------------------------------------------------------------- | |||||
| 107 | # new | |||||
| 108 | # --------------------------------------------------------------------------- | |||||
| 109 | ||||||
| 110 - 145 | =head2 new Construct a parser. =head3 Arguments Named parameters: =over 4 =item C<diagnostics> -- a C<Music::NWC2MusicXML::Diagnostics> instance (optional). =back =head3 Returns Blessed C<Music::NWC2MusicXML::Parser> object. =head3 API SPECIFICATION =head4 Input diagnostics : Music::NWC2MusicXML::Diagnostics (optional) =head4 Output Music::NWC2MusicXML::Parser object =head3 FORMAL SPECIFICATION [ParserInit] diagnostics : Diagnostics (placeholder -- populate with Z calculus as implementation matures) =cut | |||||
| 146 | ||||||
| 147 | sub new { | |||||
| 148 | 216 | 986804 | my ($class, %input) = @_; | |||
| 149 | 216 | 381 | my $args = validate_strict( | |||
| 150 | schema => { | |||||
| 151 | diagnostics => { type => 'object', optional => 1 }, | |||||
| 152 | }, | |||||
| 153 | input => \%input, | |||||
| 154 | ); | |||||
| 155 | 216 | 6233 | croak $@ unless defined $args; | |||
| 156 | ||||||
| 157 | my $self = bless { | |||||
| 158 | _diagnostics => $args->{diagnostics}, | |||||
| 159 | 216 | 308 | _score => undef, | |||
| 160 | _line_no => 0, | |||||
| 161 | _record_count => 0, | |||||
| 162 | }, $class; | |||||
| 163 | ||||||
| 164 | 216 | 371 | return $self; | |||
| 165 | } | |||||
| 166 | ||||||
| 167 | # --------------------------------------------------------------------------- | |||||
| 168 | # Public: parse | |||||
| 169 | # --------------------------------------------------------------------------- | |||||
| 170 | ||||||
| 171 - 242 | =head2 parse Parse a complete NWCTXT string and return the corresponding C<Music::NWC2MusicXML::Score>. =head3 Purpose This is the primary entry point. It iterates over each line of the NWCTXT, dispatches to a type-specific handler, and accumulates the results into a Score object. =head3 Arguments =over 4 =item C<$nwctxt> -- scalar string containing the full NWCTXT representation (required). =back =head3 Returns A C<Music::NWC2MusicXML::Score> object. =head3 Side Effects Croaks on fatal structural errors (e.g. missing header). Issues warnings via C<diagnostics> for non-fatal issues (e.g. unknown records). =head3 Usage Example my $score = Music::NWC2MusicXML::Parser->new->parse($nwctxt); =head3 API SPECIFICATION =head4 Input $nwctxt : SCALAR (UTF-8, required) -- Valid domain: non-empty string beginning with the line -- '!NoteWorthyComposer(<version>)' followed by pipe-delimited records -- Invalid partitions: -- undef or '' -> croaks error_empty_input -- non-empty but missing header -> croaks error_no_header -- Boundary: MAX_RECORDS = 1,000,000 pipe-delimited records -- At exactly 1,000,000 records: accepted -- At 1,000,001+ records: croaks error_too_many_records =head4 Output Music::NWC2MusicXML::Score =head3 MESSAGES | Code | Meaning | Resolution | |-----------------------|------------------------------------------|-------------------------------| | error_empty_input | Input is undef or zero-length | Check NWC decoder output | | error_no_header | Header line not found | Verify NWC binary decoder | | error_too_many_records| Record count exceeds MAX_RECORDS | Input may be malicious/corrupt| | error_bad_record | Record cannot be tokenised | File may be corrupt | | error_no_staff | Event seen before first AddStaff | NWCTXT may be truncated | | warn_unknown_record | Unknown record type stored as Unsupported| New NWC version may add types | =head3 FORMAL SPECIFICATION [Parse] nwctxt? : NWCTXT ---------- score! : Score (placeholder) =cut | |||||
| 243 | ||||||
| 244 | sub parse { | |||||
| 245 | 209 | 2485 | my ($self, $nwctxt) = @_; | |||
| 246 | ||||||
| 247 | 209 | 386 | croak _fmt_msg('error_empty_input') | |||
| 248 | unless defined $nwctxt && length $nwctxt; | |||||
| 249 | ||||||
| 250 | # Initialise fresh parse state for each call, enabling object reuse. | |||||
| 251 | 191 | 367 | $self->{_score} = Music::NWC2MusicXML::Score->new; | |||
| 252 | 191 | 138 | $self->{_line_no} = 0; | |||
| 253 | 191 | 121 | $self->{_record_count} = 0; | |||
| 254 | ||||||
| 255 | 191 | 248466 | my @lines = split /\r?\n/, $nwctxt; | |||
| 256 | ||||||
| 257 | # First non-blank line must be the NWCTXT header | |||||
| 258 | 191 | 193 | my $header = shift @lines; | |||
| 259 | 191 | 139 | $self->{_line_no}++; | |||
| 260 | ||||||
| 261 | 191 | 379 | croak _fmt_msg('error_no_header') | |||
| 262 | unless defined $header | |||||
| 263 | && index($header, $HEADER_PREFIX) == 0; | |||||
| 264 | ||||||
| 265 | # Extract version string from header: !NoteWorthyComposer(2.751) | |||||
| 266 | 184 | 2405 | my ($version) = $header =~ /\A\Q$HEADER_PREFIX\E([^)]+)/; | |||
| 267 | 184 | 205 | $self->{_score}{_nwc_version} = $version; | |||
| 268 | ||||||
| 269 | # Main parsing loop | |||||
| 270 | 184 | 147 | for my $line (@lines) { | |||
| 271 | 1218024 | 350526 | $self->{_line_no}++; | |||
| 272 | 1218024 | 752316 | next unless defined $line && length $line; | |||
| 273 | 1218023 | 583274 | next if $line =~ /\A\s*\z/; # blank lines are legal | |||
| 274 | ||||||
| 275 | croak _fmt_msg('error_too_many_records', $MAX_RECORDS) | |||||
| 276 | 1218022 | 481036 | if ++$self->{_record_count} > $MAX_RECORDS; | |||
| 277 | ||||||
| 278 | # All NWCTXT records begin with '|' | |||||
| 279 | 1218021 | 564716 | next unless $line =~ /\A\|/; | |||
| 280 | ||||||
| 281 | 1217968 | 405816 | $self->_dispatch_record($line); | |||
| 282 | } | |||||
| 283 | ||||||
| 284 | 182 | 17096 | return $self->{_score}; | |||
| 285 | } | |||||
| 286 | ||||||
| 287 | # --------------------------------------------------------------------------- | |||||
| 288 | # Package-level dispatch table -- built once at module load, not per call. | |||||
| 289 | # Subs are compile-time symbols; Readonly ensures the table is never mutated. | |||||
| 290 | # --------------------------------------------------------------------------- | |||||
| 291 | Readonly::Hash my %DISPATCH => ( | |||||
| 292 | SongInfo => \&_handle_song_info, | |||||
| 293 | PgSetup => \&_handle_pg_setup, | |||||
| 294 | PgMargins => \&_handle_pg_setup, | |||||
| 295 | Font => \&_handle_font, | |||||
| 296 | AddStaff => \&_handle_add_staff, | |||||
| 297 | StaffProperties => \&_handle_staff_properties, | |||||
| 298 | StaffInstrument => \&_handle_staff_instrument, | |||||
| 299 | Clef => \&_handle_clef, | |||||
| 300 | Key => \&_handle_key, | |||||
| 301 | TimeSig => \&_handle_time_sig, | |||||
| 302 | Tempo => \&_handle_tempo, | |||||
| 303 | Note => \&_handle_note, | |||||
| 304 | Rest => \&_handle_rest, | |||||
| 305 | Chord => \&_handle_chord, | |||||
| 306 | Bar => \&_handle_bar, | |||||
| 307 | Dynamic => \&_handle_dynamic, | |||||
| 308 | DynVariance => \&_handle_dyn_variance, | |||||
| 309 | Text => \&_handle_text, | |||||
| 310 | Lyric => \&_handle_lyric, | |||||
| 311 | Tie => \&_handle_tie, | |||||
| 312 | Slur => \&_handle_slur, | |||||
| 313 | Beam => \&_handle_beam, | |||||
| 314 | Tuplet => \&_handle_tuplet, | |||||
| 315 | Instrument => \&_handle_instrument_change, | |||||
| 316 | FlowControl => \&_handle_flow_control, | |||||
| 317 | TempoVariance => \&_handle_tempo_variance, | |||||
| 318 | Spacer => \&_handle_spacer, | |||||
| 319 | RestChord => \&_handle_rest_chord, | |||||
| 320 | ); | |||||
| 321 | ||||||
| 322 | # --------------------------------------------------------------------------- | |||||
| 323 | # Private: record dispatcher | |||||
| 324 | # --------------------------------------------------------------------------- | |||||
| 325 | ||||||
| 326 | # Strategy: extract the record type (first field after the leading |), then | |||||
| 327 | # call a dedicated _handle_* method. Unknown types produce UnsupportedEvent | |||||
| 328 | # records and a warning rather than aborting conversion. | |||||
| 329 | ||||||
| 330 | sub _dispatch_record { | |||||
| 331 | 1217968 | 390433 | my ($self, $line) = @_; | |||
| 332 | ||||||
| 333 | 1217968 | 400269 | my $fields = $self->_tokenise_record($line); | |||
| 334 | 1217968 | 727699 | return unless defined $fields && @$fields; | |||
| 335 | ||||||
| 336 | 1217968 | 358689 | my $type = shift @$fields; | |||
| 337 | ||||||
| 338 | 1217968 | 635797 | if (exists $DISPATCH{$type}) { | |||
| 339 | 1217932 | 1886414 | $DISPATCH{$type}->($self, $fields); | |||
| 340 | } else { | |||||
| 341 | 36 | 160 | my $staff = $self->{_score}->current_staff; | |||
| 342 | 36 | 65 | if (defined $staff) { | |||
| 343 | # Unknown type within a staff: record and warn. | |||||
| 344 | 5 | 8 | $self->_warn_unknown($type); | |||
| 345 | 5 | 12888 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 346 | type => 'UnsupportedEvent', | |||||
| 347 | nwc_label => $type, | |||||
| 348 | data => { raw => join('|', $type, @$fields) }, | |||||
| 349 | )); | |||||
| 350 | } | |||||
| 351 | # else: score-level record (Editor, Font, PgMargins, ...) before any | |||||
| 352 | # AddStaff -- silently skip; these are not musical events. | |||||
| 353 | } | |||||
| 354 | } | |||||
| 355 | ||||||
| 356 | # --------------------------------------------------------------------------- | |||||
| 357 | # Private: tokeniser | |||||
| 358 | # --------------------------------------------------------------------------- | |||||
| 359 | ||||||
| 360 | # Strategy: walk character by character to handle quoted strings and escaped | |||||
| 361 | # characters correctly. A naive split('|') would break on quoted values | |||||
| 362 | # that contain '|' or ':'. | |||||
| 363 | ||||||
| 364 | sub _tokenise_record { | |||||
| 365 | 1217971 | 353878 | my ($self, $line) = @_; | |||
| 366 | ||||||
| 367 | 1217971 | 301353 | my @fields; | |||
| 368 | 1217971 | 309055 | my $pos = 0; | |||
| 369 | 1217971 | 338421 | my $len = length $line; | |||
| 370 | ||||||
| 371 | # Skip leading '|' | |||||
| 372 | 1217971 | 509729 | $pos++ if substr($line, 0, 1) eq '|'; | |||
| 373 | ||||||
| 374 | 1217971 | 319209 | my $current = ''; | |||
| 375 | 1217971 | 322480 | my $in_quote = 0; | |||
| 376 | ||||||
| 377 | 1217971 | 413320 | while ($pos < $len) { | |||
| 378 | 9609848 | 2697297 | my $ch = substr($line, $pos, 1); | |||
| 379 | ||||||
| 380 | 9609848 | 2720478 | if ($in_quote) { | |||
| 381 | 25633 | 11038 | if ($ch eq '"') { | |||
| 382 | 1236 | 363 | $in_quote = 0; | |||
| 383 | } elsif ($ch eq '\\' && $pos + 1 < $len) { | |||||
| 384 | # Escape sequence: consume next char literally | |||||
| 385 | 5 | 2 | $pos++; | |||
| 386 | 5 | 2 | $current .= substr($line, $pos, 1); | |||
| 387 | } else { | |||||
| 388 | 24392 | 6584 | $current .= $ch; | |||
| 389 | } | |||||
| 390 | } else { | |||||
| 391 | 9584215 | 3244307 | if ($ch eq '"') { | |||
| 392 | 1236 | 356 | $in_quote = 1; | |||
| 393 | } elsif ($ch eq '|') { | |||||
| 394 | 1402447 | 460298 | push @fields, $current; | |||
| 395 | 1402447 | 401127 | $current = ''; | |||
| 396 | } else { | |||||
| 397 | 8180532 | 2080449 | $current .= $ch; | |||
| 398 | } | |||||
| 399 | } | |||||
| 400 | 9609848 | 3215603 | $pos++; | |||
| 401 | } | |||||
| 402 | ||||||
| 403 | 1217971 | 382564 | push @fields, $current; | |||
| 404 | ||||||
| 405 | 1217971 | 413644 | return \@fields; | |||
| 406 | } | |||||
| 407 | ||||||
| 408 | # Parse a field list (already tokenised) into a key => value hashref. | |||||
| 409 | # Fields have the form "Key:Value" or just "Value" for positional fields. | |||||
| 410 | sub _fields_to_hash { | |||||
| 411 | 1217904 | 374229 | my ($self, $fields_ref) = @_; | |||
| 412 | 1217904 | 306758 | my %h; | |||
| 413 | 1217904 | 360557 | for my $field (@$fields_ref) { | |||
| 414 | 1402320 | 537761 | if ($field =~ /\A([^:]+):(.*)\z/) { | |||
| 415 | 399070 | 198606 | $h{$1} = $2; | |||
| 416 | } else { | |||||
| 417 | 1003250 | 364253 | $h{_positional} = $field; | |||
| 418 | } | |||||
| 419 | } | |||||
| 420 | 1217904 | 365456 | return \%h; | |||
| 421 | } | |||||
| 422 | ||||||
| 423 | # --------------------------------------------------------------------------- | |||||
| 424 | # Private: metadata handlers | |||||
| 425 | # --------------------------------------------------------------------------- | |||||
| 426 | ||||||
| 427 | sub _handle_font { | |||||
| 428 | 360 | 512 | my ($self, $fields) = @_; | |||
| 429 | 360 | 173 | my $h = $self->_fields_to_hash($fields); | |||
| 430 | 360 | 1146 | push @{ $self->{_score}{_fonts} }, { | |||
| 431 | style => $h->{Style} // '', | |||||
| 432 | typeface => $h->{Typeface} // '', | |||||
| 433 | size => defined $h->{Size} ? $h->{Size} + 0 : 0, | |||||
| 434 | bold => ($h->{Bold} // 'N') eq 'Y' ? 1 : 0, | |||||
| 435 | 360 | 111 | italic => ($h->{Italic} // 'N') eq 'Y' ? 1 : 0, | |||
| 436 | }; | |||||
| 437 | } | |||||
| 438 | ||||||
| 439 | sub _handle_song_info { | |||||
| 440 | 98 | 254 | my ($self, $fields) = @_; | |||
| 441 | 98 | 102 | my $h = $self->_fields_to_hash($fields); | |||
| 442 | 98 | 102 | for my $key (qw(Title Author Lyricist Copyright Copyright1 Copyright2 Comments)) { | |||
| 443 | $self->{_score}->set_metadata_field($key, $h->{$key}) | |||||
| 444 | 686 | 617 | if exists $h->{$key}; | |||
| 445 | } | |||||
| 446 | } | |||||
| 447 | ||||||
| 448 | sub _handle_pg_setup { | |||||
| 449 | 73 | 151 | my ($self, $fields) = @_; | |||
| 450 | 73 | 53 | my $h = $self->_fields_to_hash($fields); | |||
| 451 | 73 | 86 | my $ps = $self->{_score}->page_setup; | |||
| 452 | 73 | 362 | %$ps = (%$ps, %$h); | |||
| 453 | } | |||||
| 454 | ||||||
| 455 | sub _handle_add_staff { | |||||
| 456 | 379 | 804 | my ($self, $fields) = @_; | |||
| 457 | 379 | 272 | my $h = $self->_fields_to_hash($fields); | |||
| 458 | my $staff = Music::NWC2MusicXML::Staff->new( | |||||
| 459 | name => $h->{Name} // 'Staff', | |||||
| 460 | 379 | 987 | group => $h->{Group} // 'Standard', | |||
| 461 | ); | |||||
| 462 | 379 | 487 | $self->{_score}->add_staff($staff); | |||
| 463 | } | |||||
| 464 | ||||||
| 465 | sub _handle_staff_properties { | |||||
| 466 | 253 | 478 | my ($self, $fields) = @_; | |||
| 467 | 253 | 171 | my $h = $self->_fields_to_hash($fields); | |||
| 468 | 253 | 228 | my $staff = $self->_current_staff_or_croak('StaffProperties'); | |||
| 469 | 253 | 419 | $staff->{_visible} = ($h->{Visible} // 'Y') eq 'Y' ? 1 : 0; | |||
| 470 | 253 | 281 | $staff->{_lines} = $h->{Lines} // 5; | |||
| 471 | 253 | 178 | $staff->{_ending_bar} = $h->{EndingBar}; | |||
| 472 | 253 | 239 | $staff->{_channel} = $h->{Channel} + 0 if defined $h->{Channel}; | |||
| 473 | 253 | 306 | $staff->{_with_next_staff} = $h->{WithNextStaff} if defined $h->{WithNextStaff}; | |||
| 474 | 253 | 258 | $staff->{_volume} = $h->{Volume} + 0 if defined $h->{Volume}; | |||
| 475 | 253 | 258 | $staff->{_stereo_pan} = $h->{StereoPan} + 0 if defined $h->{StereoPan}; | |||
| 476 | 253 | 622 | $staff->{_muted} = ($h->{Muted} // 'N') eq 'Y' ? 1 : 0; | |||
| 477 | } | |||||
| 478 | ||||||
| 479 | sub _handle_staff_instrument { | |||||
| 480 | 135 | 283 | my ($self, $fields) = @_; | |||
| 481 | 135 | 92 | my $h = $self->_fields_to_hash($fields); | |||
| 482 | 135 | 102 | my $staff = $self->_current_staff_or_croak('StaffInstrument'); | |||
| 483 | $staff->{_instrument} = { | |||||
| 484 | name => $h->{Name} // '', | |||||
| 485 | patch => $h->{Patch} // 0, | |||||
| 486 | 135 | 409 | trans => $h->{Trans} // 0, | |||
| 487 | }; | |||||
| 488 | 135 | 237 | if (defined $h->{DynVel} && length $h->{DynVel}) { | |||
| 489 | 120 | 190 | my @keys = qw(ppp pp p mp mf f ff fff); | |||
| 490 | 120 | 190 | my @vels = split /,/, $h->{DynVel}; | |||
| 491 | 120 | 116 | if (@vels == @keys) { | |||
| 492 | 120 | 72 | my %vel_map; | |||
| 493 | 120 960 | 69 760 | @vel_map{@keys} = map { $_ + 0 } @vels; | |||
| 494 | 120 | 282 | $staff->{_dyn_vel} = \%vel_map; | |||
| 495 | } | |||||
| 496 | } | |||||
| 497 | } | |||||
| 498 | ||||||
| 499 | # --------------------------------------------------------------------------- | |||||
| 500 | # Private: initial-state handlers (clef/key/time -- before events begin) | |||||
| 501 | # --------------------------------------------------------------------------- | |||||
| 502 | ||||||
| 503 | sub _handle_clef { | |||||
| 504 | 404 | 954 | my ($self, $fields) = @_; | |||
| 505 | 404 | 349 | my $h = $self->_fields_to_hash($fields); | |||
| 506 | 404 | 457 | my $type = $h->{Type} // 'Treble'; | |||
| 507 | ||||||
| 508 | 404 | 414 | unless (exists $VALID_CLEFS{$type}) { | |||
| 509 | 0 | 0 | carp _fmt_msg('warn_bad_value', 'Clef.Type', $type, $self->{_line_no}); | |||
| 510 | } | |||||
| 511 | ||||||
| 512 | 404 | 1176 | my $staff = $self->_current_staff_or_croak('Clef'); | |||
| 513 | 404 | 388 | if (!$staff->has_notes) { | |||
| 514 | 190 | 241 | $staff->set_initial_clef($type); | |||
| 515 | } else { | |||||
| 516 | 214 | 862 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 517 | type => 'Clef', | |||||
| 518 | data => { nwc_clef => $type }, | |||||
| 519 | )); | |||||
| 520 | } | |||||
| 521 | } | |||||
| 522 | ||||||
| 523 | sub _handle_key { | |||||
| 524 | 776 | 1571 | my ($self, $fields) = @_; | |||
| 525 | 776 | 491 | my $h = $self->_fields_to_hash($fields); | |||
| 526 | 776 | 668 | my $sig = $h->{Signature} // 'C'; | |||
| 527 | ||||||
| 528 | my $key_data = { | |||||
| 529 | signature => $sig, | |||||
| 530 | 776 | 1065 | tonic => $h->{Tonic} // '', | |||
| 531 | fifths => _fifths_from_signature($sig), | |||||
| 532 | }; | |||||
| 533 | ||||||
| 534 | 776 | 547 | my $staff = $self->_current_staff_or_croak('Key'); | |||
| 535 | 776 | 636 | if (!$staff->has_notes) { | |||
| 536 | 175 | 191 | $staff->set_initial_key($key_data); | |||
| 537 | } else { | |||||
| 538 | 601 | 1818 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 539 | type => 'Key', | |||||
| 540 | data => $key_data, | |||||
| 541 | )); | |||||
| 542 | } | |||||
| 543 | } | |||||
| 544 | ||||||
| 545 | sub _handle_time_sig { | |||||
| 546 | 2577 | 3811 | my ($self, $fields) = @_; | |||
| 547 | 2577 | 1243 | my $h = $self->_fields_to_hash($fields); | |||
| 548 | 2577 | 1545 | my $sig = $h->{Signature} // '4/4'; | |||
| 549 | ||||||
| 550 | 2577 | 2794 | my ($beats, $beat_type) = $sig =~ m{\A(\d+)/(\d+)\z}; | |||
| 551 | 2577 | 2223 | unless (defined $beats && defined $beat_type) { | |||
| 552 | 4 | 7 | carp _fmt_msg('warn_bad_value', 'TimeSig.Signature', $sig, $self->{_line_no}); | |||
| 553 | 4 | 592 | ($beats, $beat_type) = (4, 4); | |||
| 554 | } | |||||
| 555 | ||||||
| 556 | 2577 | 2056 | my $ts_data = { beats => $beats + 0, beat_type => $beat_type + 0 }; | |||
| 557 | ||||||
| 558 | 2577 | 1217 | my $staff = $self->_current_staff_or_croak('TimeSig'); | |||
| 559 | 2577 | 1622 | if (!$staff->has_notes) { | |||
| 560 | 177 | 177 | $staff->set_initial_timesig($ts_data); | |||
| 561 | } else { | |||||
| 562 | 2400 | 5584 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 563 | type => 'TimeSig', | |||||
| 564 | data => $ts_data, | |||||
| 565 | )); | |||||
| 566 | } | |||||
| 567 | } | |||||
| 568 | ||||||
| 569 | # --------------------------------------------------------------------------- | |||||
| 570 | # Private: musical event handlers | |||||
| 571 | # --------------------------------------------------------------------------- | |||||
| 572 | ||||||
| 573 | sub _handle_tempo { | |||||
| 574 | 169 | 333 | my ($self, $fields) = @_; | |||
| 575 | 169 | 114 | my $h = $self->_fields_to_hash($fields); | |||
| 576 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 577 | type => 'Tempo', | |||||
| 578 | data => { | |||||
| 579 | bpm => $h->{Tempo} // 120, | |||||
| 580 | 169 | 520 | base => $h->{Base} // 'Quarter', | |||
| 581 | }, | |||||
| 582 | )); | |||||
| 583 | } | |||||
| 584 | ||||||
| 585 | sub _handle_note { | |||||
| 586 | 109632 | 146910 | my ($self, $fields) = @_; | |||
| 587 | 109632 | 44260 | my $h = $self->_fields_to_hash($fields); | |||
| 588 | ||||||
| 589 | 109632 | 55866 | my ($base_dur, $dots, $triplet, $artic, $is_grace) = _parse_dur_tokens($h->{Dur} // '4th'); | |||
| 590 | 109632 | 56085 | my $rational = Music::NWC2MusicXML::Event->rational_from_nwc_duration($base_dur, $dots); | |||
| 591 | ||||||
| 592 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 593 | type => 'Note', | |||||
| 594 | duration => $rational, | |||||
| 595 | data => { | |||||
| 596 | nwc_pos => $h->{Pos} // '0', | |||||
| 597 | base_dur => $base_dur, | |||||
| 598 | dots => $dots, | |||||
| 599 | triplet => $triplet, | |||||
| 600 | articulations => $artic, | |||||
| 601 | is_grace => $is_grace, | |||||
| 602 | 109632 | 76056 | opts => _parse_opts($h->{Opts}), | |||
| 603 | }, | |||||
| 604 | )); | |||||
| 605 | } | |||||
| 606 | ||||||
| 607 | sub _handle_rest { | |||||
| 608 | 24270 | 32659 | my ($self, $fields) = @_; | |||
| 609 | 24270 | 9637 | my $h = $self->_fields_to_hash($fields); | |||
| 610 | ||||||
| 611 | 24270 | 12601 | my ($base_dur, $dots) = _parse_dur_tokens($h->{Dur} // '4th'); | |||
| 612 | 24270 | 14074 | my $rational = Music::NWC2MusicXML::Event->rational_from_nwc_duration($base_dur, $dots); | |||
| 613 | ||||||
| 614 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 615 | type => 'Rest', | |||||
| 616 | duration => $rational, | |||||
| 617 | data => { | |||||
| 618 | base_dur => $base_dur, | |||||
| 619 | dots => $dots, | |||||
| 620 | 24270 | 14744 | opts => _parse_opts($h->{Opts}), | |||
| 621 | }, | |||||
| 622 | )); | |||||
| 623 | } | |||||
| 624 | ||||||
| 625 | sub _handle_chord { | |||||
| 626 | 25770 | 35377 | my ($self, $fields) = @_; | |||
| 627 | 25770 | 10496 | my $h = $self->_fields_to_hash($fields); | |||
| 628 | ||||||
| 629 | 25770 | 14095 | my ($base_dur, $dots, $triplet, $artic, $is_grace) = _parse_dur_tokens($h->{Dur} // '4th'); | |||
| 630 | 25770 | 14040 | my $rational = Music::NWC2MusicXML::Event->rational_from_nwc_duration($base_dur, $dots); | |||
| 631 | ||||||
| 632 | # Pos field contains a comma-separated list of position strings. | |||||
| 633 | # Each entry: optional accidental prefix (#/b/n/##/bb/x) + signed integer + optional ^ (tie) | |||||
| 634 | 25770 | 16261 | my @positions = split /,/, ($h->{Pos} // '0'); | |||
| 635 | ||||||
| 636 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 637 | type => 'Chord', | |||||
| 638 | duration => $rational, | |||||
| 639 | data => { | |||||
| 640 | nwc_positions => \@positions, | |||||
| 641 | base_dur => $base_dur, | |||||
| 642 | dots => $dots, | |||||
| 643 | triplet => $triplet, | |||||
| 644 | articulations => $artic, | |||||
| 645 | is_grace => $is_grace, | |||||
| 646 | 25770 | 16318 | opts => _parse_opts($h->{Opts}), | |||
| 647 | }, | |||||
| 648 | )); | |||||
| 649 | } | |||||
| 650 | ||||||
| 651 | sub _handle_bar { | |||||
| 652 | 1049820 | 1311814 | my ($self, $fields) = @_; | |||
| 653 | 1049820 | 364105 | my $h = $self->_fields_to_hash($fields); | |||
| 654 | # NWC bar records carry an optional Style named field; plain |Bar| has none. | |||||
| 655 | 1049820 | 668095 | my $style = $h->{Style} // $h->{_positional} // 'normal'; | |||
| 656 | 1049820 | 557248 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 657 | type => 'Bar', | |||||
| 658 | data => { style => $style }, | |||||
| 659 | )); | |||||
| 660 | } | |||||
| 661 | ||||||
| 662 | # --------------------------------------------------------------------------- | |||||
| 663 | # Private: duration / options parsing helpers | |||||
| 664 | # --------------------------------------------------------------------------- | |||||
| 665 | ||||||
| 666 | sub _parse_dur_tokens { | |||||
| 667 | 159678 | 58794 | my ($dur_str) = @_; | |||
| 668 | 159678 | 75041 | my @tokens = split /,/, ($dur_str // '4th'); | |||
| 669 | 159678 | 68142 | my $base = shift(@tokens) // '4th'; | |||
| 670 | 159678 | 60155 | my ($dots, $triplet, $is_grace) = (0, undef, 0); | |||
| 671 | 159678 | 43497 | my @artic; | |||
| 672 | ||||||
| 673 | 159678 | 50377 | for my $tok (@tokens) { | |||
| 674 | 43727 4262 | 24524 1646 | if ($tok eq 'Dotted') { $dots = 1 } | |||
| 675 | 1 | 1 | elsif ($tok eq 'DblDotted') { $dots = 2 } | |||
| 676 | 542 | 366 | elsif ($tok =~ /\ATriplet(?:=(.+))?\z/) { $triplet = $1 // 'Middle' } | |||
| 677 | 0 | 0 | elsif ($tok eq 'Grace') { $is_grace = 1 } | |||
| 678 | 38922 | 16625 | else { push @artic, $tok } | |||
| 679 | } | |||||
| 680 | ||||||
| 681 | 159678 | 90145 | return ($base, $dots, $triplet, \@artic, $is_grace); | |||
| 682 | } | |||||
| 683 | ||||||
| 684 | sub _parse_opts { | |||||
| 685 | 159677 | 61100 | my ($opts_str) = @_; | |||
| 686 | 159677 | 136747 | return {} unless defined $opts_str && length $opts_str; | |||
| 687 | 82235 | 22660 | my %opts; | |||
| 688 | 82235 | 36017 | for my $opt (split /,/, $opts_str) { | |||
| 689 | 159817 134283 | 81330 73369 | if ($opt =~ /\A(\w+)=(.*)\z/) { $opts{$1} = $2 } | |||
| 690 | 25534 | 10556 | else { $opts{$opt} = 1 } | |||
| 691 | } | |||||
| 692 | 82235 | 92417 | return \%opts; | |||
| 693 | } | |||||
| 694 | ||||||
| 695 | sub _handle_dynamic { | |||||
| 696 | 3002 | 4521 | my ($self, $fields) = @_; | |||
| 697 | 3002 | 1337 | my $h = $self->_fields_to_hash($fields); | |||
| 698 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 699 | type => 'Dynamic', | |||||
| 700 | data => { | |||||
| 701 | marking => $h->{Style} // $h->{_positional} // '', | |||||
| 702 | 3002 | 4681 | placement => $h->{Placement} // '', | |||
| 703 | }, | |||||
| 704 | )); | |||||
| 705 | } | |||||
| 706 | ||||||
| 707 | sub _handle_dyn_variance { | |||||
| 708 | 3 | 6 | my ($self, $fields) = @_; | |||
| 709 | 3 | 1 | my $h = $self->_fields_to_hash($fields); | |||
| 710 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 711 | type => 'DynVariance', | |||||
| 712 | data => { | |||||
| 713 | style => $h->{Style} // $h->{_positional} // '', | |||||
| 714 | 3 | 6 | placement => $h->{Placement} // '', | |||
| 715 | }, | |||||
| 716 | )); | |||||
| 717 | } | |||||
| 718 | ||||||
| 719 | sub _handle_text { | |||||
| 720 | 0 | 0 | my ($self, $fields) = @_; | |||
| 721 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 722 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 723 | type => 'Text', | |||||
| 724 | 0 | 0 | data => { text => $h->{Text} // '', placement => $h->{Placement} // '' }, | |||
| 725 | )); | |||||
| 726 | } | |||||
| 727 | ||||||
| 728 | sub _handle_lyric { | |||||
| 729 | 0 | 0 | my ($self, $fields) = @_; | |||
| 730 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 731 | 0 | 0 | my $text = $h->{Text} // ''; | |||
| 732 | # Syllabic type encoded by leading/trailing hyphens: strip them, infer type. | |||||
| 733 | 0 | 0 | my $starts_h = ($text =~ s/\A-//); | |||
| 734 | 0 | 0 | my $ends_h = ($text =~ s/-\z//); | |||
| 735 | 0 | 0 | my $syllabic = $starts_h && $ends_h ? 'middle' | |||
| 736 | : $starts_h ? 'end' | |||||
| 737 | : $ends_h ? 'begin' | |||||
| 738 | : 'single'; | |||||
| 739 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 740 | type => 'Lyric', | |||||
| 741 | 0 | 0 | data => { text => $text, verse => $h->{Verse} // 1, syllabic => $syllabic }, | |||
| 742 | )); | |||||
| 743 | } | |||||
| 744 | ||||||
| 745 | sub _handle_tie { | |||||
| 746 | 0 | 0 | my ($self, $fields) = @_; | |||
| 747 | 0 | 0 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 748 | type => 'Tie', | |||||
| 749 | data => {}, | |||||
| 750 | )); | |||||
| 751 | } | |||||
| 752 | ||||||
| 753 | sub _handle_slur { | |||||
| 754 | 0 | 0 | my ($self, $fields) = @_; | |||
| 755 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 756 | 0 | 0 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 757 | type => 'Slur', | |||||
| 758 | data => { _raw_fields => $h }, | |||||
| 759 | )); | |||||
| 760 | } | |||||
| 761 | ||||||
| 762 | sub _handle_beam { | |||||
| 763 | 0 | 0 | my ($self, $fields) = @_; | |||
| 764 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 765 | 0 | 0 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 766 | type => 'Beam', | |||||
| 767 | data => { _raw_fields => $h }, | |||||
| 768 | )); | |||||
| 769 | } | |||||
| 770 | ||||||
| 771 | sub _handle_tuplet { | |||||
| 772 | 0 | 0 | my ($self, $fields) = @_; | |||
| 773 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 774 | 0 | 0 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 775 | type => 'Tuplet', | |||||
| 776 | data => { _raw_fields => $h }, | |||||
| 777 | )); | |||||
| 778 | } | |||||
| 779 | ||||||
| 780 | sub _handle_instrument_change { | |||||
| 781 | 0 | 0 | my ($self, $fields) = @_; | |||
| 782 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 783 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 784 | type => 'Instrument', | |||||
| 785 | 0 | 0 | data => { name => $h->{Name} // '', patch => $h->{Patch} // 0 }, | |||
| 786 | )); | |||||
| 787 | } | |||||
| 788 | ||||||
| 789 | sub _handle_flow_control { | |||||
| 790 | 0 | 0 | my ($self, $fields) = @_; | |||
| 791 | 0 | 0 | my $h = $self->_fields_to_hash($fields); | |||
| 792 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||||
| 793 | type => 'FlowControl', | |||||
| 794 | 0 | 0 | data => { directive => $h->{_positional} // $h->{Style} // '', extra => $h }, | |||
| 795 | )); | |||||
| 796 | } | |||||
| 797 | ||||||
| 798 | sub _handle_tempo_variance { | |||||
| 799 | 121 | 297 | my ($self, $fields) = @_; | |||
| 800 | 121 | 98 | my $h = $self->_fields_to_hash($fields); | |||
| 801 | ||||||
| 802 | 121 | 171 | my $style = $h->{Style} // ''; | |||
| 803 | 121 | 122 | my $pos = $h->{Pos} // 0; | |||
| 804 | 121 | 224 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 805 | type => 'TempoVariance', | |||||
| 806 | data => { | |||||
| 807 | style => $style, | |||||
| 808 | placement => ($pos >= 0 ? 'above' : 'below'), | |||||
| 809 | }, | |||||
| 810 | )); | |||||
| 811 | } | |||||
| 812 | ||||||
| 813 | sub _handle_spacer { | |||||
| 814 | # Spacer is a graphical-layout hint with no MusicXML equivalent. | |||||
| 815 | # Per the preservation principle (musical meaning > graphical appearance) | |||||
| 816 | # it is silently discarded; no event, no warning. | |||||
| 817 | 30 | 91 | return; | |||
| 818 | } | |||||
| 819 | ||||||
| 820 | sub _handle_rest_chord { | |||||
| 821 | 60 | 123 | my ($self, $fields) = @_; | |||
| 822 | 60 | 59 | my $h = $self->_fields_to_hash($fields); | |||
| 823 | ||||||
| 824 | # RestChord is a multi-voice construct: one layer rests while another | |||||
| 825 | # plays. Full handling requires voice assignment (Phase 4). | |||||
| 826 | # Stored as UnsupportedEvent so the raw field data is preserved for | |||||
| 827 | # diagnostics and future implementation. | |||||
| 828 | 60 | 90 | $self->_append_event(Music::NWC2MusicXML::Event->new( | |||
| 829 | type => 'UnsupportedEvent', | |||||
| 830 | nwc_label => 'RestChord', | |||||
| 831 | data => { _raw_fields => $h }, | |||||
| 832 | )); | |||||
| 833 | } | |||||
| 834 | ||||||
| 835 | # --------------------------------------------------------------------------- | |||||
| 836 | # Private: helpers | |||||
| 837 | # --------------------------------------------------------------------------- | |||||
| 838 | ||||||
| 839 | sub _append_event { | |||||
| 840 | 1216067 | 369786 | my ($self, $event) = @_; | |||
| 841 | 1216067 | 443361 | my $staff = $self->_current_staff_or_croak($event->type); | |||
| 842 | 1216066 | 486309 | $staff->add_event($event); | |||
| 843 | } | |||||
| 844 | ||||||
| 845 | sub _current_staff_or_croak { | |||||
| 846 | 1220212 | 386843 | my ($self, $context) = @_; | |||
| 847 | 1220212 | 470157 | my $staff = $self->{_score}->current_staff; | |||
| 848 | 1220212 | 432702 | croak _fmt_msg('error_no_staff', $context) unless defined $staff; | |||
| 849 | 1220211 | 346540 | return $staff; | |||
| 850 | } | |||||
| 851 | ||||||
| 852 | sub _warn_unknown { | |||||
| 853 | 5 | 5 | my ($self, $type) = @_; | |||
| 854 | 5 | 12 | carp _fmt_msg('warn_unknown_record', $type, $self->{_line_no}); | |||
| 855 | } | |||||
| 856 | ||||||
| 857 | sub _fifths_from_signature { | |||||
| 858 | 794 | 6566 | my ($sig) = @_; | |||
| 859 | 794 | 1126 | return 0 unless defined $sig && length $sig; | |||
| 860 | 790 | 757 | return 0 if $sig eq $KEY_SIG_NATURAL; | |||
| 861 | ||||||
| 862 | # Signature is a comma-separated list of accidentals in circle-of-fifths order. | |||||
| 863 | # Each item ending in '#' is a sharp; each item ending in 'b' (after a letter) is a flat. | |||||
| 864 | 643 | 518 | my @acc = split /,/, $sig; | |||
| 865 | 643 | 489 | return 0 unless @acc; | |||
| 866 | ||||||
| 867 | 643 | 1041 | if (index($acc[0], '#') >= 0) { | |||
| 868 | 247 | 382 | return scalar @acc; # positive = sharps | |||
| 869 | } elsif (substr($acc[0], -1, 1) eq 'b') { | |||||
| 870 | 367 | 657 | return -(scalar @acc); # negative = flats | |||
| 871 | } | |||||
| 872 | 29 | 37 | return 0; | |||
| 873 | } | |||||
| 874 | ||||||
| 875 | sub _fmt_msg { | |||||
| 876 | 36 | 26 | my ($key, @args) = @_; | |||
| 877 | 36 | 50 | croak "Unknown message key: $key" unless exists $MESSAGES{$key}; | |||
| 878 | 36 | 128 | return sprintf $MESSAGES{$key}, @args; | |||
| 879 | } | |||||
| 880 | ||||||
| 881 | 1; | |||||
| 882 | ||||||