File Coverage

blib/lib/ChordPro/Output/HTML.pm

Criterion	Covered	Total	%
statement	112	143	78.3
branch	33	60	55.0
condition	18	25	72.0
subroutine	13	13	100.0
pod	0	5	0.0
total	176	246	71.5

#!/usr/bin/perl

package ChordPro::Output::HTML;

# Produce nice viewable HMTL output.
#
# You should be able to print it using a decent browser (notexisting)
# or a formatting tool like weasyprint.

use strict;
use warnings;
use ChordPro::Output::Common;
use ChordPro::Utils qw();

sub generate_songbook {
    my ( $self, $sb ) = @_;

    my @book;
    my $cfg = $::config->{html} // {};
    $cfg->{styles}->{display} //= "chordpro.css";
    $cfg->{styles}->{print} //= "chordpro_print.css";

    push( @book,
	  '',
	  '',
	  '' );
    foreach ( sort keys %{ $cfg->{styles} } ) {
	push( @book,
	      '
	      ( $_ =~ /^(display|default)$/ ? "" : qq{ media="$_"} ).
	      '>' );
    }
    push( @book, '',
	  '',
	);

    foreach my $song ( @{$sb->{songs}} ) {
	push( @book, @{ generate_song($song) } );
    }

    push( @book, "", "" );
    \@book;
}

my $single_space = 0;		# suppress chords line when empty
my $lyrics_only = 0;		# suppress all chords lines
my $layout;

sub generate_song {
    my ( $s ) = @_;

    my $tidy      = $::options->{tidy};
    $single_space = $::options->{'single-space'};
    $lyrics_only  = $::config->{settings}->{'lyrics-only'};
    $s->structurize;
    $layout = Text::Layout::Text->new;

    my @s;

    for ( $s->{title} // "Untitled" ) {
	push( @s,
	      '',
	      '', </td>
</tr>

<tr>
<td  class="h" >
<a name="64">64</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	      '@page {', </td>
</tr>

<tr>
<td  class="h" >
<a name="65">65</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	      '  @top-center {', </td>
</tr>

<tr>
<td  class="h" >
<a name="66">66</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	      '      content: counter(song) ". ' . $_ . '";', </td>
</tr>

<tr>
<td  class="h" >
<a name="67">67</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	      '  }', </td>
</tr>

<tr>
<td  class="h" >
<a name="68">68</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	      '}', </td>
</tr>

<tr>
<td  class="h" >
<a name="69">69</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> 	      '',
	      '' . nhtml($_) . '',
	    );

    }
    if ( defined $s->{subtitle} ) {
	push( @s,
	      map { '' . nhtml($_) . '' }
	      @{$s->{subtitle}} );
    }

    push(@s, "") if $tidy;

    foreach my $elt ( @{$s->{body}} ) {

	if ( $elt->{type} eq "empty" ) {
	    push(@s, "***SHOULD NOT HAPPEN***");
	    next;
	}

	if ( $elt->{type} eq "colb" ) {
	    # push(@s, "{column_break}");
	    next;
	}

	if ( $elt->{type} eq "newpage" ) {
	    # push(@s, "{new_page}");
	    next;
	}

	if ( $elt->{type} eq "songline" ) {
	    push(@s, songline( $s, $elt ));
	    next;
	}

	if ( $elt->{type} eq "tab" ) {
	    my $p = '';
	    foreach ( @{ $elt->{body} } ) {
		next if $_->{type} eq "set";
		push( @s, $p . html($_->{text}) );
		$p = "";
	    }
	    push( @s, $p . '' );
	    push( @s, "") if $tidy;
	    next;
	}

	if ( exists $elt->{body} ) {
	    push( @s, '' );
	    foreach my $e ( @{$elt->{body}} ) {
		if ( $e->{type} eq "empty" ) {
		    push( @s, "" );
		    next;
		}
		if ( $e->{type} eq "songline" ) {
		    push( @s, songline( $s, $e ) );
		    next;
		}
		if ( $e->{type} =~ /^comment(_\w+)?$/ ) {
		    push( @s,
			  '' .
			  '' . nhtml($e->{text}) . '' );
		    next;
		}
		if ( $e->{type} eq "set" && $e->{name} eq "label" ) {
		    push( @s,
			  '' . nhtml($e->{value}) . ''
			);
		    next;
		}

	    }
	    push( @s, '' );
	    push( @s, "" ) if $tidy;
	    next;
	}

	if ( $elt->{type} eq "comment" || $elt->{type} eq "comment_italic" ) {
	    push( @s,
		  '' .
		  '' . nhtml($elt->{text}) . '' );
	    push( @s, "" ) if $tidy;
	    next;
	}

	if ( $elt->{type} eq "image" ) {
	    my @args;
	    while ( my($k,$v) = each( %{ $elt->{opts} } ) ) {
		push( @args, "$k=\"$v\"" );
	    }
	    # First shot code. Fortunately (not surprisingly :))
	    # HTML understands most arguments.
	    push( @s,
		  '' .
		  '
		  "@args" . "/>" .
		  '' );
	    push( @s, "" ) if $tidy;

	}

	if ( $elt->{type} eq "control" ) {
	    if ( $elt->{name} eq "lyrics-only" ) {
		$lyrics_only = $elt->{value}
		  unless $lyrics_only > 1;
	    }
	}
    }

    push( @s, '' );	# song
    \@s;
}

