use Config;
use File::Basename qw(&basename &dirname);
chdir dirname($0);
$file = basename($0, '.PL');
open(OUT, "> $file") || die "Can't create $file: $!";
print "Extracting $file (with variable substitutions)\n";
print OUT <<"!GROK!THIS!";
$Config{startperl}
eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
!GROK!THIS!
print OUT <<'!NO!SUBS!';
# $Id: perlrpcgen.PL,v 1.4 1997/05/01 22:06:47 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.
use perlrpcgen::RPCLParser;
use perlrpcgen::Fstream;
use perlrpcgen::RPCL::cliprocs;
use perlrpcgen::RPCL::fix_typenames;
use perlrpcgen::RPCL::gen_constants;
use perlrpcgen::RPCL::gen_typemap;
use perlrpcgen::RPCL::serprocs;
use perlrpcgen::RPCL::structprocs;
use perlrpcgen::RPCL::types;
use Getopt::Long;
# -----------------------------------------------------------------------------
# main
sub usage {
print STDERR <<EOF;
Usage: perlrpcgen [--makefile] [--all] [--client] [--server] [--data]
[--constants] [--module mod] [--typemap tm] [--fork]
[--perl p] [--cc cc] [--rpclibs libs] rpcfile.x
EOF
exit(1);
}
# -----------------------------------------------------------------------------
# main
# used by typemap code
$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
# typemaps for T_PTROBJs which also accept undef for the null pointer.
$t_ptrubj_in = <<'EOF';
if (sv_derived_from($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = ($type) tmp;
}
else if ($arg == &sv_undef)
$var = ($type) 0;
else
croak(\"$var is not of type ${ntype}\")
EOF
$t_ptrubj_out = <<'EOF';
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
EOF
$dirmode = 0755;
@orig_argv = @ARGV;
&GetOptions('module=s' => \$module,
'typemap=s@' => \@typemaps,
'makefile' => \$makefile,
'perl=s' => \$perl,
'cc=s' => \$cc,
'rpclibs=s' => \$rpclibs,
'all' => \$all,
'client' => \$client,
'server' => \$server,
'data' => \$data,
'constants' => \$constants,
'fork' => \$fork);
&usage unless $ARGV[0];
$intfile = $ARGV[0];
$intfile =~ s/\.x$//; # strip trailing .x
$module = $intfile unless $module;
!NO!SUBS!
print OUT <<"!GROK!THIS!";
\$perl = '$Config{perlpath}' unless \$perl;
\$cc = '$Config{cc}' unless \$cc;
!GROK!THIS!
print OUT <<'!NO!SUBS!';
$rpclibs = '-lrpcsvc -lnsl' unless $rpclibs;
if ($all) {
$client = 1;
$server = 1;
$data = 1;
$constants = 1;
}
if ($makefile) {
&do_makefile;
}
else {
$interface = &read_interface($ARGV[0]);
# collapse all the typenames and typedefs
foreach $def (@$interface) {
$def = $def->fix_typenames;
}
# topologically sort the type graph so that typemaps which depend on
# one another come out right.
my $marks = {};
my $order = [];
foreach $def (@$interface) {
$def->topo_sort($marks, $order) unless $marks->{$def};
}
# generate the typemaps.
$typein{'T_PTRUBJ'} = $t_ptrubj_in;
$typeout{'T_PTRUBJ'} = $t_ptrubj_out;
foreach $def (@$order) {
$def->gen_typemap($module);
}
# generate the constants.
foreach $def (@$interface) {
$def->gen_constants;
@constants = sort @constants;
}
mkdir($module, $dirmode);
&do_typemap;
&do_typedefs;
&do_root_makefile;
if ($data) {
mkdir("$module/Data", $dirmode);
&do_data_xs;
&do_data_perlmod;
&do_data_makefile;
}
if ($constants) {
mkdir("$module/Constants", $dirmode);
&do_constants_perlmod;
&do_constants_xs;
&do_constants_makefile;
}
if ($client) {
mkdir("$module/Client", $dirmode);
&do_client_xs;
&do_client_perlmod;
&do_client_makefile;
}
if ($server) {
mkdir("$module/server", $dirmode);
# push(@typemaps, "$module/typemap");
&read_typemaps(@typemaps);
&do_server;
&do_server_makefile;
}
}
# -----------------------------------------------------------------------------
# Read the interface definition and return a syntax tree
sub read_interface {
my ($fn) = @_;
open (INT, $fn) || die $!;
$s = Fstream->new(\*INT, $fn);
$p = RPCLParser->new(\&RPCLParser::yylex, \&RPCLParser::yyerror, 0);
my $interface = $p->yyparse($s);
close INT;
return $interface;
}
# -----------------------------------------------------------------------------
# Write the typemap.
sub do_typemap {
open (FH, "> $module/typemap") || die $!;
print FH "# Generated by perlrpcgen.\n";
print FH "TYPEMAP\n";
foreach $name (keys %typemap) {
print FH $name . "\t" . $typemap{$name} . "\n";
}
print FH "RPC::ONC::Client\tT_PTROBJ\n";
print FH "\nINPUT\n";
foreach $name (keys %typein) {
print FH $name . "\n" . $typein{$name};
}
print FH "\nOUTPUT\n";
foreach $name (keys %typeout) {
print FH $name . "\n" . $typeout{$name};
}
close FH;
}
# -----------------------------------------------------------------------------
# Write typedefs.h
sub do_typedefs {
open (FH, "> $module/typedefs.h") || die $!;
print FH "/* Generated by perlrpcgen. */\n";
foreach $name (keys %structs) {
print FH $structs{$name} . ";\n";
}
foreach $name (keys %typedef) {
my $cname = $name;
$cname =~ s/::/__/;
print FH "typedef " . $typedef{$name} . "\t" . $cname . ";\n";
}
print FH "typedef CLIENT *\tRPC__ONC__Client;\n";
close FH;
}
# -----------------------------------------------------------------------------
# Write the common data structure code.
sub do_data_xs {
open (FH, "> $module/Data/Data.xs") || die $!;
print FH <<EOF;
/* Generated by perlrpcgen. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "$intfile.h"
#include "typedefs.h"
#include <rpc/rpc.h>
MODULE = ${module}::Data\tPACKAGE = ${module}::Data
PROTOTYPES: DISABLE
EOF
foreach $def (@$interface) {
$def->structprocs($module, \*FH);
}
close FH;
}
# -----------------------------------------------------------------------------
# Write the client code.
sub do_client_xs {
open (FH, "> $module/Client/Client.xs") || die $!;
print FH <<EOF;
/* Generated by perlrpcgen. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "$intfile.h"
#include "typedefs.h"
#include <rpc/rpc.h>
/* kinda stupid to put this in every client module, but I'm not sure
how to get to symbols in another shared object library */
void set_perl_error(int errno, char *errstr)
{
static SV *sv_errno = 0;
static SV *sv_errstr = 0;
if (!sv_errno) sv_errno = perl_get_sv("RPC::ONC::errno", TRUE);
if (!sv_errstr) sv_errstr = perl_get_sv("RPC::ONC::errstr", TRUE);
sv_setiv(sv_errno, (IV) errno);
sv_setpv(sv_errstr, errstr);
}
void set_perl_error_clnt(CLIENT *clnt)
{
struct rpc_err err;
clnt_geterr(clnt, &err);
set_perl_error(err.re_status, clnt_sperrno(err.re_status));
}
MODULE = ${module}::Client\tPACKAGE = ${module}::Client
PROTOTYPES: DISABLE
EOF
foreach $def (@$interface) {
$def->cliprocs($module, \*FH);
}
close FH;
}
# -----------------------------------------------------------------------------
# Write the server code.
sub do_server {
open (FH, "> $module/server/server.c") || die $!;
print FH <<EOF;
/* Generated by perlrpcgen. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "$intfile.h"
#include "typedefs.h"
#include <syslog.h>
#include <rpc/rpc.h>
static PerlInterpreter *my_perl;
extern void xs_init();
void initperl(int argc, char **argv)
{
int ret;
my_perl = perl_alloc();
perl_construct(my_perl);
if ((ret = perl_parse(my_perl, xs_init, argc, argv, 0)) != 0)
exit(ret);
if ((ret = perl_run(my_perl)) != 0)
exit(ret);
}
SV *callperl(char *func, SV *arg, struct svc_req *rqstp, SVCXPRT *transp,
int checkarg)
{
SV *ret, *req = sv_newmortal(), *tr = sv_newmortal();
int count;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(sp);
sv_setref_pv(req, "RPC::ONC::svc_req", (void *)rqstp);
sv_setref_pv(tr, "RPC::ONC::Svcxprt", (void *)transp);
if (arg) {
XPUSHs(arg);
}
XPUSHs(req);
XPUSHs(tr);
PUTBACK;
count = perl_call_pv(func, G_SCALAR|G_EVAL);
SPAGAIN;
if (checkarg && count != 1)
croak("subroutine did not return 1 argument");
ret = POPs;
SvREFCNT_inc(ret);
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
EOF
foreach $def (@$interface) {
$def->serprocs($module, \*FH);
}
close FH;
}
# -----------------------------------------------------------------------------
# Write the constants code (borrowed from h2xs).
sub do_constants_xs {
open (FH, "> $module/Constants/Constants.xs") || die $!;
print FH <<EOF;
/* Generated by perlrpcgen. */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "$intfile.h"
static int
constant(char *name, int arg)
{
errno = 0;
switch (*name) {
EOF
foreach(@constants){
@AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
@az = 'a' .. 'z' if !@az && /^[a-z]/;
@under = '_' if !@under && /^_/;
}
foreach $letter (@AZ, @az, @under) {
last if $letter eq 'a' && !@constants;
print FH " case '$letter':\n";
my($name);
while (substr($constants[0],0,1) eq $letter) {
$name = shift(@constants);
print FH <<"END";
if (strEQ(name, "$name"))
return $name;
END
}
print FH <<"END";
break;
END
}
print FH <<"END";
}
errno = EINVAL;
return 0;
}
MODULE = ${module}::Constants PACKAGE = ${module}::Constants
PROTOTYPES: DISABLE
int
constant(name,arg)
char * name
int arg
END
close FH;
}
# -----------------------------------------------------------------------------
# Write the Perl modules
sub do_data_perlmod {
open (FH, "> $module/Data/Data.pm") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
package ${module}::Data;
use Exporter;
use DynaLoader;
\@ISA = qw(Exporter DynaLoader);
bootstrap ${module}::Data;
1;
EOF
close FH;
}
sub RPCL::Syntax::progvers { () }
sub RPCL::ProgramDef::progvers {
my ($self) = @_;
return ($self->ident, $self->versions->[0]->ident);
}
sub do_client_perlmod {
open (FH, "> $module/Client/Client.pm") || die $!;
my ($prog, $vers);
foreach $def (@$interface) {
last if ($prog, $vers) = $def->progvers;
}
print FH <<EOF;
# Generated by perlrpcgen.
package ${module}::Client;
use Exporter;
use DynaLoader;
use RPC::ONC;
use ${module}::Constants;
\@ISA = qw(Exporter DynaLoader RPC::ONC::Client);
bootstrap ${module}::Client;
sub new {
my (\$class, \$server, \$prot, \$prog, \$vers) = \@_;
\$prot = 'netpath' unless \$prot;
\$prog = $prog unless \$prog;
\$vers = $vers unless \$vers;
my \$client =
&RPC::ONC::Client::clnt_create(\$server, \$prog, \$vers, \$prot);
bless \$client, \$class;
}
EOF
print FH <<EOF;
1;
EOF
close FH;
}
# based on h2xs
sub do_constants_perlmod {
my ($kind) = @_;
open (FH, "> $module/Constants/Constants.pm") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
package ${module}::Constants;
use Exporter;
use DynaLoader;
use AutoLoader;
\@ISA = qw(Exporter AutoLoader DynaLoader);
\@EXPORT = qw(
@constants
);
sub AUTOLOAD {
local(\$constname);
(\$constname = \$AUTOLOAD) =~ s/.*:://;
\$val = constant(\$constname, \@_ ? \$_[0] : 0);
if (\$! != 0) {
\$AutoLoader::AUTOLOAD = \$AUTOLOAD;
goto &AutoLoader::AUTOLOAD;
}
eval "sub \$AUTOLOAD { \$val }";
goto &\$AUTOLOAD;
}
bootstrap ${module}::Constants;
1;
__END__
EOF
close FH;
}
# -----------------------------------------------------------------------------
# Write the Makefile.PLs
sub do_root_makefile {
open (FH, "> $module/Makefile.PL") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => '${module}',
'VERSION' => '0.1',
'OPTIMIZE' => '-g',
);
EOF
close FH;
}
sub do_data_makefile {
open (FH, "> $module/Data/Makefile.PL") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => '${module}::Data',
'VERSION' => '0.1',
'INC' => '-I.. -I../..',
'CC' => '$cc',
'LD' => '$cc',
);
EOF
close FH;
}
sub do_constants_makefile {
open (FH, "> $module/Constants/Makefile.PL") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => '${module}::Constants',
'VERSION' => '0.1',
'INC' => '-I.. -I../..',
'CC' => '$cc',
'LD' => '$cc',
);
EOF
close FH;
}
sub do_client_makefile {
open (FH, "> $module/Client/Makefile.PL") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => '${module}::Client',
'VERSION' => '0.1',
'LIBS' => ['-lrpcsvc -lnsl'],
'INC' => '-I.. -I../..',
'CC' => '$cc',
'LD' => '$cc',
'LDFROM' => 'Client.o ../../${intfile}_xdr.o ../../${intfile}_clnt.o',
);
EOF
close FH;
}
sub do_server_makefile {
open (FH, "> $module/server/Makefile") || die $!;
print FH <<EOF;
# Generated by perlrpcgen.
CC=$cc
RPCLIBS=$rpclibs
PERL=$perl
MOD=$module
INT=$intfile
CPPFLAGS=-I.. -I../..
CFLAGS=`\$(PERL) -MExtUtils::Embed -e ccopts` -g
LDFLAGS=`\$(PERL) -MExtUtils::Embed -e ldopts`
perlxsi.c:
\$(PERL) -MExtUtils::Embed -e xsinit --
\$(INT)_svc: ../../\$(INT)_svc.o server.o perlxsi.o
\$(CC) -o \$(INT)_svc server.o perlxsi.o \\
../../\$(INT)_xdr.o ../../\$(INT)_svc.o \\
\$(RPCLIBS) \$(CFLAGS) \$(LDFLAGS)
EOF
close FH;
}
sub do_makefile {
open (FH, "> Makefile") || die $!;
pop @orig_argv; # remove $intfile.x
@orig_argv = grep { $_ !~ /-ma/ } @orig_argv; # remove -makefile
my $opts = join(' ', map { "'$_'" } @orig_argv);
my $serv = ($server ? "\$(MOD)/server/\$(INT)_svc" : '');
my $forkfix = '';
if ($fork) {
$forkfix = "-e 's/result = (/if (!fork()) { _rpcsvccount--; " .
"_rpcsvcstate = _SERVED; return; }; result = (/' \\\n\t " .
"-e 's/^\treturn/\texit(0)/'\\\n\t";
}
print FH<<EOF;
# Generated by perlrpcgen.
INT=$intfile
MOD=$module
CC=$cc
PERL=$perl
PERLRPCGEN=$0
RPCLIBS=$rpclibs
CFLAGS=-g
all: .perlmods $serv
.perlrpcgen: \$(INT).x
\$(PERLRPCGEN) $opts -typemap \\
`\$(PERL) -MConfig -e 'print "\$\$Config{privlib}/ExtUtils/typemap"'` \\
\$(INT).x
touch .perlrpcgen
.Makefiles: .perlrpcgen
cd \$(MOD); \$(PERL) Makefile.PL
touch .Makefiles
\$(INT)_xdr.c \$(INT)_clnt.c \$(INT)_svc.c: \$(INT).x
rpcgen \$(INT).x
mv \$(INT)_svc.c \$(INT)_svc.c~
sed -e "s/svc_run();/initperl(argc, argv); svc_run();/" \\
-e "s/main()/main(int argc, char **argv)/" \\
-e "s/for (i = 0;/\\/*for (i=0;/" \\
-e "s/(i, 2);/(i, 2);\\*\\//" \\
-e "s/rqstp)/rqstp, transp)/" \\
$forkfix< \$(INT)_svc.c~ > \$(INT)_svc.c
.perlmods: .Makefiles \$(INT)_xdr.o \$(INT)_clnt.o
cd \$(MOD); make
touch .perlmods
\$(MOD)/server/\$(INT)_svc: .perlrpcgen \$(INT)_svc.o
cd \$(MOD)/server; make \$(INT)_svc
tidy:
rm -f *~ "#*" core
clean: tidy
rm -f .perlrpcgen .Makefiles .perlmods
rm -f *.h *.c *.o
rm -rf \$(MOD)
install: all
cd \$(MOD); make install
EOF
close FH;
}
# -----------------------------------------------------------------------------
# Code to deal with typemaps (taken from xsubpp). It would be nice to
# have a more general embedpp that would generate embedding stubs from
# typemaps and some kind of embedding language.
sub read_typemaps {
my (@tm) = @_;
my ($mode, $junk, $current, $proto);
foreach $typemap (@tm) {
next unless -e $typemap ;
warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
unless -T $typemap ;
open(TYPEMAP, $typemap)
or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
$mode = 'Typemap';
$junk = "" ;
$current = \$junk;
while (<TYPEMAP>) {
next if /^\s*#/;
my $line_no = $. + 1;
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
if ($mode eq 'Typemap') {
chomp;
my $line = $_ ;
TrimWhitespace($_) ;
# skip blank lines and comment lines
next if /^$/ or /^#/ ;
my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
$type = TidyType($type) ;
$type_kind{$type} = $kind ;
# prototype defaults to '$'
$proto = "\$" unless $proto ;
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
}
elsif (/^\s/) {
$$current .= $_;
}
elsif ($mode eq 'Input') {
s/\s+$//;
$input_expr{$_} = '';
$current = \$input_expr{$_};
}
else {
s/\s+$//;
$output_expr{$_} = '';
$current = \$output_expr{$_};
}
}
close(TYPEMAP);
}
foreach $key (keys %input_expr) {
$input_expr{$key} =~ s/\n+$//;
}
}
sub TrimWhitespace
{
$_[0] =~ s/^\s+|\s+$//go ;
}
sub TidyType
{
local ($_) = @_ ;
# rationalise any '*' by joining them into bunches and removing whitespace
s#\s*(\*+)\s*#$1#g;
s#(\*+)# $1 #g ;
# change multiple whitespace into a single space
s/\s+/ /g ;
# trim leading & trailing whitespace
TrimWhitespace($_) ;
$_ ;
}
sub ValidProtoString ($)
{
my($string) = @_ ;
if ( $string =~ /^$proto_re+$/ ) {
return $string ;
}
return 0 ;
}
sub C_string ($)
{
my($string) = @_ ;
$string =~ s[\\][\\\\]g ;
$string ;
}
__END__
=head1 NAME
perlrpcgen - generate Perl interfaces from ONC RPC interface definitions
=head1 SYNOPSIS
B<perlrpcgen> [B<--makefile>] [B<--all>] [B<--client>] [B<--server>]
[B<--data>] [B<--constants>] [B<--module> module] [B<--typemap>
typemap] [B<--fork>] [B<--perl> perl] [B<--cc> cc] [B<--rpclibs>
rpclibs] rpcfile.x
=head1 DESCRIPTION
I<perlrpcgen> builds a set of Perl extensions and a server shell from
an ONC RPC interface definition. For an interface Foo, I<perlrpcgen>
creates modules Foo::Client, Foo::Data, and
Foo::Constants. Foo::Client contains routines for creating a Foo
client and making remote procedure calls via the client. Foo::Data
contains routines for creating and manipulating the data structures
defined in the Foo interface. Foo::Constants contains functions to
retrieve the constants defined in the Foo interface.
=head1 OPTIONS
The option parsing uses Getopt::Long, so you can abbreviate option
names.
=over 4
=item B<--makefile>
Generates a top-level Makefile which will build all the
pieces. Include all the other options you want so they'll be
propagated to the Makefile.
=item B<--all>
Implies --client, --server, --data, and --constants. This is usually
what you want.
=item B<--client>
Generates Foo::Client module.
=item B<--server>
Generates Foo/server/foo_svc.
=item B<--data>
Generates Foo::Data module.
=item B<--constants>
Generates Foo::Constants module.
=item B<--module> module
Sets the basename of the modules. If not given, the name defaults to
the basename of the interface file.
=item B<--typemap> typemap
Uses the given typemap during stub generation. This option can be
specified many times. I<perlrpcgen> generates a typemap for the data
structures in the interface, but you also need the main Perl typemap.
=item B<--fork>
Munges the server shell code so that it forks for each request. You
probably don't want to do this (it's better to prefork several
processes when you start the server and let them fight over accept()
calls).
=item B<--perl> perl
Sets the Perl binary against which extensions should be
built. Defaults to the Perl you used to install I<perlrpcgen>.
=item B<--cc> cc
Sets the C compiler to use. Defaults to the compiler used when
building Perl.
=item B<--rpclibs> rpclibs
Sets the RPC libraries to link against. Defaults to '-lnsl -lrpcsvc'.
=back
=head1 MODULES
=head2 Foo::Client
RPC clients and the procedure calls they support are encapsulated in
Foo::Client objects (which inherit from RPC::ONC::Client).
A new Foo::Client can be created like this:
$foo = Foo::Client->new($server, $prot, $prog, $vers);
$prot, $prog, and $vers are optional, and will default to 'netpath',
the value of the first 'program' declaration in the interface, and the
value of the first 'version' declaration in the interface,
respectively.
If the client creation fails, the constructor will set
$RPC::ONC::errno and $RPC::ONC::errstr to the error number and error
string, respectively, and croak.
For each procedure there is a method with the same name (with an
underscore and the version number appended as in C). Methods are
called like this:
$val = $foo->someproc_1($arg);
$arg must be an object of the correct type as given in the interface
definition (see Foo::Data for details), or nothing if the interface
specifies a 'void' argument. If the remote procedure call fails, the
method will set $RPC::ONC::errno and $RPC::ONC::errstr and croak.
You'll need to use RPC::ONC, Foo::Data, Foo::Constants, and
Foo::Client in your client code.
=head2 Foo::Data
For each structure and union definition 'bar' in the interface
definition, I<perlrpcgen> creates a package in the Foo::Data module
called Foo::bar. (If your interface contains an anonymous structure or
union you'll get a package with an arbitrary name--you'll have to
check out the Foo::Data module to see what it is. A warning would be
nice here.)
You can create a new Foo::bar object like this:
$bar = Foo::bar->new;
$bar2 = Foo::bar->new($bar);
The first form creates an uninitialized object. The second form
initializes an object by doing a shallow copy of another object. Be
careful; you can cause coredumps and other weird behavior if you try
to get an uninitialized field from a structure or return a structure
with any uninitialized fields to a client (in that case the XDR
routine for the structure will blow up). Finally, there's nothing
stopping you from setting or retrieving the wrong type from a union
(this may be fixed in a future version), and you can coredump that way
too.
For each field in a structure or union (including the discriminant of
a union) there is a getter (with the same name) that returns the value
of the field, and a setter (with the same name prepended with 'set_')
which takes an argument of the appropriate type and sets the
field. For fields which are structures or unions themselves, the
getter returns a reference to the field, so if you set the fields on
this sub-structure you'll side-effect the super-structure.
In order to avoid having to doink around with various levels of
indirection (as in C), all structures and unions are passed by
reference, and multiple indirections are collapsed into one. So you
can do $foo->set_bar($baz) whether foo is a structure, a pointer to a
structure, a pointer to a pointer to a structure, etc.
As part of this magic, all the typedefs are collapsed as well. So if
your interface has, say, 'typedef bar *quux' and a particular
procedure calls for a 'quux', pass it a Foo::bar from Perl--there is
no Perl type corresponding to 'quux'. (This is perhaps less of a good
thing than the pointer collapsing but I couldn't see a simple way to
do one without the other.)
Finally, functions which call for a pointer to a structure or union
may be passed undef, which translates to a NULL pointer.
Types are converted from their XDR/RPC definitions as follows:
=over 4
=item int, unsigned int, enum
Become Perl numbers.
=item string, opaque
Become Perl strings (and are length-checked if a length is specified).
=item struct, union
Become Perl objects as described above.
=item bar[], bar<>
Become Perl arrays of Foo::bar objects (and are length-checked if a
length is specified).
=back
=head2 Foo::Constants
All the constants (including enums and identifiers for 'program' and
'version' definitions) defined in the interface are available via
Foo::Constants (and are imported by default).
=head2 Server
I<perlrpcgen> creates a server shell which embeds Perl. To implement
the procedure calls, you must define a function in the main package
for each procedure defined in the interface (as in C, they should have
the same names with an underscore and the version number appended).
These functions are called as follows:
$val = someproc_1($arg, $svc_req, $transp);
$val = someproc_1($svc_req, $transp);
$arg is the procedure argument (of the appropriate type) or nothing if
the procedure is declared to take 'void'. $svc_req is an
RPC::ONC::svc_req object (see RPC::ONC) through which the client's
credentials can be accessed. $transp is an RPC::ONC::Svcxprt object
(see RPC::ONC) through which the client's IP address can be accessed.
You'll need to use RPC::ONC, Foo::Data, and Foo::Constants, but don't
try to use Foo::Client in a server, because you'll get symbol
conflicts.
The command line arguments are passed unchanged to Perl. Usually you
start a server with something like:
Foo/server/foo_svc Foo.pl
If you're planning to write a lot of servers you might want to build
Perl with a shared libperl.
=head1 AUTHOR
Jake Donham <jake@organic.com>
=head1 THANKS
Thanks to Organic Online <http://www.organic.com/> for letting me hack
at work.
=head1 SEE ALSO
L<rpcgen(1)>, L<RPC::ONC(3)>
=head1 BUGS
If your interface has comments or other preprocessor statements in it
you need to run it through cpp before giving it to I<perlrpcgen>.
I<perlrpcgen> should use MakeMaker for the top-level Makefile.
=cut
!NO!SUBS!
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';