view release on metacpan or  search on metacpan

lib/Affix/Wrap.pm  view on Meta::CPAN

                    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;
        }

        method affix {
            return $definition->affix if defined $definition;
            return $type->affix       if builtin::blessed($type);

            # Fallback: if it's just a string, wrap it in a Reference object
            return Affix::Type::Reference->new( name => $type =~ s/^@//r ) if defined $type;
            return Affix::Void();
        }
    }
    class    #
        Affix::Wrap::Macro : isa(Affix::Wrap::Entity) {
        field $value : reader : param //= ();
        method set_value ($v) { $value = $v }

        method affix_type {
            my $v = $self->value // return '';

            # Sanitize C string concatenations in macros (e.g. "a" "b" -> "ab")
            $v =~ s/"\s+"//g;

            # Strip outer quotes from C string literals
            if    ( $v =~ /^"(.*)"$/ ) { $v = $1; $v =~ s/\\(.)/$1/g; }
            elsif ( $v =~ /^'(.*)'$/ ) { $v = $1; }

            # Protect against Perl-internal reserved names (starting with __)
            # and macros containing unresolved C calls or backslashes
            if ( $self->name =~ /^__/ || $v =~ /[\\()]/ ) {
                return '# use constant ' . $self->name . " => $v";
            }
            if ( $v =~ /^-?(?:0x[\da-fA-F]+|\d+(?:\.\d+)?)$/ ) {
                return sprintf 'use constant %s => %s', $self->name, $v;
            }
            $v =~ s/'/\\'/g;
            return "use constant " . $self->name . " => '$v'";
        }

        method affix ( $lib //= (), $pkg //= () ) {
            if ( $pkg && defined $value && length $value ) {
                my $val = $value;
                if ( $val =~ /^"(.*)"$/ || $val =~ /^'(.*)'$/ ) { $val = $1; }
                if ( $pkg =~ /^[a-zA-Z_]\w*(::\w+)*$/ && $self->name =~ /^[a-zA-Z_]\w*$/ ) {
                    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 {

            # Safely declare the package var, then attempt to pin it
            sprintf "our \$%s;\n    try { Affix::pin(\$%s, \$lib, '%s', %s) } catch(\$e) { }", $self->name, $self->name, $self->name,
                $type->affix_type;
        }

        method affix ( $lib, $pkg //= () ) {
            my $var;
            try {

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 ) {

                # Wrap in a localized warn-handler to suppress the internal "Can't spawn" error
                my $exit = do {
                    local $SIG{__WARN__} = sub { };
                    system( 'clang', '--version', '>', File::Spec->devnull, '2>&1' );
                };
                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];
            my @nodes = $driver->parse( $entry_point, $include_dirs );
            $self->_resolve_macros( \@nodes );
            return @nodes;
        }

        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;    # Strip C suffixes like 100ULL
                    $macros{ $node->name } = $val;
                }
            }
            my %cache;
            my $resolve;
            $resolve = sub {
                my ($token) = @_;
                return undef unless defined $token;
                $token =~ s/^\s+|\s+$//g;
                return oct($token)    if $token =~ /^0x[\da-fA-F]+$/i;
                return $token + 0     if $token =~ /^-?\d+(?:\.\d+)?$/;
                return $cache{$token} if exists $cache{$token};
                local $cache{$token} = undef;
                my $expr = $macros{$token};
                return undef unless defined $expr;
                1 while $expr =~ s/^\((.*)\)$/$1/;    # Strip outer parens

                # Resolve bitwise and arithmetic expressions
                if ( $expr =~ /[|&<>+\-*\/]/ ) {
                    my $evaluable = $expr;

                    # Using {} delimiters so the // operator doesn't break the regex parser
                    $evaluable =~ s{\b([a-zA-Z_]\w*)\b}{ $resolve->($1) // $1 }ge;

                    # Clean up any C-style suffixes that might have survived
                    $evaluable =~ s/\b(\d+)L+\b/$1/g;

                    # If everything is now numeric/operators/whitespace, we can safely eval
                    if ( $evaluable =~ /^[0-9\s|&<>\+\-\*\/\(\).xXa-fA-F]+$/ ) {