sub songline {
    my ( $song, $elt ) = @_;

    my $t_line = "";

    $elt->{chords} //= [ '' ];
    my @c = map {
	$_ eq "" ? "" : $song->{chordsinfo}->{$_->key }->name
    } @{ $elt->{chords} };

    if ( $lyrics_only
	 or
	 $single_space && ! ( $elt->{chords} && join( "", @c ) =~ /\S/ )
       ) {
	$t_line = join( "", @{ $elt->{phrases} } );
	$t_line =~ s/\s+$//;
	return ( '', ', ', ', 




199




 





 





 





 





 





 



 		 '  




200




 





 





 





 





 





 



 		 '    ' . nhtml($t_line) . '




201




 





 





 





 





 





 



 		 '  




202




 





 





 





 





 





 



 		 '' );
		 '
		 '
		 '
		 '
    }

    if ( $::config->{settings}->{'chords-under'} ) {
	return ( '', ', ' } ', ', ' } ', 




207




 





 





 





 





 





 



 		 '  




208




 





 





 





 





 





 



 		 '    ' . join( '', 




209



  
0
  



  
  0
  




 





 





 





0



 				map { ( $_ =~ s/^\s+// ? '' : '' ) . nhtml($_) . '




210



  
0
  




 





 





 





 





0



 				( @{ $elt->{phrases} } ) ), 




211




 





 





 





 





 





 



 		 '  




212




 





 





 





 





 





 



 		 '  




213




 





 





 





 





 





 



 		 '    ' . join( '', 




214



  
0
  




 





 





 





 





0



 				map { '' . nhtml($_) . ' 




 




0





 





 





 





 





0



   




215




 





 





 





 





 





 



 				( @c ) ), 




216




 





 





 





 





 





 



 		 '  




217




 





 





 





 





 





 



 		 '' );
		 '
		 '    ' . join( '',
				map { ( $_ =~ s/^\s+// ? '
				( @{ $elt->{phrases} } ) ),
		 '
		 '
		 '    ' . join( '',
				map { '
				( @c ) ),
		 '
		 '
    }
    return ( '', ', ' } ', ', ' } ', 




220




 





 





 





 





 





 



 	     '  




221




 





 





 





 





 





 



 	     '    ' . join( '', 




222




66





 





 





 





 





113



 			    map { '' . nhtml($_) . ' 




223




 





 





 





 





 





 



 			    ( @c ) ), 




224




 





 





 





 





 





 



 	     '  




225




 





 





 





 





 





 



 	     '  




226




 





 





 





 





 





 



 	     '    ' . join( '', 




227




66




  
100
  




 





 





 





267



 			    map { ( $_ =~ s/^\s+// ? '' : '' ) . nhtml($_) . '




228




24





 





 





 





 





171



 			    ( @{ $elt->{phrases} } ) ), 




 




24





 





 





 





 





58



   




229




 





 





 





 





 





 



 	     '  




230




 





 





 





 





 





 



 	     '' );
	     '
	     '    ' . join( '',
			    map { '
			    ( @c ) ),
	     '
	     '
	     '    ' . join( '',
			    map { ( $_ =~ s/^\s+// ? '
			    ( @{ $elt->{phrases} } ) ),
	     '
	     '
}

sub nhtml {
    return unless defined $_[0];
    $layout->set_markup(shift);
    html($layout->render);
}

sub html {
    my $t = shift;
    $t =~ s/&/&/g;
    $t =~ s/
    $t =~ s/>/>/g;
    $t;
}

# Temporary. Eventually we'll have a decent HTML backend for Text::Layout.

package Text::Layout::Text;

use parent 'Text::Layout';

# Eliminate warning when HTML backend is loaded together with Text backend.
no warnings 'redefine';

sub new {
    my ( $pkg, @data ) = @_;
    my $self = $pkg->SUPER::new;
    $self;
}

sub render {
    my ( $self ) = @_;
    my $res = "";
    foreach my $fragment ( @{ $self->{_content} } ) {
	next unless length($fragment->{text});
	$res .= ChordPro::Utils::fq($fragment->{text});
    }
    $res;
}

1;