font results from the CPAN

font

App-Music-ChordPro

view release on metacpan or search on metacpan

	    }
	    $nbt++;
	}
	if ( $_->{class} eq "bar" ) {
	    $p2 = $p1; $p1 = $p0; undef $p0;
	}
    }
    if ( $nbt > $grid_cells->[0] ) {
	do_warn( "Too few cells for grid content" );
    }
    return ( tokens => \@tokens,
	     $grid_type == 1 ? ( type => "strumline" ) : (),
	     $grid_type == 2 ? ( type => "strumline", subtype => "cellbars" ) : (),
	     %res );
}

################ Parsing directives ################

my %directives = (
		  chord		     => \&define_chord,
		  chorus	     => \&dir_chorus,
		  column_break	     => \&dir_column_break,
		  columns	     => \&dir_columns,
		  comment	     => \&dir_comment,
		  comment_box	     => \&dir_comment,
		  comment_italic     => \&dir_comment,
		  define	     => \&define_chord,
		  diagrams	     => \&dir_diagrams,
		  end_of_bridge	     => undef,
		  end_of_chorus	     => undef,
		  end_of_grid	     => undef,
		  end_of_grille	     => undef,
		  end_of_tab	     => undef,
		  end_of_verse	     => undef,
		  grid		     => \&dir_grid,
		  highlight	     => \&dir_comment,
		  image		     => \&dir_image,
		  meta		     => \&dir_meta,
		  new_page	     => \&dir_new_page,
		  new_physical_page  => \&dir_new_page,
		  new_song	     => \&dir_new_song,
		  no_grid	     => \&dir_no_grid,
		  pagesize	     => \&dir_papersize,
		  pagetype	     => \&dir_papersize,
		  start_of_bridge    => undef,
		  start_of_chorus    => undef,
		  start_of_grid	     => undef,
		  start_of_grille    => undef,
		  start_of_tab	     => undef,
		  start_of_verse     => undef,
		  subtitle	     => \&dir_subtitle,
		  title		     => \&dir_title,
		  titles	     => \&dir_titles,
		  transpose	     => \&dir_transpose,
   );
# NOTE: Flex: start_of_... end_of_... x_...

my %abbrevs = (
   c	      => "comment",
   cb	      => "comment_box",
   cf	      => "chordfont",
   ci	      => "comment_italic",
   col	      => "columns",
   colb	      => "column_break",
   cs	      => "chordsize",
   eob	      => "end_of_bridge",
   eoc	      => "end_of_chorus",
   eog	      => "end_of_grid",
   eot	      => "end_of_tab",
   eov	      => "end_of_verse",
   g	      => "diagrams",
   ng	      => "no_grid",
   np	      => "new_page",
   npp	      => "new_physical_page",
   ns	      => "new_song",
   sob	      => "start_of_bridge",
   soc	      => "start_of_chorus",
   sog	      => "start_of_grid",
   sot	      => "start_of_tab",
   sov	      => "start_of_verse",
   st	      => "subtitle",
   t	      => "title",
   tf         => "textfont",
   ts         => "textsize",
	      );

# Use by: runtimeinfo.
sub _directives { \%directives }
sub _directive_abbrevs { \%abbrevs }

my $dirpat;

