File Coverage

blib/lib/ChordPro/Output/Common.pm
Criterion Covered Total %
statement 129 145 88.9
branch 43 68 63.2
condition 23 35 65.7
subroutine 12 14 85.7
pod 0 6 0.0
total 207 268 77.2


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package main;
4              
5             our $config;
6             our $options;
7              
8             package ChordPro::Output::Common;
9              
10 79     79   615 use strict;
  79         228  
  79         3095  
11 79     79   457 use warnings;
  79         213  
  79         2077  
12 79     79   454 use ChordPro::Chords;
  79         193  
  79         1887  
13 79     79   410 use ChordPro::Utils qw( demarkup );
  79         214  
  79         3556  
14 79     79   533 use String::Interpolate::Named;
  79         200  
  79         3836  
15 79     79   562 use utf8;
  79         234  
  79         590  
16 79     79   3266 use POSIX qw(setlocale LC_TIME strftime);
  79         7169  
  79         1044  
17              
18 79     79   141293 use parent qw(Exporter);
  79         214  
  79         585  
19             our @EXPORT;
20             our @EXPORT_OK;
21              
22             sub fmt_subst {
23 2115     2115 0 54503 my ( $s, $t ) = @_;
24 2115         3794 my $res = "";
25 2115 50       3213 my $m = { %{$s->{meta} || {} } };
  2115         12097  
26              
27             # Derived item(s).
28 2115 100       6620 $m->{_key} = $m->{key} if exists $m->{key};
29 2115 100 100     7456 if ( $m->{key} && $m->{capo} && (my $capo = $m->{capo}->[-1]) ) {
      66        
30             ####CHECK
31             $m->{_key} =
32 123         396 [ map { ChordPro::Chords::transpose( $_, $capo ) }
33 115         223 @{$m->{key}} ];
  115         293  
34             }
35 2115   100     8218 $m->{key_actual} //= $m->{key};
36 2115   50     10079 $m->{tuning} //= [ join(" ", ChordPro::Chords::get_tuning) ];
37             # If config->{instrument} is missing, or null, the program abends with
38             # Modification of a read-only value attempted.
39 2115 50       6485 if ( $config->{instrument} ) {
40 2115         5867 $m->{instrument} = [ $config->{instrument}->{type} ];
41 2115         5393 $m->{"instrument.type"} = [ $config->{instrument}->{type} ];
42 2115         5660 $m->{"instrument.description"} = [ $config->{instrument}->{description} ];
43             }
44             # Same here.
45 2115 50       5098 if ( $config->{user} ) {
46 2115         5571 $m->{user} = [ $config->{user}->{name} ];
47 2115         5565 $m->{"user.name"} = [ $config->{user}->{name} ];
48 2115         5389 $m->{"user.fullname"} = [ $config->{user}->{fullname} ];
49             }
50 2115         16230 setlocale( LC_TIME, "" );
51             $m->{today} //= [ strftime( $config->{dates}->{today}->{format},
52 2115   50     118420 localtime(time) ) ];
53              
54 2115         5926 for ( keys %{ $config->{settings} } ) {
  2115         14423  
55 42300         72132 my $v = $config->{settings}->{$_};
56 42300 100       98125 $v = '' if $v =~ /^(0|false|off)$/i;
57 42300 50       219129 $v = 1 if $v=~ /^(true|on)$/i;
58 42300         148611 $m->{"settings.$_"} = $v;
59             }
60             interpolate( { %$s, args => $m,
61             separator => $config->{metadata}->{separator} },
62 2115         22635 $t );
63             }
64             push( @EXPORT, 'fmt_subst' );
65              
66             # Roman - functions for converting between Roman and Arabic numerals
67             #
68             # Stolen from Roman Version 1.24 by OZAWA Sakuro
69             # 1995-1997 and Alexandr Ciornii, C<< >> 2007
70             #
71             # Copyright (c) 1995 OZAWA Sakuro. All rights reserved. This program
72             # is free software; you can redistribute it and/or modify it under the
73             # same terms as Perl itself.
74              
75             our %roman2arabic = qw(I 1 V 5 X 10 L 50 C 100 D 500 M 1000);
76             my %roman_digit = qw(1 IV 10 XL 100 CD 1000 MMMMMM);
77             my @figure = reverse sort keys %roman_digit;
78             #my %roman_digit;
79             $roman_digit{$_} = [split(//, $roman_digit{$_}, 2)] foreach @figure;
80              
81             sub isroman($) {
82 0     0 0 0 my $arg = shift;
83 0 0       0 $arg ne '' and
84             $arg =~ /^(?: M{0,3})
85             (?: D?C{0,3} | C[DM])
86             (?: L?X{0,3} | X[LC])
87             (?: V?I{0,3} | I[VX])$/ix;
88             }
89             push( @EXPORT_OK, 'isroman' );
90              
91             sub arabic($) {
92 0     0 0 0 my $arg = shift;
93 0 0       0 isroman $arg or return undef;
94 0         0 my($last_digit) = 1000;
95 0         0 my($arabic);
96 0         0 foreach (split(//, uc $arg)) {
97 0         0 my($digit) = $roman2arabic{$_};
98 0 0       0 $arabic -= 2 * $last_digit if $last_digit < $digit;
99 0         0 $arabic += ($last_digit = $digit);
100             }
101 0         0 $arabic;
102             }
103             push( @EXPORT_OK, 'arabic' );
104              
105             sub Roman($) {
106 32     32 0 70 my $arg = shift;
107 32 50 33     249 0 < $arg and $arg < 4000 or return undef;
108 32         81 my($x, $roman);
109 32         99 foreach (@figure) {
110 128         293 my($digit, $i, $v) = (int($arg / $_), @{$roman_digit{$_}});
  128         469  
111 128 100 66     670 if (1 <= $digit and $digit <= 3) {
    50 33        
    50          
    50          
    50          
112 32         95 $roman .= $i x $digit;
113             } elsif ($digit == 4) {
114 0         0 $roman .= "$i$v";
115             } elsif ($digit == 5) {
116 0         0 $roman .= $v;
117             } elsif (6 <= $digit and $digit <= 8) {
118 0         0 $roman .= $v . $i x ($digit - 5);
119             } elsif ($digit == 9) {
120 0         0 $roman .= "$i$x";
121             }
122 128         220 $arg -= $digit * $_;
123 128         241 $x = $i;
124             }
125 32         206 $roman;
126             }
127             push( @EXPORT_OK, 'Roman' );
128              
129             sub roman($) {
130 32     32 0 129 lc Roman shift;
131             }
132             push( @EXPORT_OK, 'roman' );
133              
134             # Prepare outlines.
135             # This mainly untangles alternative names when being sorted on.
136             # Returns a book array where each element consists of the sort items,
137             # and the song.
138              
139             #sub PODBG() { $config->{debug}->{x1} }
140             sub PODBG() { 0 }
141              
142             sub prep_outlines {
143 37     37 0 6001 my ( $book, $ctl ) = @_;
144 37 50 33     246 return [] unless $book && @$book; # unlikely
145 37 50       149 return [] if $ctl->{omit};
146              
147 37         200 warn("FLD: ", join(" ", @{$ctl->{fields}}), "\n") if PODBG;
148              
149 37 50       92 my @fields = map { /^[-+]*(.*)/ ? $1 : $_ } @{$ctl->{fields}};
  64         444  
  37         144  
150 37 100 100     259 if ( @fields == 1 && $fields[0] eq "songindex" ) {
151             # Return in book order.
152 8         38 return [ map { [ $_->{meta}->{songindex}, $_ ] } @$book ];
  24         105  
153             }
154 29 50       101 return $book unless @fields; # ?
155              
156 29         70 my @book;
157 29         95 foreach my $song ( @$book ) {
158 87         229 my $meta = $song->{meta};
159              
160 87         143 my @split;
161              
162 87         173 foreach my $item ( @fields ) {
163 168         472 ( my $coreitem = $item ) =~ s/^sort//;
164 168 100       491 push( @split, [ $coreitem, [""] ] ), next unless $meta->{$coreitem};
165              
166 178         510 my @s = map { [ $_ ] }
167 167         262 @{ UNIVERSAL::isa( $meta->{$coreitem}, 'ARRAY' )
168             ? $meta->{$coreitem}
169 167 50       624 : [ $meta->{$coreitem} ]
170             };
171              
172 167 100       561 if ( $meta->{"sort$coreitem"} ) {
173 9 100       26 if ( $coreitem eq $item ) {
174 6         14 for ( my $i = 0; $i < @{$meta->{"sort$coreitem"}}; $i++ ) {
  14         38  
175 8 50       20 next unless defined $s[$i]->[0];
176 8         23 $s[$i]->[1] = $meta->{"sort$coreitem"}->[$i];
177             }
178             }
179             else {
180 3         6 for ( my $i = 0; $i < @{$meta->{$item}}; $i++ ) {
  7         19  
181 4 50       10 next unless defined $s[$i]->[0];
182 4         10 $s[$i]->[1] = $meta->{$item}->[$i];
183             }
184             }
185             }
186 167         455 push( @split, [ $coreitem, @s ] );
187             }
188              
189             # Merge with (unique) copies of the song.
190 87 50       239 if ( @split == 0 ) {
191 0         0 push( @book, $song );
192             }
193             # elsif ( @split == 1 ) {
194             # my $f1 = shift(@{$split[0]});
195             # my $addsort1 = $f1 =~ /^(title|artist)$/;
196             # for my $s1 ( @{$split[0]} ) {
197             # push( @book,
198             # { %$song,
199             # meta =>
200             # { %$meta,
201             # $f1 => [ $s1->[0] ],
202             # $addsort1
203             # ? ( "sort$f1" => [ $s1->[1] // $s1->[0] ] )
204             # : (),
205             # }
206             # }
207             # );
208             # }
209             # }
210             # elsif ( @split == 200 ) {
211             # my $f1 = shift(@{$split[0]}) // "";
212             # my $f2 = shift(@{$split[1]}) // "";
213             # my $addsort1 = $f1 =~ /^(title|artist)$/;
214             # my $addsort2 = $f2 =~ /^(title|artist)$/;
215             # for my $s1 ( @{$split[0]} ) {
216             # for my $s2 ( @{$split[1]} ) {
217             # push( @book,
218             # { %$song,
219             # meta =>
220             # { %$meta,
221             # $f1 => [ $s1->[0] ],
222             # $addsort1
223             # ? ( "sort$f1" => [ $s1->[1] // $s1->[0] ] )
224             # : (),
225             # $f2 => [ $s2->[0] ],
226             # $addsort2
227             # ? ( "sort$f2" => [ $s2->[1] // $s2->[0] ] )
228             # : (),
229             # }
230             # }
231             # );
232             # }
233             # }
234             # }
235             else {
236 87         154 my @mm;
237 87         170 for my $split ( @split ) {
238 168   50     410 my $f = shift(@$split) // "";
239 168         318 warn("F: $f\n") if PODBG;
240 168         611 my $addsort = $f =~ /^(title|artist)$/;
241 168         277 my @x;
242 168         237 for my $s ( @{$split} ) {
  168         393  
243 179         270 warn("V: $s->[0]\n") if PODBG;
244 179         518 my %x = ( $f => [ $s->[0] ] );
245 179 100 100     824 $x{"sort$f"} = [ $s->[1] // $s->[0] ] if $addsort;
246 179 100       408 if ( @mm ) {
247 87         463 push( @x, { %x, %$_ } ) for @mm;
248             }
249             else {
250 92         183 push( @x, \%x );
251             }
252 179         372 warn("X: ", scalar(@x), " items\n") if PODBG;
253             }
254 168         436 @mm = @x;
255             }
256 87         1603 push( @book, { %$song, meta => { %$meta, %$_ } } ) for @mm;
257             }
258             }
259              
260             # Sort.
261 29         110 my $i = -1;
262             my $srt =
263             "sub { " .
264             join( " or ",
265 56         107 map { $i++;
266 56         263 my ( $rev, $f ) = /^([-+]*)(.*)/;
267 56         179 my $num = $rev =~ s/\+//g;
268 56         93 warn("F: $f, N: $num, R: $rev\n") if PODBG;
269 56 100       510 "\$" . ( $rev =~ /-/ ? "b" : "a" ) . "->[$i] " .
    50          
    100          
270             ($num ? '<=>' : 'cmp') .
271             " \$" . ( $rev =~ /-/ ? "a" : "b" ) . "->[$i]" }
272 29         84 @{$ctl->{fields}} ) .
  29         92  
273             " }";
274 29         81 warn("SRT; $srt\n") if PODBG;
275 29 50       5682 $srt = eval $srt or die($@);
276             @book =
277             sort $srt
278 29         132 map { my $t = $_;
  101         193  
279 101   50     187 [ ( map { demarkup(lc($t->{meta}->{$_}->[0] // "")) }
  194         874  
280             @fields ),
281             $_ ] }
282             @book;
283              
284 29         395 return \@book;
285             }
286             push( @EXPORT_OK, 'prep_outlines' );
287              
288             1;