view release on metacpan or  search on metacpan

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

        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]+$/ ) {

                        # Using a string eval here to let Perl's engine handle C-like precedence
                        my $res = eval $evaluable;
                        return $cache{$token} = $res if defined $res;
                    }
                }

                # 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 );
                    $node->set_value($val) if defined $val;
                }
            }
        }

        method _generate_code( $lib, $pkg ) {
            Carp::croak("Affix::Wrap::generate/wrap requires a valid package name") unless defined $pkg && $pkg =~ /^[a-zA-Z_]\w*(::\w+)*$/;
            my @nodes = $self->parse;
            my %unique_types;
            my %referenced_names;
            for my $node (@nodes) {
                if ( $node->can('name') && $node->name && $node->name ne '(anonymous)' ) {
                    next if $node isa Affix::Wrap::Macro || $node isa Affix::Wrap::Function || $node isa Affix::Wrap::Variable;
                    $unique_types{ $node->name } = $node;
                }

                # Collect dependencies from affix_type strings (e.g. '@sockaddr')
                my $sig = eval { $node->affix . "" } // '';
                while ( $sig =~ /@([a-zA-Z_]\w*)/g ) { $referenced_names{$1} = 1; }
            }

            # Atomic Engine Batch
            my @fwd = sort keys %{ { map { $_ => 1 } ( keys %unique_types, keys %referenced_names ) } };
            my @batch_lines;
            for my $name ( sort keys %unique_types ) {
                my $sig = $unique_types{$name}->affix_type;
                push @batch_lines, "    typedef $name => $sig;" if $sig && $sig ne "$name()";
            }
            my $batch_str = @batch_lines ? join( "\n", @batch_lines ) . "\n" : "";

            # Perl Module Construction
            # Safely quote $lib: escape \ and ] within q[...] delimiters
            my $_lib = '';
            if ( defined $lib ) {
                my $safe_lib = $lib;
                $safe_lib =~ s/\\/\\\\/g;
                $safe_lib =~ s/\]/\\]/g;
                $_lib = "my \$lib = q[$safe_lib];";
            }
            my $out = <<~"PERL";
            package $pkg {
                use v5.40;
                use Affix qw[:all];