# $Id: serprocs.pm,v 1.5 1997/04/30 04:30:08 jake Exp $

#   Copyright 1997 Jake Donham <jake@organic.com>

#   You may distribute under the terms of either the GNU General
#   Public License or the Artistic License, as specified in the README
#   file.

# serprocs generates C stubs which are called by the RPC driver
# code. They convert arguments into the right thing and pass
# everything to callperl().

sub RPCL::Syntax::serprocs {}

sub RPCL::ProgramDef::serprocs {
    my ($self, $mod, $fh) = @_;
    foreach $ver (@{$self->versions}) {
	$ver->serprocs($mod, $fh);
    }
}

sub RPCL::Version::serprocs {
    my ($self, $mod, $fh) = @_;
    foreach $proc (@{$self->procedures}) {
	$proc->serprocs($mod, $self->value, $fh);
    }
}

sub RPCL::Type::freestruct {}

sub RPCL::StructDef::freestruct {
  my ($self) = @_;
  my $ctype = $self->ctype;
  return <<EOF

      if (ret) {
	xdr_free(xdr_$ctype, (char *)ret);
	free(ret);
      }
EOF
}

*{RPCL::UnionDef::freestruct} = \&RPCL::StructDef::freestruct;

sub RPCL::Procedure::serprocs {
  my ($self, $mod, $version, $fh) = @_;
  my $ret = $self->rettype->ctype . " *";
  my $arg = $self->argtype->ctype . " *";
  my $proc = lc($self->ident) . '_' . $version;
  my $argderef = $self->argtype->deref;
  my $retref = $self->rettype->ref;
  my $argcheck = &type_outcheck($self->argtype->perltype($mod), 'arg',
				"(${argderef}argp)")
    unless $arg eq 'void *';
  my $retcheck = &type_incheck($self->rettype->perltype($mod), 'pret', 'ret')
    unless $ret eq 'void *';
  my $rret = $ret;
  my $freestruct = $self->rettype->freestruct;

  # cancel the pointer if return needs to be dereferenced.
  if ($retref) {
    $rret =~ s/ \*$//;
  }

  if ($ret eq 'void *') {
    if ($arg eq 'void *') {
      print $fh <<EOF;
$ret
$proc($arg argp, struct svc_req *rqstp, SVCXPRT *transp)
{
    static char *result;
    callperl("$proc", 0, rqstp, transp, 0);
    return (void *)&result;
}

EOF
    }
    else {
      print $fh <<EOF;
$ret
$proc($arg argp, struct svc_req *rqstp, SVCXPRT *transp)
{
    SV *arg = sv_newmortal();
    static char *result;
$argcheck
    callperl("$proc", arg, rqstp, transp, 0);
    return (void *)&result;
}

EOF
    }
  }
  else {
    if ($arg eq 'void *') {
      print $fh <<EOF;
$ret
$proc($arg argp, struct svc_req *rqstp, SVCXPRT *transp)
{
    static SV *pret = 0;
    static $rret ret;

    if (pret) {$freestruct
      SvREFCNT_dec(pret);
    }
    pret = callperl("$proc", 0, rqstp, transp, 1);
$retcheck;
    return ${retref}ret;
}

EOF
    }
    else {
      print $fh <<EOF;
$ret
$proc($arg argp, struct svc_req *rqstp, SVCXPRT *transp)
{
    static SV *pret = 0;
    SV *arg = sv_newmortal();
    static $rret ret;

    if (pret) {$freestruct
      SvREFCNT_dec(pret);
    }
$argcheck
    pret = callperl("$proc", arg, rqstp, transp, 1);
$retcheck;
    return ${retref}ret;
}

EOF
    }
  }
}

# This is all kind of gory. It would be nice to have a typemap
# abstraction for manipulating them.

sub main::type_outcheck {
  my ($type, $arg, $var) = @_;
  my $kind = $main::type_kind{$type};
  $kind = $main::typemap{$type} unless $kind;
  warn("No typemap for $type") unless $kind;
  my $ntype = $type;
  $type =~ tr/:/_/;
  # first look in external typemap...
  my $expr = $main::output_expr{$kind};
  # then in the one we're generating.
  $expr = $main::typeout{$kind} unless $expr;
  warn("No OUTPUT for $kind") unless $expr;
  return eval qq/"$expr"/;
}

sub main::type_incheck {
  my ($type, $arg, $var) = @_;
  my $kind = $main::type_kind{$type};
  $kind = $main::typemap{$type} unless $kind;
  warn("No typemap for $type") unless $kind;
  my $ntype = $type;
  $type =~ tr/:/_/;
  # first look in external typemap...
  my $expr = $main::input_expr{$kind};
  # then in the one we're generating.
  $expr = $main::typein{$kind} unless $expr;
  warn("No INPUT for $kind") unless $expr;
  return eval qq/"$expr"/;
}

1;