#!/usr/bin/perl
use strict;
use Config;
use IPC::Open3;
use inc::Module::Install;
name('Language-MzScheme');
version_from('lib/Language/MzScheme.pm');
abstract_from('lib/Language/MzScheme.pm');
author('Autrijus Tang <autrijus@autrijus.org>');
license('perl');
build_requires('Test::More');
install_script('script/mzperl');
can_cc() or die "This module requires a C compiler";
my ($mz_version) = (run('mzscheme', '--version') =~ /([\d\.]+)/g)
or die "MzScheme not found - http://plt-scheme.org/software/mzscheme/";
my $plt_path = $ENV{PLT_PATH} || do {
my $show = run(qw(mzc --ldl-show --help))
or die 'Cannot run mzc; please set $ENV{PLT_PATH}';
$show =~ m!\("([^"]+)/lib/!i
or die 'Cannot find PLT path; please set $ENV{PLT_PATH}';
$1;
};
my $include = "$plt_path/include";
-d $include or die "Cannot find 'include' path under $plt_path; please set \$ENV{PLT_PATH}";
if (-e 'inc/.author') {
my ($swig_version) = (run('swig', '-version') =~ /([\d\.]+)/g)
or die "SWIG not found - http://www.swig.org/";
(v($swig_version) ge v('1.3.24'))
or die "SWIG 1.3.24+ not found - http://www.swig.org/";
make_h();
system(
'swig',
"-I$include",
qw(-noproxy -module Language::MzScheme -includeall -exportall -perl5 mzscheme.i)
);
unlink('lib/Language/MzScheme_in.pm');
rename('MzScheme.pm' => 'lib/Language/MzScheme_in.pm');
}
makemaker_args(
LIBS => "-L$plt_path/lib -lmzgc -lmzscheme",
INC => "-I$include",
OBJECT => "mzscheme_wrap$Config{obj_ext}",
);
WriteAll( sign => 1 );
sub make_h {
open IN, "$include/scheme.h" or die $!;
open OUT, "> mzscheme_wrap.h" or die $!;
while (<IN>) {
next if /^#include\b/;
next if /typedef struct Scheme_Jumpup_Buf \{/ .. /\} Scheme_Jumpup_Buf/;
next if /typedef struct Scheme_Thread \{/ .. /\} Scheme_Thread/;
next if /^MZ_EXTERN/;
print OUT $_;
}
close OUT;
close IN;
open IN, "$include/schemex.h" or die $!;
open OUT, ">> mzscheme_wrap.h" or die $!;
while (<IN>) {
next if /^#include\b/;
next if /^typedef struct \{/;
next if /^\} Scheme_Extension_Table;/;
s/\(\*(\w+)\)/$1/;
print OUT $_;
}
close OUT;
close IN;
open IN, "$include/stypes.h" or die $!;
open OUT, ">> mzscheme_wrap.h" or die $!;
while (<IN>) {
print OUT $_;
}
close OUT;
close IN;
}
sub make_c {
local $/;
open IN, "mzscheme_wrap.c" or die $!;
my $text = '';
while (<IN>) {
if (/^static\s+swig_type_info\s+_swigt__p_(Scheme_(\w+))\[\]/o){
my $fromType = $1;
my $toType = "Language::MzScheme::".munge($1);
print << "END";
static void *_p_${fromType}To_p_${toType}(void *x) {
return (void *)(($toType *) (($fromType *) x));
}
END
s/("$toType\s*\*"\}),/$1,{"_p_$fromType",_p_${fromType}To_p_${toType}},/;
}
$text .= $_;
}
close IN;
open OUT, "> mzscheme_wrap.c" or die $!;
print OUT $text;
close OUT;
}
sub munge {
my $func = shift;
$func =~ s/_(?:[A-Z])//g;
$func;
}
sub v {
my $v = shift;
join('', map chr, $v =~ /(\d+)/g);
}
sub run {
my ($wtr, $rdr, $err);
local $SIG{__WARN__} = sub { 1 };
my $pid = open3($wtr, $rdr, $err, @_);
my $out = join('', map $_ && readline($_), $rdr, $err);
chomp $out;
return $out;
}