sweavealike.pm

   1 #!/usr/bin/perl
   2 # Ikiwiki Sweave-alike plugin
   3 # under the terms of the GPL version 2, or any later version at your
   4 # option.
   5 # Copyright 2012 by Don Armstrong <don@donarmstrong.com>.
   6
   7
   8 package IkiWiki::Plugin::sweavealike;
   9
  10 =head1 NAME
  11
  12 sweavealike -- A Sweave-alike plugin which allows for embedding R code in IkiWiki
  13
  14 =head1 SYNOPSIS
  15
  16
  17 =head1 DESCRIPTION
  18
  19
  20 =head1 BUGS
  21
  22 None known.
  23
  24 =cut
  25
  26 use warnings;
  27 use strict;
  28
  29 use Statistics::R;
  30
  31 use IkiWiki '3.00';
  32
  33 use Encode qw(decode);
  34 use Digest::MD5 qw(md5_hex);
  35
  36 my $id = "sweavealike";
  37 sub import {
  38     hook(type => "getsetup", id => $id, call => \&getsetup);
  39     hook(type => "preprocess", id => $id, call => \&preprocess);
  40     hook(type => "htmlize", id => $id, call => \&htmlize);
  41     hook(type => "savestate", id => $id, call => \&savestate);
  42 }
  43
  44 sub getsetup {
  45     return(plugin => {safe => 1,
  46                       rebuild => 1,
  47                       section => "misc",
  48                       link => "http://git.donarmstrong.com/?p=ikiwiki_plugins.git;a=blob;f=sweavealike.pm;hb=HEAD",
  49                       description => "sweavealike plugin",
  50                      },
  51           );
  52 }
  53
  54 sub code_md5 {
  55     my ($code) = @_;
  56     return(md5_hex(decode('utf8',$code)));
  57 }
  58
  59 sub preprocess {
  60     my %param = @_;
  61
  62     if (not defined $pagestate{$param{page}}{$id}{R}) {
  63         $pagestate{$param{page}}{$id}{R} = Statistics::R->new(shared => 1)
  64             or error("Unable to create an R process");
  65     }
  66     # we currently don't bother to support anything but outputing the
  67     # entire segment of code and its R output
  68
  69     if (not exists $param{code}
  70         or not defined $param{code}
  71         or not length $param{code}) {
  72         error("There wasn't any R code supplied");
  73     }
  74
  75     $param{width} = '400' unless exists $param{width} and defined $param{width};
  76     $param{height} = '400' unless exists $param{height} and defined $param{height};
  77     for (qw(width height)) {
  78         if ($param{$_} !~ /^\d+$/) {
  79             error("invalid $_; must be an integer: $param{$_}");
  80         }
  81     }
  82     if (exists $param{picture}) {
  83         my $md5 = code_md5($param{code}."width=$param{width}height=$param{height}");
  84         my $page_esc = $params->{page};
  85         $page_esc =~ s/"/\\"/g;
  86         $pagestate{$param{page}}{$id}{R}->run(qq{png(filename="$page_esc",width=$param{width},height=$param{height});});
  87     }
  88     my $code_result;
  89     eval {
  90         $code_result = $pagestate{$param{page}}{$id}{R}->run($param{code});
  91     };
  92     if ($@) {
  93         error("code '$param{code}' produced error '$@'");
  94     }
  95     if (exists $param{picture}) {
  96         $pagestate{$param{page}}{$id}{R}->run(qq{dev.off();});
  97     }
  98     if (exists $param{nooutput}) {
  99         return('');
 100     }
 101     my $output = '';
 102     if (exists $param{echo}) {
 103         $output .= $param{code};
 104         $output =~ s/^/> /mg;
 105         $output .= "\n";
 106     }
 107     if (exists $param{results}) {
 108         $output .= $code_result;
 109     }
 110     if (exists $param{echo} or
 111         exists $param{results}) {
 112         $output =~ s/^/    /mg;
 113     }
 114     return($output);
 115 }
 116
 117 # stop any started R processes here
 118 sub htmlize {
 119     my %param = @_;
 120     if (exists $pagestate{$param{page}} and
 121         exists $pagestate{$param{page}}{$id} and
 122         exists $pagestate{$param{page}}{$id}{R}) {
 123         if (defined $pagestate{$param{page}}{$id}{R}
 124             and $pagestate{$param{page}}{$id}{R}->is_started()) {
 125             $pagestate{$param{page}}{$id}{R}->stop();
 126         }
 127         delete $pagestate{$param{page}}{$id}{R};
 128     }
 129 }
 130
 131 sub savestate {
 132     # make sure we never try to save an R process
 133     for my $page (keys %pagestate) {
 134         next unless exists $pagestate{$page}{$id};
 135         next unless exists $pagestate{$page}{$id}{R};
 136         if (defined $pagestate{$page}{$id}{R}
 137             and $pagestate{$page}{$id}{R}->is_started()) {
 138             $pagestate{$page}{$id}{R}->stop;
 139         }
 140         delete $pagestate{$page}{$id}{R};
 141     }
 142 }
 143
 144
 145
 146
 147
 148 1;
 149
 150
 151 __END__
 152
 153
 154
 155
 156
 157
 158
 159