Affix
view release on metacpan or search on metacpan
lib/Affix/Wrap.pm view on Meta::CPAN
my $tag = ucfirst($1);
$data->{desc} .= "\n\nB<$tag:> $2";
$current_tag = 'desc';
}
else {
if ( $current_tag eq 'brief' ) { $data->{brief} .= ' ' . $line; }
elsif ( $current_tag eq 'param' && defined $current_param ) { $data->{params}{$current_param} .= ' ' . $line; }
elsif ( $current_tag eq 'return' ) { $data->{return} .= ' ' . $line; }
else { $data->{desc} .= ( length( $data->{desc} ) ? "\n" : '' ) . $line; }
}
}
if ( length( $data->{brief} ) == 0 && length( $data->{desc} ) > 0 ) {
if ( $data->{desc} =~ s/^(.+?\.)\s+//s ) { $data->{brief} = $1; }
}
return $doc_data = $data;
}
method pod {
my $d = $self->parse_doc;
my $out = '=head2 ' . $self->name . "\n\n";
$out .= $self->_format_pod( $d->{brief} ) . "\n\n" if length $d->{brief};
$out .= $self->_format_pod( $d->{desc} ) . "\n\n" if length $d->{desc};
# Format parameters
if ( keys %{ $d->{params} } ) {
$out .= "=over\n\n";
my @param_names = sort keys %{ $d->{params} };
# If we have args metadata (e.g. Function), use it for ordering
if ( $self->can('args') && ref( $self->args ) eq 'ARRAY' ) {
@param_names = map { $_->name } grep { exists $d->{params}{ $_->name } } @{ $self->args };
# Fallback for params documented but not in signature (rare but possible in C macros/varargs)
my %seen = map { $_ => 1 } @param_names;
push @param_names, grep { !$seen{$_} } sort keys %{ $d->{params} };
}
for my $name (@param_names) {
$out .= "=item C<$name>\n\n" . $self->_format_pod( $d->{params}{$name} ) . "\n\n";
}
$out .= "=back\n\n";
}
# Format return value
if ( length $d->{return} ) {
$out .= "B<Returns:> " . $self->_format_pod( $d->{return} ) . "\n\n";
}
$out;
}
method affix( $lib //= (), $pkg //= () ) { return undef }
}
class #
Affix::Wrap::Member {
use Affix qw[Void];
field $name : reader : param //= '';
field $type : reader : param //= '';
field $doc : reader : param //= ();
field $definition : reader : param //= ();
method affix_type {
return $definition->affix_type if defined $definition;
return $type->affix_type if builtin::blessed($type);
return 'Void';
}
method affix {
return $definition->affix if defined $definition;
builtin::blessed($type) ? $type->affix : Void;
}
}
class #
Affix::Wrap::Macro : isa(Affix::Wrap::Entity) {
field $value : reader : param //= ();
method set_value ($v) { $value = $v }
method affix_type {
$value // return '';
my $v = $value // '';
$v =~ s/^\s+|\s+$//g;
return '' unless length $v;
if ( $v =~ /^-?(?:0x[\da-fA-F]+|\d+(?:\.\d+)?)$/ ) {
return sprintf 'use constant %s => %s', $self->name, $v;
}
if ( $v =~ /^".*"$/ || $v =~ /^'.*'$/ ) {
return sprintf 'use constant %s => %s', $self->name, $v;
}
$v =~ s/'/\\'/g;
sprintf 'use constant %s => \'%s\'', $self->name, $v;
}
method affix ( $lib //= (), $pkg //= () ) {
if ( $pkg && defined $value && length $value ) {
my $val = $value;
if ( $val =~ /^"(.*)"$/ || $val =~ /^'(.*)'$/ ) { $val = $1; }
no strict 'refs';
no warnings 'redefine';
*{ "${pkg}::" . $self->name } = sub () {$val};
}
sub () {$value};
}
} class Affix::Wrap::Variable : isa(Affix::Wrap::Entity) {
field $type : reader : param;
method affix_type { sprintf 'pin my $%s, $lib, \'%s\' => %s', $self->name, $self->name, $type->affix_type }
method affix ( $lib, $pkg //= () ) {
if ($lib) {
my $t = $type->affix;
if ($pkg) {
no strict 'refs';
# Vivify package variable and bind it
Affix::pin( ${ "${pkg}::" . $self->name }, $lib, $self->name, $t );
}
else {
my $var;
Affix::pin( $var, $lib, $self->name, $t );
return $var;
}
}
$type->affix;
}
} class #
Affix::Wrap::Typedef : isa(Affix::Wrap::Entity) {
field $underlying : reader : param;
method affix_type { 'typedef \'' . $self->name . '\' => ' . $underlying->affix_type }
method affix ( $lib //= (), $pkg //= () ) {
my $t = $underlying->affix;
Affix::typedef $self->name, $t;
# If the underlying type is an Enum, we must manually export the constants to the target package.
# Affix::typedef only installs them into the *caller* (which is this class).
if ( $pkg && builtin::blessed($t) && $t->isa('Affix::Type::Enum') ) {
my ( $const_map, $val_map ) = $t->resolve();
no strict 'refs';
while ( my ( $const_name, $val ) = each %$const_map ) {
*{"${pkg}::${const_name}"} = sub () {$val};
}
}
}
} class Affix::Wrap::Struct : isa(Affix::Wrap::Entity) {
field $tag : reader : param //= 'struct';
field $members : reader : param //= [];
method affix_type {
my $type_name = $tag eq 'union' ? 'Union' : 'Struct';
sprintf '%s[ %s ]', $type_name, join( ', ', map { $_->name . ' => ' . $_->affix_type } @$members );
}
method affix ( $lib //= (), $pkg //= () ) {
use Affix qw[Struct Union];
if ( $tag eq 'union' ) {
return Union [ map { $_->name, $_->affix } @$members ];
}
Struct [ map { $_->name, $_->affix } @$members ];
}
} class #
Affix::Wrap::Enum : isa(Affix::Wrap::Entity) {
field $constants : reader : param //= [];
method affix_type {
my @defs;
for my $c (@$constants) {
if ( !defined $c->{value} ) {
push @defs, $c->{name};
next;
}
my $v = $c->{value} // 0;
$v = "'$v'" if $v !~ /^-?\d+$/;
push @defs, sprintf( '[%s => %s]', $c->{name}, $v );
}
return sprintf 'Enum[ %s ]', join( ', ', @defs );
}
method affix ( $lib //= (), $pkg //= () ) {
use Affix qw[Enum];
my @defs;
for my $c (@$constants) {
if ( !defined $c->{value} ) { push @defs, $c->{name}; next }
push @defs, [ $c->{name}, $c->{value} ];
}
my $type = Enum [@defs];
# Manual export if this is a bare enum (not typedef'd)
if ($pkg) {
my ( $const_map, $val_map ) = $type->resolve();
no strict 'refs';
while ( my ( $const_name, $val ) = each %$const_map ) {
*{"${pkg}::${const_name}"} = sub () {$val};
}
}
return $type;
}
lib/Affix/Wrap.pm view on Meta::CPAN
# Function pointer: ret (*name)(args)
if ( $b =~ s/^\s*([\w\s\*]+?)\s*\(\*\s*(\w+)\)\s*\((.*?)\)\s*;// ) {
my ( $ret_str, $name, $args_str ) = ( $1, $2, $3 );
my $ret = Affix::Wrap::Type->parse($ret_str);
my @args;
if ( $args_str ne '' && $args_str ne 'void' ) {
@args = map { Affix::Wrap::Type->parse($_) } split( /\s*,\s*/, $args_str );
}
my $type_obj = Affix::Wrap::Type::CodeRef->new( ret => $ret, params => \@args );
push @m, Affix::Wrap::Member->new( name => $name, type => $type_obj, doc => $clean->($pending_doc) );
$pending_doc = '';
next;
}
if ( $b =~ s/^\s*(.+?)([\s\*]+)([a-zA-Z_]\w*(?:\[.*?\])?)\s*;// ) {
my ( $t, $sep, $n ) = ( $1, $2, $3 );
$t .= $sep;
$t =~ s/^\s+|\s+$//g;
if ( $n =~ s/(\[.*\])$// ) { $t .= $1 }
push @m, Affix::Wrap::Member->new( name => $n, type => Affix::Wrap::Type->parse($t), doc => $clean->($pending_doc) );
$pending_doc = '';
next;
}
substr( $b, 0, 1 ) = '';
$pending_doc = '';
}
return \@m;
}
method _ln( $c, $o ) { ( substr( $c, 0, $o ) =~ tr/\n// ) + 1 }
method _doc( $c, $o ) {
return undef if $o == 0;
my @l = split /\n/, substr( $c, 0, $o );
my @d;
my $cap = 0;
while ( my $l = pop @l ) {
next if !$cap && $l =~ /^\s*$/;
if ( $l =~ s/\s*\*\/\s*$// ) { $cap = 1; }
elsif ( $l =~ m{^\s*//} ) { $cap = 1; }
if ($cap) {
unshift @d, $l;
last if $l =~ /^\s*\/\*/;
last if $l =~ m{^\s*//} && ( !@l || $l[-1] !~ m{^\s*//} );
}
else {last}
}
return undef unless @d;
my $t = join "\n", @d;
$t =~ s/^\s*(\/\*+|\*+\/|\*|\/\/)\s?//mg;
$t =~ s/^\s+|\s+$//g;
return $t;
}
}
class Affix::Wrap {
field $driver : param //= ();
field $project_files : param //= $driver->project_files;
field $include_dirs : param //= [];
field $types : param //= {};
#
ADJUST {
if ( defined $driver && !builtin::blessed($driver) ) {
if ( $driver eq 'Clang' ) { $driver = Affix::Wrap::Driver::Clang->new( project_files => $project_files ); }
elsif ( $driver eq 'Regex' ) { $driver = Affix::Wrap::Driver::Regex->new( project_files => $project_files ); }
else { die "Unknown driver '$driver'"; }
}
elsif ( !defined $driver ) {
my ( $out, $err, $exit ) = Capture::Tiny::capture { system( 'clang', '--version' ); };
my $use_clang = $exit == 0;
$driver = $use_clang ? Affix::Wrap::Driver::Clang->new( project_files => $project_files ) :
Affix::Wrap::Driver::Regex->new( project_files => $project_files );
}
}
method parse( $entry_point //= () ) {
$entry_point //= $project_files->[0];
$driver->parse( $entry_point, $include_dirs );
}
method _resolve_macros ($nodes) {
my %macros;
for my $node (@$nodes) {
if ( $node isa Affix::Wrap::Macro ) {
my $val = $node->value // '';
$val =~ s/(?<=\d)[Uu][Ll]{0,2}//g;
$macros{ $node->name } = $val;
}
}
my %cache;
my $resolve;
$resolve = sub {
my ($token) = @_;
return undef unless defined $token;
$token =~ s/^\s+|\s+$//g; # Trim whitespace
# Is it a literal number?
return oct($token) if $token =~ /^0x[\da-fA-F]+$/i; # Hex -> Int
return int($token) if $token =~ /^-?\d+$/; # Dec -> Int
# Check cache (recursion guard)
return $cache{$token} if exists $cache{$token};
local $cache{$token} = undef;
# Look up definition
my $expr = $macros{$token};
return undef unless defined $expr; # Not found (maybe a string or unknown)
# Parse expression
# Strip outer parentheses recursively: ((A|B)) -> A|B
1 while $expr =~ s/^\((.*)\)$/$1/;
# Handle bitwise OR chains (e.g. "FLAG_A | FLAG_B")
if ( $expr =~ /\|/ ) {
my $accum = 0;
for my $part ( split /\|/, $expr ) {
my $val = $resolve->($part);
return undef unless defined $val; # Abort if any part is non-numeric
$accum |= $val;
}
return $cache{$token} = $accum;
}
# Fallback: Treat as simple alias (A -> B)
return $cache{$token} = $resolve->($expr);
};
for my $node (@$nodes) {
if ( $node isa Affix::Wrap::Macro ) {
my $val = $resolve->( $node->name );
if ( defined $val ) {
$node->set_value($val);
}
}
}
}
method generate ( $lib, $pkg, $file ) {
my @nodes = $self->parse;
$self->_resolve_macros( \@nodes );
my $out =<<~"";
package $pkg {
use v5.36;
use Affix;
#
my \$lib = '$lib';
for my $name ( keys %$types ) {
my $type = $types->{$name};
my $type_str = builtin::blessed($type) ? $type : "'$type'"; # Quote user types
$out .= "typedef '$name' => $type_str;\n";
}
for my $node (@nodes) {
if ( ( $node isa Affix::Wrap::Typedef || $node isa Affix::Wrap::Struct || $node isa Affix::Wrap::Enum ) &&
exists $types->{ $node->name } ) {
next;
}
my $code = $node->affix_type;
if ($code) { $out .= "$code;\n"; }
}
$out .= "\n};\n1;\n";
Path::Tiny::path($file)->spew_utf8($out);
}
method wrap ( $lib, $target //= [caller]->[0] ) {
# Pre-register User Types
# This ensures they are available in the Affix registry before signatures are parsed,
# and allows using them in recursive definitions or opaque handles.
for my $name ( keys %$types ) {
my $type = $types->{$name};
my $type_str = builtin::blessed($type) ? $type : "$type";
Affix::typedef( $name, $type_str );
}
my @nodes = $self->parse;
# Macro resolution pass
$self->_resolve_macros( \@nodes );
# Generation pass
my @installed;
for my $node (@nodes) {
# Skip definitions if the user provided a manual type override
if ( ( $node isa Affix::Wrap::Typedef || $node isa Affix::Wrap::Struct || $node isa Affix::Wrap::Enum ) &&
exists $types->{ $node->name } ) {
next;
}
if ( $node->can('affix') ) {
$node->affix( $lib, $target );
push @installed, $node;
}
}
@installed;
}
}
}
1;
__END__
Copyright (C) Sanko Robinson.
This library is free software; you can redistribute it and/or modify it under
the terms found in the Artistic License 2. Other copyrights, terms, and
conditions may apply to data transmitted through this module.
( run in 0.592 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )