view release on metacpan or  search on metacpan

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

			  if $config->{debug}->{images};
		    }
		}

		# Move to assets.
		$self->{assets}->{$id} =
		  { type      => "image",
		    subtype   => "delegate",
		    delegate  => "Grille",
		    handler   => "grille2xo",
		    opts      => $opts,
		    line      => $grille[0]{line},
		    data      => \@grille,
		    context   => $in_context,
		  };
		if ( $def ) {
		    my $label = delete $a->{label};
		    do_warn("Label \"$label\" ignored on non-displaying $in_context section\n")
		      if $label;
		}
		else {
		    my $label = delete $opts->{label};
		    $self->add( type => "set",
				name => "label",
				value => $label )
		      if $label && $label ne "";
		    $self->add( type => "image",
				opts => $opts,
				id => $id );
		    if ( $opts->{label} ) {
			push( @labels, $opts->{label} )
			  unless $in_context eq "chorus"
			  && !$config->{settings}->{choruslabels};
		    }
		}
	    }
	}
	else {
	    $self->add( type => "set",
			name => "context",
			value => $def_context );
	}
	$in_context = $def_context;
	undef $memchords;
	return 1;
    }

    # Metadata extensions (legacy). Should use meta instead.
    # Only accept the list from config.
    if ( any { $_ eq $dir } @{ $config->{metadata}->{keys} } ) {
	return $self->dir_meta( "meta", "$dir $arg" );
    }

    # Formatting. {chordsize XX} and such.
    if ( $dir =~ m/ ^( $propitems_re )
		     ( font | size | colou?r )
		     $/x ) {
	my $item = $1;
	my $prop = $2;

	$self->propset( $item, $prop, $arg );

	# Derived props.
	$self->propset( "chorus", $prop, $arg ) if $item eq "text";

	# ::dump( { %propstack, line => $diag->{line} } );
	return 1;
    }
    # More private hacks.
    if ( !$options->{reference} && $d =~ /^([-+])([-\w.]+)$/i ) {
	if ( $2 eq "dumpmeta" ) {
	    warn(::dump($self->{meta}));
	}
	$self->add( type => "set",
		    name => $2,
		    value => $1 eq "+" ? 1 : 0,
		  );
	return 1;
    }

    if ( !$options->{reference} && $dir =~ /^\+([-\w.]+(?:\.[<>])?)$/ ) {
	$self->add( type => "set",
		    name => $1,
		    value => $arg,
		  );

	$config->unlock;
	prpadd2cfg( $config, $1 => $arg );
	$config->lock;

	upd_config();

	return 1;
    }

    # Warn about unknowns, unless they are x_... form.
    do_warn("Unknown directive: $d\n")
      if $config->{settings}->{strict} && $d !~ /^x_/;
    return;
}

sub dir_chorus {
    my ( $self, $dir, $arg ) = @_;

    if ( $in_context ) {
	do_warn("{chorus} encountered while in $in_context context -- ignored\n");
	return 1;
    }

    # Clone the chorus so we can modify the label, if required.
    my $chorus = @chorus ? dclone(\@chorus) : [];

    if ( @$chorus && $arg && $arg ne "" ) {
	my $kv = parse_kv( $arg, "label" );
	my $label = $kv->{label};
	if ( $chorus->[0]->{type} eq "set" && $chorus->[0]->{name} eq "label" ) {
	    $chorus->[0]->{value} = $label;
	}
	elsif ( defined $label ) {
	    unshift( @$chorus,
		     { type => "set",
		       name => "label",
		       value => $label,
		       context => "chorus",

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

		my $info_s = $xpk->transpose( transpose_sound() );
		$self->{chordsinfo}->{$info_p->name} //= $info_p;
		$self->{chordsinfo}->{$info_s->name} //= $info_s;
		$m->{key_print} = [ $info_p->keyname ];
		$m->{key_sound} = [ $info_s->keyname ];
		$xpose->set_key($info_p);
		transpose_debug( "xp($arg)", $m );
	    }
	    else {
		warn("WHOAH! Key \"$key\" not found in chordsinfo");
	    }
	}
    }

    $self->add( %a, value => $xpose )
      if $no_transpose;
    return 1;
}

#### End of directive handlers ####

sub transpose_sound {
    my ( $only_print ) = @_;

    my $xp =
      # Use current.
      $xpose
      # Apply capo.
      + ( $only_print ? 0 : $capo//0 )
      # Apply global (cli, config) transpose.
      + $config->{settings}->{transpose};

    warn( "XPOSE: ",
	  "base = ", $xpose->_data_printer, " ",
	  ($only_print || !$capo) ? "" : "capo = $capo ",
	  "outer = ", $config->{settings}->{transpose}->_data_printer, " ",
	  $only_print ? "print = " : "sound = ", $xp->_data_printer,
	  "\n") if $config->{debug}->{xpose};

    return $xp;
}

sub transpose_print {
    transpose_sound(1);
}

sub transpose_debug {
    return unless $config->{debug}->{xpose};
    my ( $tag, $m ) = @_;
    my $xp = transpose_print();
    warn( "XPOSE: $tag, ",
	  "key = ",   $m->{key}->[-1],      ", ",
	  "print = ", $m->{key_print}->[0], ", ",
	  "sound = ", $m->{key_sound}->[0],
	  " [ ", join( " ", $config->{settings}->{transpose},
		       $xpose, $capo//0,
		       $xp->key ? "\@" . $xp->key->keyname : () ),
	  " ]\n" );
}

sub propset {
    my ( $self, $item, $prop, $value ) = @_;
    $prop = "color" if $prop eq "colour";
    my $name = "$item-$prop";
    $propstack{$name} //= [];

    if ( $value eq "" ) {
	my @toadd;
	# Pop current value from stack.
	if ( @{ $propstack{$name} } ) {
	    my $old = pop( @{ $propstack{$name} } );
	    # A trailing number after a font directive means there
	    # was also a size saved. Pop it.
	    if ( $prop eq "font" && $old =~ /\s(\d+(?:\.\d+)?)$/ ) {
		pop( @{ $propstack{"$item-size"} } );
		# Resetting the size must follow the font reset.
		push( @toadd, type  => "control",
		      name  => "$item-size",
		      value =>
		      @{ $propstack{"$item-size"} }
		      ? $propstack{"$item-size"}->[-1]
		      : undef );
	    }
	}
	else {
	    do_warn("No saved value for property $item$prop\n" )
	}
	# Use new current value, if any.
	if ( @{ $propstack{$name} } ) {
	    $value = $propstack{$name}->[-1]
	}
	else {
	    $value = undef;
	}
	$self->add( type  => "control",
		    name  => $name,
		    value => $value );
	$self->add( @toadd ) if @toadd;
	return 1;
    }

    if ( $prop eq "size" ) {
	unless ( $value =~ /^\d+(?:\.\d+)?\%?$/ ) {
	    do_warn("Illegal value \"$value\" for $item$prop\n");
	    return 1;
	}
    }
    if ( $prop eq "color" ) {
	my $v;
	unless ( $v = get_color($value) ) {
	    do_warn("Illegal value \"$value\" for $item$prop\n");
	    return 1;
	}
	$value = $v;
    }
    $value = $prop eq "font" ? $value : lc($value);
    $self->add( type  => "control",
		name  => $name,
		value => $value );
    push( @{ $propstack{$name} }, $value );