view release on metacpan or  search on metacpan

lib/ChordPro/Song.pm  view on Meta::CPAN

	ChordPro::Chords::set_parser($target);
	my $p = ChordPro::Chords::get_parser;
	$xcmov = $p->movable;
	if ( $target ne $p->{system} ) {
	    ::dump(ChordPro::Chords::Parser->parsers);
	    warn("OOPS parser mixup, $target <> ",
		ChordPro::Chords::get_parser->{system})
	}
	ChordPro::Chords::set_parser($self->{system});
    }
    else {
	$target = $self->{system};
    }

    upd_config();
    $self->{source}     = { file => $diag->{file}, line => 1 + $$linecnt };
    $self->{system}     = $target // $config->{notes}->{system};
    $self->{config}     = $config;
    $self->{meta}       = $meta if $meta;
    $self->{chordsinfo} = {};
    $target //= $self->{system};

    # Preprocessor.
    my $prep = make_preprocessor( $config->{parser}->{preprocess} );

    # Pre-fill meta data, if any. TODO? ALREADY DONE?
    if ( $options->{meta} ) {
	while ( my ($k, $v ) = each( %{ $options->{meta} } ) ) {
	    $self->{meta}->{$k} = [ $v ];
	}
    }
    $self->{meta}->{"chordpro.songsource"} = $diag->{file}
      unless $::running_under_test;

    # Build regexp to split out chords.
    if ( $config->{settings}->{memorize} ) {
	$re_chords = qr/(\[.*?\]|\^)/;
    }
    else {
	$re_chords = qr/(\[.*?\])/;
    }

    my $skipcnt = 0;
    while ( @$lines ) {
	if ( $skipcnt ) {
	    $skipcnt--;
	}
	else {
	    $diag->{line} = ++$$linecnt;
	}

	$_ = shift(@$lines);
	while ( /\\\Z/ && @$lines ) {
	    chop;
	    my $cont = shift(@$lines);
	    $$linecnt++;
	    $cont =~ s/^\s+//;
	    $_ .= $cont;
	}

	# Uncomment this to allow \uDXXX\uDYYY (surrogate) escapes.
	s/ \\u(d[89ab][[:xdigit:]]{2})\\u(d[cdef][[:xdigit:]]{2})
	 / pack('U*', 0x10000 + (hex($1) - 0xD800) * 0x400 + (hex($2) - 0xDC00) )
	   /igex;

	# Uncomment this to allow \uXXXX escapes.
	s/\\u([0-9a-f]{4})/chr(hex("0x$1"))/ige;
	# Uncomment this to allow \u{XX...} escapes.
	s/\\u\{([0-9a-f]+)\}/chr(hex("0x$1"))/ige;

	$diag->{orig} = $_;
	# Get rid of TABs.
	s/\t/ /g;

	if ( $config->{debug}->{echo} ) {
	    warn(sprintf("==[%3d]=> %s\n", $diag->{line}, $diag->{orig} ) );
	}

	for my $pp ( "all", "env-$in_context" ) {
	    next if $pp eq "env-$in_context"
	      && /^\s*\{(\w+)\}\s*$/
	      && $self->parse_directive($1)->{name} eq "end_of_$in_context";
	    if ( $prep->{$pp} ) {
		$config->{debug}->{pp} && warn("PRE:  ", $_, "\n");
		$prep->{$pp}->($_);
		$config->{debug}->{pp} && warn("POST: ", $_, "\n");
		if ( /\n/ ) {
		    my @a = split( /\n/, $_ );
		    $_ = shift(@a);
		    unshift( @$lines, @a );
		    $skipcnt += @a;
		}
	    }
	}

	if ( $skip_context ) {
	    if ( /^\s*\{(\w+)\}\s*$/ ) {
		my $dir = $self->parse_directive($1);
		if ( $dir->{name} eq "end_of_$in_context" ) {
		    $in_context = $def_context;
		    $skip_context = 0;
		}
	    }
	    next;
	}

	if ( /^\s*\{((?:new_song|ns)\b.*)\}\s*$/ ) {
	    if ( $self->{body} ) {
		unshift( @$lines, $_ );
		$$linecnt--;
		last;
	    }
	    my $dir = $self->parse_directive($1);
	    next unless my $kv = parse_kv($dir->{arg}//"");
	    if ( defined $kv->{toc} ) {
		$self->{meta}->{_TOC} = [ $kv->{toc} ];
	    }
	    if ( $kv->{forceifempty} ) {
		push( @{ $self->{body} },
		      { type => "set",
			name => "forceifempty",
			value => $kv->{forceifempty} } );
	    }
	    next;
	}

	if ( /^#/ ) {