view release on metacpan or  search on metacpan

lib/ChordPro/Output/Common.pm  view on Meta::CPAN

#! perl

package main;

our $config;
our $options;

package ChordPro::Output::Common;

use strict;
use warnings;
use feature qw( state );
use ChordPro::Chords;
use ChordPro::Utils qw( demarkup is_true plural );
use String::Interpolate::Named;
use utf8;
use POSIX qw(setlocale LC_TIME strftime);
use Ref::Util qw( is_arrayref );
use File::LoadLines ();
use Encode qw( encode_utf8 );

use Exporter 'import';
our @EXPORT;
our @EXPORT_OK;

sub fmt_subst {
    my ( $s, $t ) = @_;
    my $res = "";
    my $m = { %{$s->{meta} || {} } };

    $m->{tuning} //= [ join(" ", ChordPro::Chords::get_tuning) ];
    # If config->{instrument} is missing, or null, the program abends with
    # Modification of a read-only value attempted.
    if ( $config->{instrument} ) {
	$m->{instrument} = [ $config->{instrument}->{type} ];
	$m->{"instrument.type"} = [ $config->{instrument}->{type} ];
	$m->{"instrument.description"} = [ $config->{instrument}->{description} ];
    }
    # Same here.
    if ( $config->{user} ) {
	$m->{user} = [ $config->{user}->{name} ];
	$m->{"user.name"} = [ $config->{user}->{name} ];
	$m->{"user.fullname"} = [ $config->{user}->{fullname} ];
    }
    setlocale( LC_TIME, "" );
    $m->{today} //= strftime( $config->{dates}->{today}->{format},
			      localtime(time) );
    $m->{chordpro} = "ChordPro";
    $m->{"chordpro.version"} = $ChordPro::VERSION;
    for ( keys %{ $config->{settings} } ) {
	my $v = $config->{settings}->{$_};
	$v = '' if $v =~ /^(0|false|off)$/i;
	$v = 1  if $v=~ /^(true|on)$/i;
	$m->{"settings.$_"} = $v;
    }

    # Legacy.
    $m->{key_actual} = $m->{key_sound} // [];
    # Modern.
    $m->{'key.print'} = $m->{key_print} // [];
    $m->{'key.sound'} = $m->{key_sound} // [];

    interpolate( { %$s, args => $m,
		   separator => $config->{metadata}->{separator} },
		 $t );
}
push( @EXPORT, 'fmt_subst' );

# Roman - functions for converting between Roman and Arabic numerals
# 
# Stolen from Roman Version 1.24 by OZAWA Sakuro <ozawa at aisoft.co.jp>
# 1995-1997 and Alexandr Ciornii, C<< <alexchorny at gmail.com> >> 2007
# 
# Copyright (c) 1995 OZAWA Sakuro.  All rights reserved.  This program
# is free software; you can redistribute it and/or modify it under the
# same terms as Perl itself.

our %roman2arabic = qw(I 1 V 5 X 10 L 50 C 100 D 500 M 1000);
my %roman_digit = qw(1 IV 10 XL 100 CD 1000 MMMMMM);
my @figure = reverse sort keys %roman_digit;
#my %roman_digit;
$roman_digit{$_} = [split(//, $roman_digit{$_}, 2)] foreach @figure;

sub isroman($) {
    my $arg = shift;
    $arg ne '' and
      $arg =~ /^(?: M{0,3})
                (?: D?C{0,3} | C[DM])
                (?: L?X{0,3} | X[LC])
                (?: V?I{0,3} | I[VX])$/ix;
}
push( @EXPORT_OK, 'isroman' );

sub arabic($) {
    my $arg = shift;
    isroman $arg or return undef;
    my($last_digit) = 1000;
    my($arabic);
    foreach (split(//, uc $arg)) {
        my($digit) = $roman2arabic{$_};
        $arabic -= 2 * $last_digit if $last_digit < $digit;
        $arabic += ($last_digit = $digit);
    }
    $arabic;
}