view release on metacpan or  search on metacpan

lib/ChordPro/Chords/Parser.pm  view on Meta::CPAN

	$info->{root_canon} = $info->{root} =
	  $p->root_canon( $info->{root_ord},
			  $dir > 0,
			  $info->{qual_canon} eq "-" );
    }
    if ( $self->{bass} && $self->{bass} ne "" && $self->{bass} !~ /^\d+$/ ) {
	$info->{bass_ord} = ( $self->{bass_ord} + $xpose ) % $p->intervals;
	$info->{bass_canon} = $info->{bass} =
	  $p->root_canon( $info->{bass_ord}, $xpose > 0 );
	$info->{bass_mod} = $dodir->( $info->{bass_ord}, $dir );
    }
    $info->{root_mod} = $dodir->( $info->{root_ord}, $dir );
    $info->{name} = $info->{name_canon} = $info->canonical;

    delete $info->{$_} for qw( copy base frets fingers keys display );

    return $info;
}

sub transcode ( $self, $xcode, $key_ord = 0 ) {
    return $self unless $xcode;
    return $self unless $self->is_chord;
    return $self if $self->{system} eq $xcode;
    my $info = $self->dclone;
#warn("_>_XCODE = $xcode, _SELF = $self->{system}, CHORD = $info->{name}");
    $info->{system} = $xcode;
    my $p = $self->{parser}->get_parser($xcode);
    die("OOPS ", $p->{system}, " $xcode") unless $p->{system} eq $xcode;
    $info->{parser} = $p;
    if ( $key_ord && $p->movable ) {
	$info->{root_ord} -= $key_ord % $p->intervals;
    }
#    $info->{$_} = $p->{$_} for qw( ns_tbl nf_tbl ns_canon nf_canon );
    unless ( $self->{rootless} ) {
	$info->{root_canon} = $info->{root} =
	  $p->root_canon( $info->{root_ord},
			  $info->{root_mod} >= 0,
			  $info->{qual_canon} eq "-" );
    }
    if ( $p->{system} eq "roman" && $info->{qual_canon} eq "-" ) {
	# Minor quality is in the root name.
	$info->{qual_canon} = $info->{qual} = "";
    }
    if ( $self->{bass} && $self->{bass} ne "" ) {
	if ( $key_ord && $p->movable ) {
	    $info->{bass_ord} -= $key_ord % $p->intervals;
	}
	$info->{bass_canon} = $info->{bass} =
	  $p->root_canon( $info->{bass_ord}, $info->{bass_mod} >= 0 );
    }
    $info->{name} = $info->{name_canon} = $info->canonical;
    $info->{system} = $p->{system};
    bless $info => $p->{target};
#    ::dump($info);
#warn("_<_XCODE = $xcode, CHORD = ", $info->canonical);
    return $info;
}

sub chord_display ( $self ) {

    $self->SUPER::chord_display
      ( $::config->{"chord-formats"}->{common}
	// $::config->{settings}->{"chord-format"}
	// "%{name}" );
}

################ Chord objects: Nashville ################

package ChordPro::Chord::Nashville;

our @ISA = 'ChordPro::Chord::Base';

sub transpose ( $self, $dummy1, $dummy2=0 ) { $self }

sub show {
    Carp::croak("call canonical instead of show");
}

sub canonical ( $self ) {
    my $res = $self->{root_canon} . $self->{qual} . $self->{ext};
    if ( $self->{bass} && $self->{bass} ne "" ) {
	$res .= "/" . lc($self->{bass});
    }
    return $res;
}

sub chord_display ( $self ) {

    $self->SUPER::chord_display
      ( $::config->{"chord-formats"}->{nashville}
	// "%{name}" );
}

# Key name.
sub keyname( $k ) {
    return $k->{parser}->root_canon( $k->{root_ord} ) .
      ( $k->{qual_canon} eq '-' ? "m" : "" );
}

################ Chord objects: Roman ################

package ChordPro::Chord::Roman;

our @ISA = 'ChordPro::Chord::Base';

sub transpose ( $self, $dummy1, $dummy2=0 ) { $self }

sub show {
    Carp::croak("call canonical instead of show");
}

sub canonical ( $self ) {
    my $res = $self->{root_canon} . $self->{qual} . $self->{ext};
    if ( $self->{bass} && $self->{bass} ne "" ) {
	$res .= "/" . lc($self->{bass});
    }
    return $res;
}

sub chord_display ( $self ) {

    $self->SUPER::chord_display
      ( $::config->{"chord-formats"}->{roman}
	// "%{name}" );
}

# Key name.
sub keyname( $k ) {
    return $k->{parser}->root_canon( $k->{root_canon}, 0, $k->{qual_canon} eq '-' );
}

################ Chord objects: Annotations ################

package ChordPro::Chord::Annotation;

use String::Interpolate::Named;

our @ISA = 'ChordPro::Chord::Base';

sub transpose ( $self, $dummy1, $dummy2=0 ) { $self }
sub transcode ( $self, $dummy1, $dummy2=0 ) { $self }

sub canonical ( $self ) {
    my $res = $self->{text};
    return $res;
}

sub chord_display ( $self ) {
    return interpolate( { args => $self }, $self->{text} );
}

# For convenience.
sub is_chord      ( $self ) { 0 };
sub is_annotation ( $self ) { 1 };

################ Chord objects: Strums ################

package ChordPro::Chord::Strum;

# Special 'chord'-like objects for strums in grids.
#
# Main purpose is to show an arrow from the ChordProSymbols font.

our @ISA = 'ChordPro::Chord::Base';

use ChordPro::Symbols qw( strum );

sub new( $pkg, $data ) {
    my $self = $pkg->SUPER::new( $data );
    my $fmt = strum( $data->{name} );
    unless ( defined $fmt ) {
	warn("Unknown strum: $data->{name}\n");
	$self->{format} = "";
    }
    else {
	$self->{format} = $fmt;
    }
    return $self;
}

sub chord_display ( $self, $default = undef ) {
    $self->{format};
}

sub transpose ( $self, $dummy1, $dummy2=0 ) { $self }
sub transcode ( $self, $dummy1, $dummy2=0 ) { $self }

sub canonical ( $self ) {
    my $res = $self->{text};
    return $res;
}

# For convenience.
sub is_chord      ( $self ) { 0 };
sub is_annotation ( $self ) { 1 };
sub is_nc         ( $self ) { 1 };
sub is_xpxc       ( $self ) { 0 };
sub has_diagram   ( $self ) { 0 };
sub is_gridstrum  ( $self ) { 1 };

################ Chord objects: NC ################

package ChordPro::Chord::NC;

use String::Interpolate::Named;

our @ISA = 'ChordPro::Chord::Base';

sub transpose ( $self, $dummy1, $dummy2=0 ) { $self }
sub transcode ( $self, $dummy1, $dummy2=0 ) { $self }

sub canonical ( $self ) {
    my $res = $self->{name};
    return $res;
}

sub chord_display ( $self ) {
    return interpolate( { args => $self }, $self->{name} );
}

# For convenience.
sub is_nc         ( $self ) { 1 };
sub is_chord      ( $self ) { 0 };
sub is_annotation ( $self ) { 0 };
sub has_diagram   ( $self ) { 0 };

################ Testing ################

package main;