File Coverage

lib/ChordPro/Delegate/ABC.pm

Criterion	Covered	Total	%
statement	72	297	24.2
branch	7	150	4.6
condition	8	79	10.1
subroutine	18	31	58.0
pod	0	7	0.0
total	105	564	18.6

#!/usr/bin/perl

use v5.26;
use utf8;

package main;

our $config;
our $options;

package ChordPro::Delegate::ABC;

use strict;
use warnings;
use feature qw( signatures );
no warnings "experimental::signatures";
use utf8;
use Carp;
use File::Temp ();
use File::LoadLines;
use feature 'state';

use ChordPro::Files;
use ChordPro::Paths;
use ChordPro::Utils;
use Text::ParseWords qw(shellwords);

use constant { QUICKJS   => "QuickJS",
	       QUICKJSXS => "QuickJS_XS" };

sub DEBUG() { $config->{debug}->{abc} }

# ABC processing using abc2svg and custom SVG processor.
# See info() below how the method is determined.

# Song and PDF module uses 'can' to get at this.
sub can( $class, $method ) {
    if ( $method eq "options" ) {
	return \&options;
    }
    # abc2svg handlers are sorted out by info().
    return \&abc2svg;
}

# Default entry point.

sub abc2svg( $song, %args ) {

    my $abc2svg = info();

    if ( DEBUG() ) {
	::dump($abc2svg);
    }

    state $cfg_checked;
    unless ( $cfg_checked++ ) {
	if ( ($config->{delegates}{abc}{config} // "default") ne "default" ) {
	    warn("ABC: delegates.abc.config is no longer used.\n");
	    warn("ABC: Config \"default.abc\" will be loaded instead.\n")
	      if !$abc2svg->{external} && fs_test( s => "default.abc" );
	}
    }

    my ( $elt, $pw ) = @args{qw(elt pagewidth)};

    return { type => "ignore" } unless @{ $elt->{data} };
    # Bail out if we don't have a suitable program.
    unless ( $abc2svg->{method} ) {
	warn("Error in ABC embedding. Please install the JavaScript::QuickJS module.\n");
	return;
    }

    state $td = File::Temp::tempdir( CLEANUP => !$config->{debug}->{abc} );
    my $cfg = { %{$config->{delegates}->{abc} } };

    # External tools usually process a default.abc.
    warn("ABC: Using config \"default.abc\".\n")
      if index( $abc2svg->{method}, QUICKJSXS ) < 0 && fs_test( s => "default.abc" );

    my $prep = make_preprocessor( $cfg->{preprocess} );

    # Prepare names for temporary files.
    state $imgcnt = 0;
    $imgcnt++;
    my $src  = fn_catfile( $td, "tmp${imgcnt}.abc" );
    my $svg  = fn_catfile( $td, "tmp${imgcnt}.svg" );
    my $out  = fn_catfile( $td, "tmp${imgcnt}.out" );
    my $err  = fn_catfile( $td, "tmp${imgcnt}.err" );

    # Get rid of as much space as possible.
    # Jean-François Moine:
    # If you have both "%%stretchstaff 1" and "%%trimsvg 1", and
    # "%%stretchlast 0", only the final line is shorter.
    # Otherwise, you can have "%%trimsvg 1" as the last line of the tune.
    my @preamble =
      ( "%%topspace 0",
	"%%titlespace 0",
	"%%musicspace 0",
	"%%composerspace 0",
	"%%infospace 0",
	"%%textspace 0",
	"%%leftmargin 0cm",
	"%%rightmargin 0cm",
	"%%stretchstaff 1",
	"%%stretchlast 0",
	"%%trimsvg 1",
	"%%staffsep 0",
	@{ $cfg->{preamble}//[] } );

    for ( keys(%{$elt->{opts}}) ) {

	# Suppress meaningless transpositions. ChordPro uses them to enforce
	# certain chord renderings.
	next if $_ ne "transpose";
	my $x = $elt->{opts}->{$_} % @{ $config->{notes}->{sharp} };
	unshift( @preamble, '%%transpose'." $x" );
    }

    # Add mandatory field.
    my @pre;
    my @data = @{$elt->{data}};
    while ( @data ) {
	$_ = shift(@data);
	unshift( @data, $_ ), last if /^X:/;
	push( @pre, $_ );
    }
    if ( @pre && !@data ) {	# no X: found
	warn("X:1 (added)\n") if DEBUG;
	@data = ( "X:1", @pre );
	@pre = ();
    }
    my $kv = {};
    $kv = parse_kvm( @pre ) if @pre;
    $kv = { %$kv, %{$elt->{opts}} };
    $kv->{split} //= 1;		# less overhead. really.
    $kv->{scale} ||= 1;		# with id: design scale
    $kv->{align} //= ($kv->{center}//0) ? "center" : "left";
    if ( $kv->{width} ) {
	$pw = $kv->{width};
    }

    unshift( @preamble,
	     grep { /^%%/ } @pre,
	     $pw ? sprintf("%%%%pagewidth %dpx", $pw) : (),
	   );

    # Create the temp file for the ABC source.
    my $fd;
    unless ( $fd = fs_open( $src, '>:utf8' ) ) {
	warn("Error in ABC embedding: $src: $!\n");
	return;
    }

    # Copy. We assume the user knows how to write ABC.
    for ( @preamble ) {
	print $fd $_, "\n";
	warn($_, "\n") if DEBUG > 1;
    }
    for ( @data ) {
	$prep->{abc}->($_) if $prep->{abc};
	print $fd $_, "\n";
	warn($_, "\n") if DEBUG > 1;
    }
    for ( @{ $cfg->{postamble}//[] } ) {
	print $fd $_, "\n";
	warn($_, "\n") if DEBUG > 1;
    }

    unless ( close($fd) ) {
	warn("Error in ABC embedding: $src: $!\n");
	return;
    }

    my @lines;
    my $ret;

    if ( $abc2svg->{method} eq QUICKJSXS ) {

	# QuickJS with embedded interpreter.

	my $js = JavaScript::QuickJS->new;
	my $base = $abc2svg->{abclib} . "/abc2svg";
	$js->set_module_base($base);

	my $qjsdata =
	  {
	   print     => sub { push( @lines, split(/\n/, $_) ) for @_ },
	   printErr  => sub { print STDERR @_ },
	   quit      => sub { exit 66 },
	   readFile  => sub { slurp($_[0]) },
	   get_mtime => sub {
	       my @stat = stat($_[0]);
	       return @stat ? 1000*$stat[9] : undef;
	   },
	   loadjs    => sub {
	       my ( $fn, $relay, $onerror ) = @_;
	       if ( fs_test( sr => "$base/$fn" ) ) {
		   $js->eval(slurp("$base/$_[0]"));
		   $relay->() if $relay;
	       }
	       elsif ( $onerror ) {
		   $onerror->();
	       }
	       else {
		   warn( qq{loadjs("$fn"): $!\n} );
	       }
	   },
	  };

	$js->set_globals
	  ( args    => [ $src ],
	    load    => sub { $js->eval(slurp("$base/$_[0]")) },
	    abc2svg => $qjsdata,
	    abc     => {},	# for backends
	  );

	warn( "+ QuickJS_XS[", CP->display($base), "] $src\n") if DEBUG;
	my $hooks = "$base/../hooks.js";
	undef $hooks unless fs_test( s => $hooks );

	eval {
	    $js->eval( slurp("$base/abc2svg-1.js") );
	    $js->eval( slurp($hooks) ) if $hooks;
	    if ( -r "$base/../cmd.js" ) {
		warn(" QuickJS_XS using ", CP->display("$base/../cmd.js"),
		     $hooks ? "+hooks" : "", "\n" )
		  if DEBUG;
		$js->eval( slurp("$base/../cmd.js") );
	    }
	    else {
		warn(" QuickJS_XS using ", CP->display("$base/cmdline.js"),
		     $hooks ? "+hooks" : "", "\n" )
		  if DEBUG;
		$js->eval( slurp("$base/cmdline.js") );
	    }
	    $js->eval( slurp("$base/tohtml.js") );
	    $js->eval( qq{abc_cmd("ChordPro", args, "QuickJS_XS")} );
	};
	warn($@) if $@;
	undef $js;

	if ( DEBUG ) {
	    my $fd = fs_open( $out, '>:utf8' );
	    print $fd join("\n", @lines), "\n";
	    close($fd);
	}
    }

    elsif ( $abc2svg->{method} eq QUICKJS ) {

	# QuickJS with external interpreter.

	my @cmd = @{ $abc2svg->{command} };

	push( @cmd, $out, $src );
	if ( DEBUG ) {
	    warn( "+ @cmd\n" );
	    $ENV{CHORDPRO_ABC_DEBUG} = 1;
	}

	# Run the command.
	$ret = eval { sys( @cmd ) };

	# Load data.
	@lines = loadlines($out)
    }

    # Not packaged. Check for Wx on Windows since we cannot redirect STD***.
    elsif ( !is_wx() && !is_msw() ) {

	my @cmd = @{ $abc2svg->{command} };

	push( @cmd, $src );
	warn( "+ @cmd\n" ) if DEBUG;

	# Setup redirection for STDOUT/ERR.
	my ( $oldout, $olderr );
	open( $oldout, ">&STDOUT" )
	  or die "Can't dup STDOUT: $!";
	open( $olderr,     ">&", \*STDERR )
	  or die "Can't dup STDERR: $!";

	open(STDOUT, '>:utf8', $out)
	  or die "Can't redirect STDOUT: $!";
	open(STDERR, ">:utf8", $err)
	  or die "Can't dup STDERR: $!";

	select STDERR; $| = 1;  # make unbuffered
	select STDOUT; $| = 1;  # make unbuffered

	# Run the command.
	$ret = eval { sys(@cmd) };

	# Reconnect STDOUT/ERR.
	open(STDOUT, ">&", $oldout)
	  or die "Can't dup OLDOUT: $!";
	open(STDERR, ">&", $olderr)
	  or die "Can't dup OLDERR: $!";
	select STDERR; $| = 1;  # make unbuffered

	# Load data.
	@lines = loadlines($out);
    }

    else {
	my @cmd = @{ $abc2svg->{command} };
	push( @cmd, $src );
	if ( 0 ) {
	    # This seemed a good idea but unfortunately Wx has problems
	    # returning the UTF8 data correctly. Non-ASCII characters are
	    # crippled.
	    warn( "+ @cmd\n" ) if DEBUG;
	    ( $ret, $out, $err ) = Wx::ExecuteStdoutStderr( "@cmd", 32 );
	    warn("ABC: $_") for @$err;
	    @lines = @$out;
	}
	else {
	    # This will cause a console window flash, but at least we get
	    # the data right.
	    warn( "+ @cmd > $out\n" ) if DEBUG;
	    system( "@cmd > $out" );
	    @lines = loadlines($out);
	}
    }

    if ( $ret ) {
	warn( sprintf( "Error in ABC embedding (ret = 0x%x)\n", $ret ) );
	return;
    }
    if ( ! @lines ) {
	warn("Error in ABC embedding (no output?)\n");
	return;
    }
    warn("SVG: ", scalar(@lines), " lines (raw)\n") if DEBUG > 1;

    # Postprocess the SVG data.
    my $staffbase;
    my $copy = 0;
    @data = ();
    my $lines = 1;
    while ( @lines ) {
	$_ = shift(@lines);
	if ( /\