File Coverage

lib/ChordPro/Output/HTML.pm
Criterion Covered Total %
statement 157 225 69.7
branch 49 108 45.3
condition 23 53 43.4
subroutine 16 16 100.0
pod 0 5 0.0
total 245 407 60.2


"; "; "; ' }
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   2333 use strict;
  2         6  
  2         106  
11 2     2   14 use warnings;
  2         4  
  2         153  
12 2     2   16 use ChordPro::Files;
  2         4  
  2         401  
13 2     2   15 use ChordPro::Output::Common;
  2         5  
  2         55153  
14 2     2   31 use ChordPro::Utils qw();
  2         6  
  2         106  
15 2     2   14 use Storable 'dclone';
  2         4  
  2         10262  
16              
17             sub generate_songbook {
18 3     3 0 11 my ( $self, $sb ) = @_;
19              
20 3         5 my @book;
21 3   50     17 my $cfg = $::config->{html} // {};
22 3   50     16 $cfg->{styles}->{display} //= "chordpro.css";
23 3   50     13 $cfg->{styles}->{print} //= "chordpro_print.css";
24              
25 3         14 push( @book,
26             '',
27             '',
28             '' );
29 3         6 foreach ( sort keys %{ $cfg->{styles} } ) {
  3         18  
30             push( @book,
31 6 100       42 '
32             ( $_ =~ /^(display|default)$/ ? "" : qq{ media="$_"} ).
33             '>' );
34             }
35 3         15 push( @book, '',
36             '',
37             );
38              
39 3         6 foreach my $song ( @{$sb->{songs}} ) {
  3         10  
40 3         7 push( @book, @{ generate_song($song) } );
  3         11  
41             }
42              
43 3         15 push( @book, "", "" );
44 3         16 \@book;
45             }
46              
47             my $config;
48             my $single_space = 0; # suppress chords line when empty
49             my $lyrics_only = 0; # suppress all chords lines
50             my $layout;
51              
52             sub generate_song {
53 3     3 0 8 my ( $s ) = @_;
54              
55 3         9 my $tidy = $::options->{tidy};
56 3         10 $single_space = $::options->{'single-space'};
57 3   33     8076 $config = dclone( $s->{config} // $::config );
58 3         20 $lyrics_only = $config->{settings}->{'lyrics-only'};
59 3         23 $s->structurize;
60 3         33 $layout = Text::Layout::HTML->new;
61 3         6 while ( my($k,$v) = each( %{$config->{markup}->{shortcodes}}) ) {
  3         40  
62 0 0       0 unless ( $layout->can("register_shortcode") ) {
63 0         0 warn("Cannot register shortcodes, upgrade Text::Layout module\n");
64 0         0 last;
65             }
66 0         0 $layout->register_shortcode( $k, $v );
67             }
68              
69 3         8 my @s;
70              
71 3   50     14 for ( $s->{title} // "Untitled" ) {
72 3         18 push( @s,
73             '
',
74             '',
81             '
' . nhtml($_) . '
',
82             );
83              
84             }
85 3 50       12 if ( defined $s->{subtitle} ) {
86             push( @s,
87 3         8 map { '
' . nhtml($_) . '
' }
88 3         8 @{$s->{subtitle}} );
  3         8  
89             }
90              
91 3 50       11 push(@s, "") if $tidy;
92              
93 3         8 my @elts = @{$s->{body}};
  3         16  
94 3         10 while ( @elts ) {
95 30         77 my $elt = shift(@elts);
96              
97 30 50       88 if ( $elt->{type} eq "empty" ) {
98 0         0 push(@s, "***SHOULD NOT HAPPEN***");
99 0         0 next;
100             }
101              
102 30 100       74 if ( $elt->{type} eq "colb" ) {
103             # push(@s, "{column_break}");
104 3         8 next;
105             }
106              
107 27 100       103 if ( $elt->{type} eq "newpage" ) {
108             # push(@s, "{new_page}");
109 3         11 next;
110             }
111              
112 24 50       57 if ( $elt->{type} eq "songline" ) {
113 0         0 push(@s, songline( $s, $elt ));
114 0         0 next;
115             }
116              
117 24 50       59 if ( $elt->{type} eq "tab" ) {
118 0         0 my $p = '
';
119 0         0 foreach ( @{ $elt->{body} } ) {
  0         0  
120 0 0       0 next if $_->{type} eq "set";
121 0         0 push( @s, $p . html($_->{text}) );
122 0         0 $p = "";
123             }
124 0         0 push( @s, $p . '' );
125 0 0       0 push( @s, "") if $tidy;
126 0         0 next;
127             }
128              
129 24 100       51 if ( exists $elt->{body} ) {
130 12         37 push( @s, '
' );
131 12         20 my @elts = @{$elt->{body}};
  12         48  
132 12         27 while ( @elts ) {
133 51         101 my $e = shift(@elts);
134 51 50       145 if ( $e->{type} eq "empty" ) {
135 0         0 push( @s, "" );
136 0         0 next;
137             }
138 51 100       125 if ( $e->{type} eq "songline" ) {
139 48         121 push( @s, songline( $s, $e ) );
140 48         174 next;
141             }
142 3 50       14 if ( $e->{type} =~ /^comment(_\w+)?$/ ) {
143             push( @s,
144             '
' .
145 0         0 '' . nhtml($e->{text}) . '' );
146 0         0 next;
147             }
148 3 50 33     24 if ( $e->{type} eq "set" && $e->{name} eq "label" ) {
149             push( @s,
150 0         0 '
' . nhtml($e->{value}) . '
'
151             );
152 0         0 next;
153             }
154 3 50 33     28 if ( $e->{type} eq "delegate"
155             && $e->{subtype} =~ /^image(?:-(\w+))?$/ ) {
156 0   0     0 my $delegate = $1 // $e->{delegate};
157 0         0 my $pkg = __PACKAGE__;
158 0         0 $pkg =~ s/::Output::\w+$/::Delegate::$delegate/;
159 0 0       0 eval "require $pkg" || die($@);
160 0   0     0 my $hd = $pkg->can($e->{handler}) //
161             die("HTML: Missing delegate handler ${pkg}::$e->{handler}\n");
162 0         0 my $res = $hd->( $s, 0, $e );
163 0 0       0 next unless $res; # assume errors have been given
164 0         0 unshift( @elts, @$res );
165 0         0 next;
166             }
167 3 50       17 if ( $e->{type} eq "svg" ) {
168 0         0 push( @s, '
' );
169 0         0 push( @s, fs_load( $e->{uri} ) );
170 0         0 push( @s, "" );
171 0 0       0 push( @s, "" ) if $tidy;
172 0         0 next;
173             }
174              
175              
176             }
177 12         41 push( @s, '' );
178 12 50       25 push( @s, "" ) if $tidy;
179 12         35 next;
180             }
181              
182 12 50 66     65 if ( $elt->{type} eq "comment" || $elt->{type} eq "comment_italic" ) {
183 12 50       33 if ( $elt->{chords} ) {
184 0         0 my $t = "";
185 0         0 for ( my $i=0; $i < @{$elt->{chords}}; $i++ ) {
  0         0  
186             $t .= $s->{chordsinfo}->{$elt->{chords}->[$i]->key}->name
187 0 0       0 if $elt->{chords}->[$i];
188 0         0 $t .= $elt->{phrases}->[$i];
189             }
190 0         0 push( @s, '
' .
191             nhtml($t) . '' );
192              
193             }
194             else {
195             push( @s,
196             '
' .
197 12         39 '' . nhtml($elt->{orig}) . '' );
198             }
199 12 50       32 push( @s, "" ) if $tidy;
200 12         30 next;
201             }
202              
203 0 0       0 if ( $elt->{type} eq "image" ) {
204 0         0 my @args;
205 0         0 while ( my($k,$v) = each( %{ $elt->{opts} } ) ) {
  0         0  
206 0         0 push( @args, "$k=\"$v\"" );
207             }
208             # First shot code. Fortunately (not surprisingly :))
209             # HTML understands most arguments.
210              
211 0 0       0 if ( $elt->{type} eq "image" ) {
212 0   0     0 $elt->{uri} //= $s->{assets}->{$elt->{id}}->{uri};
213             }
214             push( @s,
215             '
' .
216 0         0 '
217             "@args" . "/>" .
218             '' );
219 0 0       0 push( @s, "" ) if $tidy;
220 0         0 next;
221             }
222              
223 0 0       0 if ( $elt->{type} eq "control" ) {
224 0 0       0 if ( $elt->{name} eq "lyrics-only" ) {
225             $lyrics_only = $elt->{value}
226 0 0       0 unless $lyrics_only > 1;
227             }
228             }
229             }
230              
231 3         8 push( @s, '' ); # song
232 3         124 \@s;
233             }
234              
235             sub songline {
236 48     48 0 101 my ( $song, $elt ) = @_;
237              
238 48         104 my $t_line = "";
239              
240 48   100     201 $elt->{chords} //= [ '' ];
241             my @c = map {
242 111 100       398 $_ eq "" ? "" : $song->{chordsinfo}->{$_->key }->name
243 48         77 } @{ $elt->{chords} };
  48         118  
244              
245 48 100 66     146 if ( $lyrics_only
      100        
      100        
246             or
247             $single_space && ! ( $elt->{chords} && join( "", @c ) =~ /\S/ )
248             ) {
249 24         41 $t_line = join( "", @{ $elt->{phrases} } );
  24         142  
250 24         137 $t_line =~ s/\s+$//;
251 24         55 return ( '', ', ', ',
252             '
253             ' ' . nhtml($t_line) . '
254             '
255             '
' );
256             }
257              
258 24         49 my $cr = ""; # chords row
259 24         41 for ( @{$elt->{chords}} ) {
  24         59  
260 66 100       135 if ( $_ eq "" ) {
261 24         35 $cr .= "
262 24         42 next;
263             }
264 42         95 my $c = $song->{chordsinfo}->{$_->key};
265 42 50       166 if ( $c->isa("ChordPro::Chord::Annotation") ) {
266 0         0 $cr .= "" . $c->{text} . "
267             }
268             else {
269 42         85 $cr .= "" . $c->name . "
270             }
271             }
272              
273             my $pr = join( '', # phrases row
274 66 100       290 map { ( $_ =~ s/^\s+// ? '' : '' ) . nhtml($_) . '
275 24         43 ( @{ $elt->{phrases} } ) );
  24         61  
276              
277 24 50       140 if ( $config->{settings}->{'chords-under'} ) {
278 0         0 return ( '', ', ' ' . $pr, ' ', ', ' ' . $cr, ' ',
279             '
280             '
281             '
' );
282             }
283 24         182 return ( '', ', ' ' . $cr, ' ', ', ' ' . $pr, ' ',
284             '
285             '
286             '
' );
287             }
288              
289             =for later
290              
291             sub gridline {
292             }
293              
294            
306              
307            
308              
309            
intro
310            
a1
311            
a2
312            
a3
313            
a4
314            
b1
315            
b2
316            
b3
317            
b4
318            
c1
319            
c2
320            
c3
321            
c4
322            
d1
323            
d2
324            
d3
325            
d4 d4
326            
327              
328            
329            
a1
330            
a2
331            
a3
332            
a4
333            
b1
334            
b2
335            
b3
336            
b4
337            
c1
338            
c2
339            
c3
340            
c4
341            
d1
342            
d2
343            
d3
344            
d4
345            
2x
346              
347            
348              
349             =cut
350              
351             sub nhtml {
352 108 50   108 0 242 return unless defined $_[0];
353 108         388 $layout->set_markup(shift);
354 108         7431 $layout->render;
355             }
356              
357             sub html {
358 102     102 0 181 my $t = shift;
359 102         154 $t =~ s/&/&/g;
360 102         182 $t =~ s/
361 102         170 $t =~ s/>/>/g;
362 102         240 $t;
363             }
364              
365             # Temporary. Eventually we'll have a decent HTML backend for Text::Layout.
366              
367             package Text::Layout::HTML;
368              
369 2     2   22 use parent 'Text::Layout';
  2         4  
  2         264  
370              
371 2     2   39128 use ChordPro::Utils qw(fq);
  2         5  
  2         165  
372              
373             # Eliminate warning when HTML backend is loaded together with Text backend.
374 2     2   51 no warnings 'redefine';
  2         6  
  2         2210  
375              
376             sub new {
377 3     3   10 my ( $pkg, @data ) = @_;
378 3         25 my $self = $pkg->SUPER::new;
379 3         88 $self->{_currentfont} = { family => 'default',
380             style => 'normal',
381             weight => 'normal' };
382 3         8 $self->{_currentcolor} = 'black';
383 3         10 $self->{_currentsize} = 12;
384 3         8 $self;
385             }
386              
387             *html = \&ChordPro::Output::HTML::html;
388              
389             sub render {
390 108     108   220 my ( $self ) = @_;
391 108         180 my $res = "";
392 108         150 foreach my $fragment ( @{ $self->{_content} } ) {
  108         269  
393 102 50       245 if ( $fragment->{type} eq 'strut' ) {
394 0 0 0     0 next unless length($fragment->{label}//"");
395 0         0 $res .= "{label}."\"/>";
396 0         0 next;
397             }
398 102 50       260 next unless length($fragment->{text});
399 102   33     265 my $f = $fragment->{font} || $self->{_currentfont};
400 102         191 my @c; # styles
401             my @d; # decorations
402 102 50       233 if ( $f->{style} eq "italic" ) {
403 0         0 push( @c, q{font-style:italic} );
404             }
405 102 50       230 if ( $f->{weight} eq "bold" ) {
406 0         0 push( @c, q{font-weight:bold} );
407             }
408 102 50 33     423 if ( $fragment->{color} && $fragment->{color} ne $self->{_currentcolor} ) {
409 0         0 push( @c, join(":","color",$fragment->{color}) );
410             }
411 102 50 33     452 if ( $fragment->{size} && $fragment->{size} ne $self->{_currentsize} ) {
412 0         0 push( @c, join(":","font-size",$fragment->{size}) );
413             }
414 102 50       222 if ( $fragment->{bgcolor} ) {
415 0         0 push( @c, join(":","background-color",$fragment->{bgcolor}) );
416             }
417 102 50       234 if ( $fragment->{underline} ) {
418 0         0 push( @d, q{underline} );
419             }
420 102 50       197 if ( $fragment->{strikethrough} ) {
421 0         0 push( @d, q{line-through} );
422             }
423 102 50       179 push( @c, "text-decoration-line:@d" ) if @d;
424 102   50     324 my $href = $fragment->{href} // "";
425 102 50       187 $res .= "" if length($href);
426 102 50       210 $res .= "" if @c;
427 102         302 $res .= html(fq($fragment->{text}));
428 102 50       214 $res .= "" if @c;
429 102 50       264 $res .= "" if length($href);
430             }
431 108         504 $res;
432             }
433              
434             1;