#!/usr/local/bin/perl -w
use Getopt::Long;
use Pod::Usage;
$VERSION = 0.01;
use vars qw($mname $fname $otype $oname $rtype $rname $atype $aname $mget $mset);
# data structure: @xspec
# + array of hash-refs, each of the form:
# {
# otype => $xs_obj_type,
# oname => $xs_obj_name,
# fname => $xs_fcn_suffix,
# rtype => $xs_return_type,
# rname => $xs_retval_name,
# aname => $xs_set_arg_name,
# atype => $xs_set_arg_type,
# mname => $c_member_name,
# mname => $c_member_type,
# }
# + defaults are drawn from @XSPEC_DEFAULTS
@XSPEC_DEFAULTS = (
mname => 'UNKNOWN_FIELD',
mtype => 'int',
fname => '$mname',
otype => "UNKNOWN_STRUCT",
oname => "obj",
rtype => '$mtype',
rname => "RETVAL",
atype => '$mtype',
aname => 'val',
);
@xspex = qw();
######################################################################
# Cmdline processing
######################################################################
GetOptions("help"=>\$help,
"man"=>\$man,
"version"=>\$version,
## -- globals
"prefix:s"=>\$XSPREFIX,
"spex|specfile:s"=>\$SPECFILE,
## -- files
"xsin:s"=>\$XSIN,
"xsout:s"=>\$XSOUT,
"pmin:s"=>\$PMIN,
"pmout:s"=>\$PMOUT,
## -- replace-strings
"xs_macro:s"=>\$XS_ACCESSOR_SYMBOL,
"pm_macro_list:s"=>\$PM_ACCESSOR_LIST_SYMBOL,
"pm_macro_code:s"=>\$PM_ACCESSOR_CODE_SYMBOL,
);
#--------------------------------------------------------------
# Process Options: help
#--------------------------------------------------------------
if ($version) {
print STDERR "C-struct accessor generator `$0' version $VERSION by Bryan Jurish\n";
exit 0;
}
pod2usage({
-exitval => 1,
-verbose => 2,
}) if ($man);
pod2usage({
-exitval => 1,
verbose => 0,
}) if ($help);
#--------------------------------------------------------------
# Process Options: Specs
#--------------------------------------------------------------
if (defined($SPECFILE)) {
do("$SPECFILE") or
die("$0: couldn't source spec-file '$SPECFILE': $!");
}
#--------------------------------------------------------------
# Process Options: Files
#--------------------------------------------------------------
if (defined($XSIN)) {
open(XSIN,"<$XSIN") or
die("$0: open failed for XS input file '$XSIN': $!");
}
if (defined($XSOUT)) {
open(XSOUT,">$XSOUT") or
die("$0: open failed for XS output file '$XSOUT': $!");
}
if (defined($PMIN)) {
open(PMIN,"<$PMIN") or
die("$0: open failed for PM input file '$PMIN': $!");
}
if (defined($PMOUT)) {
open(PMOUT,">$PMOUT") or
die("$0: open failed for PM output file '$PMOUT': $!");
}
#--------------------------------------------------------------
# Process Options: Macro Symbols
#--------------------------------------------------------------
$XS_ACCESSOR_SYMBOL = '#XS_ACCESSOR_CODE#' unless (defined($XS_ACCESSOR_SYMBOL));
$PM_ACCESSOR_LIST_SYMBOL = '#PM_ACCESSOR_LIST#' unless (defined($PM_ACCESSOR_LIST_SYMBOL));
$PM_ACCESSOR_CODE_SYMBOL = '#PM_ACCESSOR_CODE#' unless (defined($PM_ACCESSOR_CODE_SYMBOL));
######################################################################
# Subs
######################################################################
# @clines = c2perl($ctype,$cname,$ptype,$pname)
# + code to get C variable "$cname" of type "$ctype" into the
# perl-argument variable "$pname" of type "$ptype"
# + default is just '=' with typecast
sub c2perl {
my ($ctype,$cname,$ptype,$pname) = @_;
my (@clines);
## special handling code HERE
# if ($ctype eq '') { ... }
# else {
@clines = ("$pname = ($ptype)$cname;");
#}
return @clines;
}
# @clines = perl2c($ptype,$pname,$ctype,$cname)
# + code to set C variable "$cname" of type "$ctype" to the value of
# the perl-argument variable "$pname" of type "$ptype"
# + should be memory-safe
sub perl2c {
my ($ptype,$pname,$ctype,$cname) = @_;
my (@clines);
## special handling code HERE
if ($ctype eq 'CharPtr') {
@clines =
(
"if ($cname) { Safefree($cname); $cname = NULL; }",
"if ($pname) { $cname = savepv($pname); }",
);
} else {
## default case
@clines = ("$cname = ($ctype)$pname;");
}
return @clines;
}
# $ccode_string = clines2string($indent,@clines);
sub clines2string {
my ($indent,@clines) = @_;
return
join('',
map {
(($_ =~ /^\#/)
? "$_\n"
: "$indent$_\n")
} @clines);
}
######################################################################
# MAIN (Generation)
######################################################################
%XSPEC_DEFAULTS = @XSPEC_DEFAULTS;
$XSPREFIX = '' unless (defined($XSPREFIX));
@XSCODE = qw(); # XS accessor code to print (contains all neccessary newlines!)
@PMLIST = qw(); # list of accessible fields (one field per element)
@PMCODE = qw(); # PM accessor code to print (contains all neccessary newlines!)
foreach $spec (@xspex) {
## clear variables
foreach $key (keys(%XSPEC_DEFAULTS)) {
$$key = undef;
}
## instantiate defaults
%$spec = (%XSPEC_DEFAULTS, %$spec);
## instantiate spec variables
@def = @XSPEC_DEFAULTS;
while (($key,$_) = splice(@def,0,2)) {
eval
#print
"\$$key = qq($spec->{$key});\n";
warn($@) if ($@);
}
## add to the perl accessor list
push(@PMLIST,$fname);
## add the perl accessor
push(@PMCODE,
"sub $fname { return \$#_ > 0 ? \$_[0]->set_$fname(\$_[1]) : \$_[0]->get_$fname(); }\n",
);
## add to the list of XSubs
push(@XSCODE,
##--- get_*
"$rtype\n",
"${XSPREFIX}get_$fname ( $oname )\n",
"\t INPUT:\n",
"\t $otype $oname\n",
"\t CODE:\n",
clines2string("\t ", c2perl($mtype, "$oname->$mname", $rtype, $rname)),
"\t OUTPUT:\n",
"\t $rname\n",
"\n",
##--- set_*
"$rtype\n",
"${XSPREFIX}set_$fname ( $oname, $aname )\n",
"\t INPUT:\n",
"\t $otype $oname\n",
"\t $atype $aname\n",
"\t CODE:\n",
clines2string("\t ", perl2c($atype, $aname, $mtype, "$oname->$mname")),
clines2string("\t ", c2perl($mtype, "$oname->$mname", $rtype, $rname)),
"\t OUTPUT:\n",
"\t $rname\n",
"\n",
);
}
######################################################################
# MAIN (Replacement)
######################################################################
## do XS substitution
if (defined($XSIN) && defined($XSOUT)) {
$XSCODE = join('',@XSCODE);
while (<XSIN>) {
s/$XS_ACCESSOR_SYMBOL/$XSCODE/;
print XSOUT $_;
}
} else {
print STDERR "$0 Warning: XS file(s) not specified: XS accessors will not be generated\n";
}
close(XSIN);
close(XSOUT);
## do PM substitution
if (defined($PMIN) && defined($PMOUT)) {
$PMLIST = "qw(\n\t".join("\n\t",@PMLIST)."\n\t)";
$PMCODE = join('',@PMCODE);
while (<PMIN>) {
s/$PM_ACCESSOR_LIST_SYMBOL/$PMLIST/;
s/$PM_ACCESSOR_CODE_SYMBOL/$PMCODE/;
print PMOUT $_;
}
} else {
print STDERR "$0 Warning: PM file(s) not specified: Perl accessors will not be generated\n";
}
close(PMIN);
close(PMOUT);
__END__
###############################################################
# Program Usage
###############################################################
=pod
=head1 NAME
create-xs-accessors.perl --
create XSub and PM wrappers for C-struct access.
=head1 SYNOPSIS
create-xs-accessors.perl [options]
General Options:
-help
-man
-version
Generation Options:
-xsprefix PREFIX
-specfile SPECFILE
File Options:
-xsin XS_INPUT_FILE
-xsout XS_OUTPUT_FILE
-pmin PM_INPUT_FILE
-pmout PM_OUTPUT_FILE
Replacement Options:
-xsmacro XS_ACCESSOR_SYMBOL [=#XS_ACCESSOR_CODE#]
-pmmacro_list PM_LIST_SYMBOL [=#XS_ACCESSOR_LIST#]
-pmmacro_code PM_CODE_SYMBOL [=#PM_ACCESSOR_CODE#]
=cut
###############################################################
# Description
###############################################################
=pod
=head1 OPTIONS AND ARGUMENTS
=cut
###############################################################
# General Options
###############################################################
=pod
=head2 General Options
=over 4
=item * C<-help>
Display a brief help message.
=item * C<-man>
Display a longer help message.
=item * C<-version>
Display version information.
=back
=cut
###############################################################
# Options
###############################################################
=pod
... the rest of this section is not yet written. sorry.
=cut
###############################################################
# Footer
###############################################################
=pod
=head1 ACKNOWLEDGEMENTS
perl by Larry Wall.
=head1 AUTHOR
Bryan Jurish E<lt>moocow@ling.uni-potsdam.deE<gt>
=head1 SEE ALSO
perl(1).
h2xs(1).
=cut