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