package Inline::Struct::grammar;
use strict;
$Inline::Struct::grammar::VERSION = '0.10';
sub grammar {
<<'END';
code: part(s) {1}
part: comment
| struct
{
my ($perlname, $cname, $fields, @aliases) = @{$item[1]};
my @fields;
push @fields, @$_ for (@$fields);
push @{$thisparser->{data}{structs}}, $perlname;
$thisparser->{data}{struct}{$perlname}{cname} = $cname;
$thisparser->{data}{struct}{$perlname}{field} = {reverse @fields};
$thisparser->{data}{struct}{$perlname}{fields} =
[ grep { defined $thisparser->{data}{struct}{$perlname}{field}{$_} }
@fields ];
Inline::Struct::grammar::typemap($thisparser, $perlname, $cname);
Inline::Struct::grammar::alias($thisparser, $cname, $_)
for @aliases[0..$#aliases];
}
| typedef
{
my ($type,$alias) = @{$item[1]}[0,1];
Inline::Struct::grammar::alias($thisparser, $type, $alias);
}
| ALL
struct: 'struct' IDENTIFIER { $thisparser->{data}{current}="@item[1,2]" }
'{' field(s) '}' ';'
{
# [perlname, cname, fields]
[$item[2], "@item[1,2]", $item[5]]
}
| 'typedef' 'struct' '{' field(s) '}' IDENTIFIER ';'
{
# [perlname, cname, fields]
[@item[6,6,4]]
}
| 'typedef' 'struct' IDENTIFIER '{' field(s) '}' IDENTIFIER ';'
{
# [perlname, cname, fields, alias]
[$item[3], "@item[2,3]", $item[5], $item[7]]
}
typedef: 'typedef' 'struct' IDENTIFIER IDENTIFIER ';'
{
["@item[2,3]", $item[4]]
}
field: comment
| type IDENTIFIER ';'
{
[@item[1,2]]
}
IDENTIFIER: /[~_a-z]\w*/i
{
$item[1]
}
comment: m{\s* // [^\n]* \n }x
| m{\s* /\* (?:[^*]+|\*(?!/))* \*/ ([ \t]*)? }x
type: TYPE star(s?)
{
$return = $item[1];
$return .= join '',' ',@{$item[2]} if @{$item[2]};
return undef
unless (defined $thisparser->{data}{typeconv}{valid_types}{$return});
}
| modifier(s) TYPE star(s?)
{
$return = $item[2];
$return = join ' ',@{$item[1]},$return if @{$item[1]};
$return .= join '',' ',@{$item[3]} if @{$item[3]};
return undef
unless (defined $thisparser->{data}{typeconv}{valid_types}{$return} or
# $return eq $thisparser->{data}{current} or
$return eq $thisparser->{data}{current} . "*"
);
}
modifier: 'extern' | 'unsigned' | 'long' | 'short' | 'const'
star: '*' | '&'
TYPE: /\w+/
ALL: /.*/
END
}
# Adds an entry in these fields of the parser:
# ->{data}{typeconv}{input_expr}
# ->{data}{typeconv}{output_expr}
# ->{data}{typeconv}{valid_types}
# ->{data}{typeconv}{valid_rtypes}
# ->{data}{typeconv}{type_kind}
sub typemap {
my $parser = shift;
my $perlname = shift;
my $cname = shift;
my ($TYPEMAP, $INPUT, $OUTPUT);
my $type = "O_OBJECT_$perlname";
$TYPEMAP .= "$cname *\t\t$type\n";
$INPUT .= <<END;
if (sv_isobject(\$arg) && (SvTYPE(SvRV(\$arg)) == SVt_PVMG)) {
\$var = (\$type)SvIV((SV*)SvRV( \$arg ));
}
else {
warn ( \\"\${Package}::\$func_name() -- \$var is not a blessed reference\\" );
XSRETURN_UNDEF;
}
END
$OUTPUT .= <<END;
{
HV *map = get_hv("Inline::Struct::${perlname}::_map_", 1);
SV *lookup = newSViv((IV)\$var);
STRLEN klen;
char *key = SvPV(lookup, klen);
if (hv_exists(map, key, klen)) {
HV *info = (HV*)SvRV(*hv_fetch(map, key, klen, 0));
SV *refcnt = *hv_fetch(info, "REFCNT", 6, 0);
sv_inc(refcnt);
}
else {
HV *info = newHV();
SV *info_ref = newRV((SV*)info);
hv_store(info, "REFCNT", 6, newSViv(1), 0);
hv_store(info, "FREE", 4, newSViv(0), 0);
hv_store(map, key, klen, info_ref, 0);
}
}
sv_setref_pv( \$arg, "Inline::Struct::$perlname", (void*)\$var );
END
$parser->{data}{typeconv}{input_expr}{$type} = $INPUT;
$parser->{data}{typeconv}{output_expr}{$type} = $OUTPUT;
$parser->{data}{typeconv}{valid_types}{$cname." *"}++;
$parser->{data}{typeconv}{valid_rtypes}{$cname." *"}++;
$parser->{data}{typeconv}{type_kind}{$cname." *"} = $type;
}
sub alias {
my $parser = shift;
my $type = shift;
my $alias = shift;
$type .= " *"; $alias .= " *"; # because I only deal with pointers.
$parser->{data}{typeconv}{valid_types}{$alias}++;
$parser->{data}{typeconv}{valid_rtypes}{$alias}++;
$parser->{data}{typeconv}{type_kind}{$alias} =
$parser->{data}{typeconv}{type_kind}{$type};
}
1;