File Coverage

lib/ChordPro/Output/HTML.pm
Criterion Covered Total %
statement 118 164 71.9
branch 35 70 50.0
condition 19 33 57.5
subroutine 13 13 100.0
pod 0 5 0.0
total 185 285 64.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             package ChordPro::Output::HTML;
4              
5             # Produce nice viewable HMTL output.
6             #
7             # You should be able to print it using a decent browser (notexisting)
8             # or a formatting tool like weasyprint.
9              
10 2     2   1068 use strict;
  2         5  
  2         113  
11 2     2   20 use warnings;
  2         5  
  2         75  
12 2     2   12 use ChordPro::Output::Common;
  2         4  
  2         136  
13 2     2   15 use ChordPro::Utils qw();
  2         5  
  2         4186  
14              
15             sub generate_songbook {
16 3     3 0 11 my ( $self, $sb ) = @_;
17              
18 3         8 my @book;
19 3   50     14 my $cfg = $::config->{html} // {};
20 3   50     13 $cfg->{styles}->{display} //= "chordpro.css";
21 3   50     13 $cfg->{styles}->{print} //= "chordpro_print.css";
22              
23 3         14 push( @book,
24             '',
25             '',
26             '' );
27 3         6 foreach ( sort keys %{ $cfg->{styles} } ) {
  3         28  
28             push( @book,
29 6 100       51 '
30             ( $_ =~ /^(display|default)$/ ? "" : qq{ media="$_"} ).
31             '>' );
32             }
33 3         13 push( @book, '',
34             '',
35             );
36              
37 3         6 foreach my $song ( @{$sb->{songs}} ) {
  3         9  
38 3         6 push( @book, @{ generate_song($song) } );
  3         10  
39             }
40              
41 3         12 push( @book, "", "" );
42 3         12 \@book;
43             }
44              
45             my $single_space = 0; # suppress chords line when empty
46             my $lyrics_only = 0; # suppress all chords lines
47             my $layout;
48              
49             sub generate_song {
50 3     3 0 11 my ( $s ) = @_;
51              
52 3         10 my $tidy = $::options->{tidy};
53 3         9 $single_space = $::options->{'single-space'};
54 3         7 $lyrics_only = $::config->{settings}->{'lyrics-only'};
55 3         17 $s->structurize;
56 3         34 $layout = Text::Layout::Text->new;
57              
58 3         7 my @s;
59              
60 3   50     14 for ( $s->{title} // "Untitled" ) {
61 3         21 push( @s,
62             '
',
63             '',
70             '
' . nhtml($_) . '
',
71             );
72              
73             }
74 3 50       15 if ( defined $s->{subtitle} ) {
75             push( @s,
76 3         8 map { '
' . nhtml($_) . '
' }
77 3         9 @{$s->{subtitle}} );
  3         9  
78             }
79              
80 3 50       12 push(@s, "") if $tidy;
81              
82 3         6 my @elts = @{$s->{body}};
  3         14  
83 3         12 while ( @elts ) {
84 33         48 my $elt = shift(@elts);
85              
86 33 50       83 if ( $elt->{type} eq "empty" ) {
87 0         0 push(@s, "***SHOULD NOT HAPPEN***");
88 0         0 next;
89             }
90              
91 33 100       61 if ( $elt->{type} eq "colb" ) {
92             # push(@s, "{column_break}");
93 3         7 next;
94             }
95              
96 30 100       62 if ( $elt->{type} eq "newpage" ) {
97             # push(@s, "{new_page}");
98 3         9 next;
99             }
100              
101 27 50       55 if ( $elt->{type} eq "songline" ) {
102 0         0 push(@s, songline( $s, $elt ));
103 0         0 next;
104             }
105              
106 27 50       89 if ( $elt->{type} eq "tab" ) {
107 0         0 my $p = '
';
108 0         0 foreach ( @{ $elt->{body} } ) {
  0         0  
109 0 0       0 next if $_->{type} eq "set";
110 0         0 push( @s, $p . html($_->{text}) );
111 0         0 $p = "";
112             }
113 0         0 push( @s, $p . '' );
114 0 0       0 push( @s, "") if $tidy;
115 0         0 next;
116             }
117              
118 27 100       56 if ( exists $elt->{body} ) {
119 12         41 push( @s, '
' );
120 12         17 my @elts = @{$elt->{body}};
  12         46  
121 12         30 while ( @elts ) {
122 51         89 my $e = shift(@elts);
123 51 50       138 if ( $e->{type} eq "empty" ) {
124 0         0 push( @s, "" );
125 0         0 next;
126             }
127 51 100       115 if ( $e->{type} eq "songline" ) {
128 48         90 push( @s, songline( $s, $e ) );
129 48         147 next;
130             }
131 3 50       17 if ( $e->{type} =~ /^comment(_\w+)?$/ ) {
132             push( @s,
133             '
' .
134 0         0 '' . nhtml($e->{text}) . '' );
135 0         0 next;
136             }
137 3 50 33     24 if ( $e->{type} eq "set" && $e->{name} eq "label" ) {
138             push( @s,
139 0         0 '
' . nhtml($e->{value}) . '
'
140             );
141 0         0 next;
142             }
143 3 50 33     15 if ( $e->{type} eq "delegate"
144             && $e->{subtype} =~ /^image(?:-(\w+))?$/ ) {
145 0   0     0 my $delegate = $1 // $e->{delegate};
146 0         0 my $pkg = __PACKAGE__;
147 0         0 $pkg =~ s/::Output::\w+$/::Delegate::$delegate/;
148 0 0       0 eval "require $pkg" || die($@);
149 0   0     0 my $hd = $pkg->can($e->{handler}) //
150             die("HTML: Missing delegate handler ${pkg}::$e->{handler}\n");
151 0         0 my $res = $hd->( $s, 0, $e );
152 0 0       0 next unless $res; # assume errors have been given
153 0         0 unshift( @elts, @$res );
154 0         0 next;
155             }
156 3 50       15 if ( $e->{type} eq "svg" ) {
157 0         0 push( @s, '
' );
158 0         0 push( @s, File::LoadLines::loadlines( $e->{uri} ) );
159 0         0 push( @s, "" );
160 0 0       0 push( @s, "" ) if $tidy;
161 0         0 next;
162             }
163              
164              
165             }
166 12         25 push( @s, '' );
167 12 50       25 push( @s, "" ) if $tidy;
168 12         29 next;
169             }
170              
171 15 100 100     70 if ( $elt->{type} eq "comment" || $elt->{type} eq "comment_italic" ) {
172             push( @s,
173             '
' .
174 12         46 '' . nhtml($elt->{text}) . '' );
175 12 50       32 push( @s, "" ) if $tidy;
176 12         30 next;
177             }
178              
179 3 50       11 if ( $elt->{type} eq "image" ) {
180 0         0 my @args;
181 0         0 while ( my($k,$v) = each( %{ $elt->{opts} } ) ) {
  0         0  
182 0         0 push( @args, "$k=\"$v\"" );
183             }
184             # First shot code. Fortunately (not surprisingly :))
185             # HTML understands most arguments.
186             push( @s,
187             '
' .
188 0         0 '
189             "@args" . "/>" .
190             '' );
191 0 0       0 push( @s, "" ) if $tidy;
192 0         0 next;
193             }
194              
195 3 50       12 if ( $elt->{type} eq "control" ) {
196 0 0       0 if ( $elt->{name} eq "lyrics-only" ) {
197             $lyrics_only = $elt->{value}
198 0 0       0 unless $lyrics_only > 1;
199             }
200             }
201             }
202              
203 3         18 push( @s, '' ); # song
204 3         73 \@s;
205             }
206              
207             sub songline {
208 48     48 0 87 my ( $song, $elt ) = @_;
209              
210 48         64 my $t_line = "";
211              
212 48   100     210 $elt->{chords} //= [ '' ];
213             my @c = map {
214 111 100       368 $_ eq "" ? "" : $song->{chordsinfo}->{$_->key }->name
215 48         86 } @{ $elt->{chords} };
  48         97  
216              
217 48 100 66     151 if ( $lyrics_only
      100        
      100        
218             or
219             $single_space && ! ( $elt->{chords} && join( "", @c ) =~ /\S/ )
220             ) {
221 24         110 $t_line = join( "", @{ $elt->{phrases} } );
  24         63  
222 24         122 $t_line =~ s/\s+$//;
223 24         52 return ( '', ', ', ',
224             '
225             ' ' . nhtml($t_line) . '
226             '
227             '
' );
228             }
229              
230 24 50       301 if ( $::config->{settings}->{'chords-under'} ) {
231             return ( '', ', ' } ', ', ' } ',
232             '
233             ' ' . join( '',
234 0 0       0 map { ( $_ =~ s/^\s+// ? '' : '' ) . nhtml($_) . '
235 0         0 ( @{ $elt->{phrases} } ) ),
236             '
237             '
238             ' ' . join( '',
239 0         0 map { '' . nhtml($_) . '
  0         0  
240             ( @c ) ),
241             '
242             '
' );
243             }
244             return ( '', ', ' } ', ', ' } ',
245             '
246             ' ' . join( '',
247 66         115 map { '' . nhtml($_) . '
248             ( @c ) ),
249             '
250             '
251             ' ' . join( '',
252 66 100       259 map { ( $_ =~ s/^\s+// ? '' : '' ) . nhtml($_) . '
253 24         205 ( @{ $elt->{phrases} } ) ),
  24         54  
254             '
255             '
' );
256             }
257              
258             =for later
259              
260             sub gridline {
261             }
262              
263            
275              
276            
277              
278            
intro
279            
a1
280            
a2
281            
a3
282            
a4
283            
b1
284            
b2
285            
b3
286            
b4
287            
c1
288            
c2
289            
c3
290            
c4
291            
d1
292            
d2
293            
d3
294            
d4 d4
295            
296              
297            
298            
a1
299            
a2
300            
a3
301            
a4
302            
b1
303            
b2
304            
b3
305            
b4
306            
c1
307            
c2
308            
c3
309            
c4
310            
d1
311            
d2
312            
d3
313            
d4
314            
2x
315              
316            
317              
318             =cut
319              
320             sub nhtml {
321 174 50   174 0 463 return unless defined $_[0];
322 174         455 $layout->set_markup(shift);
323 174         7139 html($layout->render);
324             }
325              
326             sub html {
327 174     174 0 262 my $t = shift;
328 174         281 $t =~ s/&/&/g;
329 174         262 $t =~ s/
330 174         237 $t =~ s/>/>/g;
331 174         764 $t;
332             }
333              
334             # Temporary. Eventually we'll have a decent HTML backend for Text::Layout.
335              
336             package Text::Layout::Text;
337              
338 2     2   22 use parent 'Text::Layout';
  2         4  
  2         15  
339              
340             # Eliminate warning when HTML backend is loaded together with Text backend.
341 2     2   15217 no warnings 'redefine';
  2         5  
  2         419  
342              
343             sub new {
344 3     3   12 my ( $pkg, @data ) = @_;
345 3         31 my $self = $pkg->SUPER::new;
346 3         64 $self;
347             }
348              
349             sub render {
350 174     174   297 my ( $self ) = @_;
351 174         246 my $res = "";
352 174         305 foreach my $fragment ( @{ $self->{_content} } ) {
  174         369  
353 144 50       345 next unless length($fragment->{text});
354 144         328 $res .= ChordPro::Utils::fq($fragment->{text});
355             }
356 174         382 $res;
357             }
358              
359             1;