#!../../perl
#
# usage: cliperl pkg cli.in cli.h cli.i init.i cli.xtra val.i set.i
#
# pkg string package name
# pfx string prefix name
# cli.in input from preprocessor (no comments)
# cli.h general header lines (fxn decl)
# cli.i the main code
# init.i the "glue" code
# cli.xtra misc. source code from .cli.out
# val.i code to get values of variables
# set.i code to set values of variables
#
# Fernando Trias
#
$pg=shift;
$pfx=shift;
open(IN,"<$ARGV[0]") || die "Input file $ARGV[0] not found";
open(HDR,">$ARGV[1]") || die "Can't open header file $ARGV[1]";
open(BODY,">$ARGV[2]") || die "Can't open $ARGV[2]";
open(INIT,">$ARGV[3]") || die "Can't open $ARGV[3]";
open(XTRA,">$ARGV[4]") || die "Can't open $ARGV[4]";
&init;
while(<IN>) {
next if /^#/;
/^CALL|^CASE/ && ( &docall, next );
/^VAR/ && ( &dovarline, next );
print XTRA $_;
}
&term;
close(IN);
close(HDR);
close(BODY);
close(INIT);
close(XTRA);
sub init {
}
sub term {
}
sub dovarline {
s/^VAR\s+//;
($type,$varn,$als,$dims)=&breakup($_);
if ($als =~ /^\d$/) {
$dims=$als; $alias="";
}
$als=$varn if $als eq "-";
$als=$varn unless $als;
if ($dims) {
for ($i=0;$i<$dims;$i++) {
$alias=$als.$i;
$var="$varn[$i]";
&dovar;
}
}
else {
$alias=$als; $var=$varn;
&dovar;
}
}
sub dovar {
print INIT
"newXS(\"${pg}::var_${alias}::TIESCALAR\",
${pfx}_var_${alias}_TIESCALAR,fn);\n";
print INIT
"newXS(\"${pg}::var_${alias}::FETCH\",
${pfx}_var_${alias}_FETCH,fn);\n";
print INIT
"newXS(\"${pg}::var_${alias}::STORE\",
${pfx}_var_${alias}_STORE,fn);\n";
# print INIT "\tMAGICVAR(\"$alias\",UV_$alias);\n";
# print HDR "\tUV_$alias,\n";
print HDR "extrn $type $var;\n";
print HDR "${pfx}_var_${alias}_TIESCALAR();\n";
print HDR "${pfx}_var_${alias}_FETCH();\n";
print HDR "${pfx}_var_${alias}_STORE();\n";
print BODY <<EOF;
XS(${pfx}_var_${alias}_TIESCALAR)
{
dXSARGS;
char *name;
SV *ret;
HV *stash;
name = SvPV(ST(1),na);
ret = newSVpv(name, strlen(name));
stash = gv_stashpv("${pg}::var_${alias}", 0);
ST(0) = sv_bless(newRV(ret), stash);
XSRETURN(1);
}
EOF
if ($type !~ /string/) {
print BODY <<EOF;
XS(${pfx}_var_${alias}_FETCH)
{
dXSARGS;
ST(0)=newSVnv((double) $var);
XSRETURN(1);
}
XS(${pfx}_var_${alias}_STORE)
{
dXSARGS;
$var = ($type) SvNV(ST(1));
ST(0)=ST(1);
XSRETURN(1);
}
EOF
}
else {
$slen=$type;
$slen =~ s/string\s*//;
$slen=1024 if $slen eq "";
$type="char *";
$cat=1;
print BODY <<EOF;
XS(${pfx}_var_${alias}_FETCH)
{
dXSARGS;
ST(0) = newSVpv($var, strlen($var));
XSRETURN(1);
}
XS(${pfx}_var_${alias}_STORE)
{
dXSARGS;
char *name;
name = SvPV(ST(1),na);
strncpy($var, name, $slen);
ST(0) = ST(1);
XSRETURN(1);
}
EOF
}
}
sub docall {
s/^\S+\s+//;
$init="";
$retx="";
$retfree="";
$callarg="";
$arglist="";
$count=-1;
$retvc=0;
($rettype,$call,$alias)=&breakup($_);
if ($call =~ s/^&//) {
$retfree.="\tfree(retval);\n" if $rettype ne "void";
}
$alias=$call unless $alias;
print INIT "newXS(\"${pg}::${alias}\",${pfx}_${alias},fn);\n";
print HDR "$pfx_$alias();\n";
if ($rettype =~ /string/) {
$rettype="char *";
$decl="\t$rettype retval;\n";
$retv="\tST(0)=sv_newmortal();\n\tsv_setpv(ST(0),retval);\n";
#$retv="\tXPUSHs(sv_2mortal(newSVpv(retval,strlen(retval))));";
$retvc++;
}
elsif ($rettype ne "void") {
$decl="\t$rettype retval;\n";
$retv="\tST(0)=sv_newmortal();\n\tsv_setnv(ST(0),(double)retval);\n";
#$retv="\tXPUSHs(sv_2mortal(newSVnv((double) retval)));";
$retvc++;
}
else { $decl=""; $retv=""; }
while(<IN>) {
last if /^END/;
($io,$type,$argx,$dims)=&breakup($_);
if ($dims) { $dimsv="[".$dims."]"; }
else { $dimsv=""; }
if ($argx =~ s/^&//) { $alloc=0; }
else { $alloc=1; }
if ($argx =~ /^=/) {
$_=$argx;
($argx,$initv)=/([^=]*)(.*)/;
} else { $initv=""; }
# $cat=0 for numeric; 1 for string
if ($type =~ /string/) {
$slen=$type;
$slen =~ s/string\s*//;
$slen=1024 if $slen eq "";
$type="char *";
$cat=1;
}
else { $cat=0; }
$decl.="\t$type $argx$dimsv$initv;\n";
if ($cat) {
if ( ($slen) && ($alloc || $io =~ /I/) ) {
$callarg.="$argx,";
}
else {
$callarg.="&$argx,";
}
}
else {
if ($dims) {
$callarg.="$argx,";
}
elsif ($io =~ /O/) {
$callarg.="&$argx,";
}
else {
$callarg.="$argx,";
}
}
if ($dims) {
for ($i=0; $i<$dims; $i++) {
$arg="${argx}[${i}]";
&doarg;
}
}
else {
$arg=$argx;
&doarg;
}
}
chop($arglist);
print BODY <<EOF;
XS(${pfx}_$alias)
{
dXSARGS;
if (items != $count + 1)
{ croak("Usage: &$alias($arglist)"); }
else {
EOF
print BODY $decl,"\n";
print BODY $init,"\n";
chop($callarg); # take out final ","
if ($rettype ne "void") {
print BODY "\tretval=($rettype)$call($callarg);\n";
}
else {
print BODY "\t(void)$call($callarg);\n";
}
print BODY $retx;
if ($retvc>1) {
print BODY <<EOF;
EXTEND(sp, $retvc);
EOF
}
print BODY $retv;
print BODY $retfree;
# if ($retvc) {
#print BODY "\tXSRETURN(1);\n";
#}
# else { print BODY "\tXSRETURN(1);\n"; }
print BODY "\t}\n";;
print BODY "\tXSRETURN(1);\n";
print BODY "}\n";
print BODY "\n\n";
}
sub doarg {
$count++ if $io =~ /[IO]/;
if ($cat) {
if ( ($slen) && ($alloc || $io =~ /I/) ) {
$init.="\t$arg=($type)malloc($slen);\n";
$init.="\tif ($arg==NULL) ";
$init.="\t{croak(\"Out of memory in $alias($arg)\"); XSRETURN(0);}\n";
}
$arglist.="\$$arg," if $io =~ /[IO]/;
$retfree.="\tfree($arg);\n";
if ( $io =~ /I/ ) {
$init.="\tstrncpy($arg,SvPV(ST($count),na),$slen);\n"
}
if ($io =~ /O/) {
$retx.="\tif (!SvREADONLY(ST($count)))\n";
$retx.="\t\tsv_setpv(ST($count),$arg);\n";
}
if ($io =~ /R/) {
$retv.="\tST($retvc)=sv_newmortal();\n";
$retv.="\tsv_setpv(ST($retvc),$arg);\n"; $retvc++;
}
}
else {
if ( $io =~ /O/ ) {
$init.="\t$arg = ($type) SvIV(ST($count));\n"
if $io =~ /I/;
$retx.="\tif (!SvREADONLY(ST($count)))\n";
$retx.="\t\tsv_setnv(ST($count), (double) $arg);\n";
$arglist.="\$$arg,";
if ( $io =~ /R/ ) {
$retv.="\tST($retvc)=sv_newmortal();\n";
$retv.="\tsv_setnv(ST($retvc),(double) $arg);\n"; $retvc++;
}
} else {
$arglist.="\$$arg," if /[IO]/;
$init.="\t$arg=SvIV(ST($count));\n"
if $io =~ /I/;
if ( $io =~ /R/ ) {
$retv.="\tST($retvc)=sv_newmortal();\n";
$retv.="\tsv_setnv(ST($retvc),(double) $arg);\n"; $retvc++;
}
}
}
}
sub breakup {
local ($_)=@_;
local(@r,$x,$xx,$count);
s/\s+$//;
while ($_ ne "") {
s/^\s+//;
if (/^\(/) {
$count=0; $xx="";
do {
if (/^\(/) { $count++; }
($x,$_)=/^(.[^\)\(]*)(.*)/;
$xx.=$x;
if (/^\)/) { $count--; }
} while ($count>0);
s/^.//;
push(@r,substr($xx,1));
}
else {
($xx,$_)=/^(\S+)(.*)/;
push(@r,$xx);
}
}
@r;
}