sub parse_directive {
    my ( $self, $d ) = @_;

    # Pattern for all recognized directives.
    unless ( $dirpat ) {
	$dirpat =
	  '(?:' .
	  join( '|', keys(%directives),
		     @{$config->{metadata}->{keys}},
		     keys(%abbrevs),
		     '(?:start|end)_of_\w+',
		     "(?:$propitems_re".
		     '(?:font|size|colou?r))',
		) . ')';
	$dirpat = qr/$dirpat/;
    }

    # $d is the complete directive line, without leading/trailing { }.
    if ( $options->{reference} and $d =~ s/^\s*:[: ]*//) {
	do_warn("Incorrect start of directive (':' not allowed at start)");
    }
    $d =~ s/^[: ]+//;
    $d =~ s/\s+$//;
    my $dir = lc($d);
    my $arg = "";
    if ( $d =~ /^(.*?)([: ])\s*(.*)/ ) {
	( $dir, $arg ) = ( lc($1), $3 );
	if ( $options->{reference} ) {
	    do_warn("Directive name must be followed by a ':'")
	      unless $2 eq ":";
	}
    }
    $dir =~ s/[: ]+$//;
    # $dir is the lowcase directive name.
    # $arg is the rest, if any.

    # Check for xxx-yyy selectors.
    if ( $dir =~ /^($dirpat)-(.+)$/ ) {
	$dir = $abbrevs{$1} // $1;
	unless ( $self->selected($2) ) {
	    if ( $dir =~ /^start_of_/ ) {
		return { name => $dir, arg => $arg, omit => 2 };
	    }
	    else {
		return { name => $dir, arg => $arg, omit => 1 };
	    }
	}
    }
    else {
	$dir = $abbrevs{$dir} // $dir;
    }

    if ( $dir =~ /^start_of_(.*)/
	 && exists $config->{delegates}->{$1}
	 && beo( $config->{delegates}->{$1}, 'type' ) eq 'omit' ) {
	return { name => $dir, arg => $arg, omit => 2 };
    }

    return { name => $dir, arg => $arg, omit => 0 }
}

# Process a selector.
sub selected {
    my ( $self, $sel ) = @_;
    return 1 unless defined $sel;
    my $negate = $sel =~ s/\!$//;
    $sel = ( $sel eq lc($config->{instrument}->{type}) )
      ||
      ( $sel eq lc($config->{user}->{name})
	||
	( $self->{meta}->{lc $sel} && is_true($self->{meta}->{lc $sel}->[0]) )
      );
    $sel = !$sel if $negate;

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

		    }
		    else {
			$self->{spreadimage} =
			  { id => $id, space => $opts->{spread} };
			warn("Got spread image $id with space=$opts->{spread}\n")
			  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" ) {

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

	}
    }

    $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 );

    # A trailing number after a font directive is an implicit size
    # directive.
    if ( $prop eq 'font' && $value =~ /\s(\d+(?:\.\d+)?)$/ ) {
	$self->add( type  => "control",
		    name  => "$item-size",
		    value => $1 );
	push( @{ $propstack{"$item-size"} }, $1 );
    }
}

sub add_chord {
    my ( $self, $info, $new_id ) = @_;

    if ( $new_id ) {
	if ( $new_id eq "1" ) {
	    state $id = "ch0000";
	    $new_id = " $id";
	    $id++;
	}
    }
    else {
	$new_id = $info->name;
    }
    $self->{chordsinfo}->{$new_id} = $info->new($info);

    return $new_id;
}

sub define_chord {
    my ( $self, $dir, $args ) = @_;

    # Split the arguments and keep a copy for error messages.
    # Note that quotewords returns an empty result if it gets confused,
    # so fall back to the ancient split method if so.
    $args =~ s/^\s+//;
    $args =~ s/\s+$//;
    my @a = quotewords( '[: ]+', 0, $args );
    @a = split( /[: ]+/, $args ) unless @a;

    my @orig = @a;
    my $show = $dir eq "chord";
    my $fail = 0;
    my $name = shift(@a);
    my $strings = $config->diagram_strings;

    # Process the options.
    my %kv = ( name => $name );
    while ( @a ) {
	my $a = shift(@a);

	# Copy existing definition.
	if ( $a eq "copy" || $a eq "copyall" ) {
	    if ( my $i = ChordPro::Chords::known_chord($a[0]) ) {
		$kv{$a} = $a[0];
		$kv{orig} = $i;
		shift(@a);
	    }
	    else {
		do_warn("Unknown chord to copy: $a[0]\n");
		$fail++;
		last;
	    }
	}

( run in 0.611 second using v1.01-cache-2.11-cpan-5735350b133 )