File Coverage

blib/lib/Pandoc/Filter/ImagesFromCode.pm

Criterion	Covered	Total	%
statement	99	105	94.2
branch	12	28	42.8
condition	11	27	40.7
subroutine	20	20	100.0
pod	3	6	50.0
total	145	186	77.9

package Pandoc::Filter::ImagesFromCode;
use strict;
use warnings;
use utf8;
use Encode;
use 5.010;

our $VERSION = '0.36';

use Digest::MD5 'md5_hex';
use IPC::Run3;
use File::Spec::Functions;
use File::stat;
use Pandoc::Elements;
use Scalar::Util 'reftype';
use parent 'Pandoc::Filter', 'Exporter';

our @EXPORT_OK = qw(read_file write_file);

sub new {
    my ($class, %opts) = @_;

    $opts{from} //= 'code';
    $opts{dir} //= '.';
    $opts{dir} =~ s!/$!!;
    $opts{name} //= sub {
        $_[0]->id =~ /^[a-z0-9_]+$/i ? $_[0]->id
            : md5_hex( encode( 'utf8', $_[0]->content ) );
    };

    die "missing option: to\n" unless $opts{to};

    if ('ARRAY' ne reftype $opts{run} or !@{$opts{run}}) {
        die "missing or empty option: run\n";
    }

    bless \%opts, $class;
}

sub to {
    my $to     = $_[0]->{to};
    my $format = $_[1];
    if (ref $to) {
        return $to->($format);
    } elsif ($to) {
        return $to;
    } else {
        return 'png';
    }
}

sub action {
    my $self = shift;

    sub {
        my ($e, $format, $m) = @_;

        return if $e->name ne 'CodeBlock';

        my $code = $e->content;
        my $dir  = $self->{dir};

        my %args = (
            name => $self->{name}->($e),
            from => $self->{from},
            to   => $self->to($format),
        );
        $args{infile}  = catfile($self->{dir}, "$args{name}.$args{from}");
        $args{outfile} = catfile($self->{dir}, "$args{name}.$args{to}");

        # TODO: document or remove this experimental code. If keep, expand args
        my $kv = $e->keyvals;
        my @options = $kv->get_all('option');
        push @options, map { split /\s+/, $_ } $kv->get_all('options');

        # TODO: print args in debug mode?

        # skip transformation if nothing has changed
        my $in  = stat($args{infile});
        my $out = stat($args{outfile});
        if (!$self->{force} and $in and $out and $in->mtime <= $out->mtime) {
            if ($code eq read_file($args{infile}, ':utf8')) {
                # no need to rebuild the same outfile
                return build_image($e, $args{outfile});
            }
        }

        write_file($args{infile}, $code, ':utf8');

        my ($stderr, $stdout);
        my @command = map {
                  my $s = $_;
                  #if ($args{substr $s, 1, -1})
                  $s =~ s|\$([^\$]+)\$| $args{$1} // $1 |eg;
                  $s
                } @{$self->{run}};
        push @command, @options;

        run3 \@command, \undef, \$stdout, \$stderr,
            {
                binmode_stdin  => ':utf8',
                binmode_stdout => ':raw',
                binmode_stderr => ':raw',
            };

        if ($self->{capture}) {
            write_file($args{outfile}, $stdout, ':raw');
        }

        # TODO: include $code or $stderr on error in debug mode
        # TODO: skip error if requested
        die $stderr if $stderr;

        return build_image($e, $args{outfile});
    }
}

# build_image( $element [, $filename ] )
#
# Maps an element to an L element with attributes
# from the given element. The attribute C
# into image caption. This utility function is useful for filters that transform
# content to images. See graphviz, tikz, lilypond and similar filters in the
# L.

sub build_image {
    my $e = shift;
    my $filename = shift // '';

    my $keyvals = $e->keyvals;
    my $title = $keyvals->get('title') // '';
    my $img = Image attributes { id => $e->id, class => $e->class },
        [], [$filename, $title];

    my $caption = $keyvals->get('caption') // '';
    if (defined $caption) {
        push @{$img->content}, Str($caption);
    }

    return Plain [ $img ];
}

sub write_file {
    my ($file, $content, $encoding) = @_;

    open my $fh, ">$encoding", $file
        or die "failed to create file $file: $!\n";
    print $fh $content;
    close $fh;
}

sub read_file {
    my ($file, $encoding) = @_;

    open my $fh, "<$encoding", $file
        or die "failed to open file: $file: $!\n";

    my $content = do { local $/; <$fh> };
    close $fh or die "failed to close file: $file: $!\n";

    return $content;
}

1;

__END__