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


line stmt bran cond sub pod time code
1             package Pandoc::Filter::ImagesFromCode;
2 1     1   708 use strict;
  1         3  
  1         36  
3 1     1   7 use warnings;
  1         3  
  1         38  
4 1     1   7 use utf8;
  1         3  
  1         8  
5 1     1   672 use Encode;
  1         8650  
  1         60  
6 1     1   19 use 5.010;
  1         3  
7              
8             our $VERSION = '0.36';
9              
10 1     1   5 use Digest::MD5 'md5_hex';
  1         3  
  1         51  
11 1     1   6 use IPC::Run3;
  1         2  
  1         34  
12 1     1   4 use File::Spec::Functions;
  1         2  
  1         56  
13 1     1   396 use File::stat;
  1         5488  
  1         4  
14 1     1   52 use Pandoc::Elements;
  1         2  
  1         222  
15 1     1   7 use Scalar::Util 'reftype';
  1         1  
  1         56  
16 1     1   6 use parent 'Pandoc::Filter', 'Exporter';
  1         2  
  1         6  
17              
18             our @EXPORT_OK = qw(read_file write_file);
19              
20             sub new {
21 1     1 1 15 my ($class, %opts) = @_;
22              
23 1   50     3 $opts{from} //= 'code';
24 1   50     4 $opts{dir} //= '.';
25 1         3 $opts{dir} =~ s!/$!!;
26             $opts{name} //= sub {
27 1 50   1   5 $_[0]->id =~ /^[a-z0-9_]+$/i ? $_[0]->id
28             : md5_hex( encode( 'utf8', $_[0]->content ) );
29 1   50     8 };
30              
31 1 50       2 die "missing option: to\n" unless $opts{to};
32              
33 1 50 33     5 if ('ARRAY' ne reftype $opts{run} or !@{$opts{run}}) {
  1         4  
34 0         0 die "missing or empty option: run\n";
35             }
36              
37 1         3 bless \%opts, $class;
38             }
39              
40             sub to {
41 1     1 1 2 my $to = $_[0]->{to};
42 1         2 my $format = $_[1];
43 1 50       4 if (ref $to) {
    50          
44 0         0 return $to->($format);
45             } elsif ($to) {
46 1         4 return $to;
47             } else {
48 0         0 return 'png';
49             }
50             }
51              
52             sub action {
53 1     1 1 2 my $self = shift;
54              
55             sub {
56 1     1   3 my ($e, $format, $m) = @_;
57              
58 1 50       7 return if $e->name ne 'CodeBlock';
59              
60 1         25 my $code = $e->content;
61 1         6 my $dir = $self->{dir};
62              
63             my %args = (
64             name => $self->{name}->($e),
65             from => $self->{from},
66 1         3 to => $self->to($format),
67             );
68 1         9 $args{infile} = catfile($self->{dir}, "$args{name}.$args{from}");
69 1         6 $args{outfile} = catfile($self->{dir}, "$args{name}.$args{to}");
70              
71             # TODO: document or remove this experimental code. If keep, expand args
72 1         7 my $kv = $e->keyvals;
73 1         46 my @options = $kv->get_all('option');
74 1         17 push @options, map { split /\s+/, $_ } $kv->get_all('options');
  0         0  
75              
76             # TODO: print args in debug mode?
77              
78             # skip transformation if nothing has changed
79 1         16 my $in = stat($args{infile});
80 1         74 my $out = stat($args{outfile});
81 1 0 33     60 if (!$self->{force} and $in and $out and $in->mtime <= $out->mtime) {
      33        
      33        
82 0 0       0 if ($code eq read_file($args{infile}, ':utf8')) {
83             # no need to rebuild the same outfile
84 0         0 return build_image($e, $args{outfile});
85             }
86             }
87              
88 1         5 write_file($args{infile}, $code, ':utf8');
89              
90 1         3 my ($stderr, $stdout);
91             my @command = map {
92 2         4 my $s = $_;
93             #if ($args{substr $s, 1, -1})
94 2   33     8 $s =~ s|\$([^\$]+)\$| $args{$1} // $1 |eg;
  1         6  
95 2         6 $s
96 1         2 } @{$self->{run}};
  1         4  
97 1         2 push @command, @options;
98              
99 1         8 run3 \@command, \undef, \$stdout, \$stderr,
100             {
101             binmode_stdin => ':utf8',
102             binmode_stdout => ':raw',
103             binmode_stderr => ':raw',
104             };
105              
106 1 50       6355 if ($self->{capture}) {
107 1         40 write_file($args{outfile}, $stdout, ':raw');
108             }
109              
110             # TODO: include $code or $stderr on error in debug mode
111             # TODO: skip error if requested
112 1 50       12 die $stderr if $stderr;
113              
114 1         17 return build_image($e, $args{outfile});
115             }
116 1         8 }
117              
118             # build_image( $element [, $filename ] )
119             #
120             # Maps an element to an L element with attributes
121             # from the given element. The attribute C
, if available, is transformed
122             # into image caption. This utility function is useful for filters that transform
123             # content to images. See graphviz, tikz, lilypond and similar filters in the
124             # L.
125              
126             sub build_image {
127 1     1 0 6 my $e = shift;
128 1   50     13 my $filename = shift // '';
129              
130 1         24 my $keyvals = $e->keyvals;
131 1   50     95 my $title = $keyvals->get('title') // '';
132 1         19 my $img = Image attributes { id => $e->id, class => $e->class },
133             [], [$filename, $title];
134              
135 1   50     6 my $caption = $keyvals->get('caption') // '';
136 1 50       17 if (defined $caption) {
137 1         3 push @{$img->content}, Str($caption);
  1         26  
138             }
139              
140 1         15 return Plain [ $img ];
141             }
142              
143             sub write_file {
144 2     2 0 12 my ($file, $content, $encoding) = @_;
145              
146 2 50       140 open my $fh, ">$encoding", $file
147             or die "failed to create file $file: $!\n";
148 2         33 print $fh $content;
149 2         65 close $fh;
150             }
151              
152             sub read_file {
153 2     2 0 914 my ($file, $encoding) = @_;
154              
155 2 50       78 open my $fh, "<$encoding", $file
156             or die "failed to open file: $file: $!\n";
157              
158 2         6 my $content = do { local $/; <$fh> };
  2         12  
  2         51  
159 2 50       22 close $fh or die "failed to close file: $file: $!\n";
160              
161 2         19 return $content;
162             }
163              
164             1;
165              
166             __END__