view release on metacpan or  search on metacpan

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

package Affix::Wrap v1.0.9 {
    use v5.40;
    use feature 'class';
    no warnings 'experimental::class';
    no warnings 'experimental::builtin';
    use Path::Tiny;
    use Capture::Tiny qw[capture];
    use JSON::PP;
    use File::Basename qw[basename];
    use Affix          qw[];
    #
    class    #
        Affix::Wrap::Type {
        use Affix qw[Void];
        field $name : reader : param //= 'void';
        method to_string { $self->name }
        use overload '""' => 'to_string', fallback => 1;

        # Factory method to parse a C type string into objects
        sub parse ( $class, $t ) {
            return $class->new( name => 'void' ) unless defined $t;

            # Cleanup attributes and whitespace
            $t =~ s/__attribute__\s*\(\(.*\)\)//g;
            $t =~ s/^\s+|\s+$//g;

            # Function Pointer: Ret (*)(Args)
            if ( $t =~ /^(.+?)\s*\(\*\)\s*\((.*)\)$/ ) {
                my $ret_str  = $1;
                my $args_str = $2;
                my $ret      = $class->parse($ret_str);
                my @args;
                if ( $args_str ne '' && $args_str ne 'void' ) {
                    @args = map { $class->parse($_) } split( /\s*,\s*/, $args_str );
                }
                return Affix::Wrap::Type::CodeRef->new( ret => $ret, params => \@args );
            }
            if ( $t =~ /^(.*)\s*\[(\d+)\]$/ ) {
                return Affix::Wrap::Type::Array->new( of => $class->parse($1), count => $2 );
            }
            $t =~ s/(\*)\s*(?:const|restrict)\s*$/$1/;
            $t =~ /^(.+)\s*\*$/ ? Affix::Wrap::Type::Pointer->new( of => $class->parse($1) ) : $class->new( name => $t );
        }

        method affix_type {
            my $t = $self->name;
            $t =~ s/^(?:struct|union|enum)\s+//;
            $t =~ s/consts?\s+//g;
            $t =~ s/(\s+\**)const$/$1/g;
            $t =~ s/(\s+\**)restrict$/$1/g;
            $t =~ s/\s+$//;
            #
            state $type_map //= {
                void                 => 'Void',
                bool                 => 'Bool',
                short                => 'Short',
                'unsigned short'     => 'UShort',
                char                 => 'Char',
                'signed char'        => 'SChar',
                'unsigned char'      => 'UChar',
                int                  => 'Int',
                'unsigned int'       => 'UInt',
                long                 => 'Long',
                'unsigned long'      => 'ULong',
                'long long'          => 'LongLong',
                'unsigned long long' => 'ULongLong',
                float                => 'Float',
                double               => 'Double',

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

            [ map { $_->affix } @$args ]
        }
        } class    #
        Affix::Wrap::Driver::Clang {
        use Config;
        field $project_files : param : reader;
        field $allowed_files  = {};
        field $project_dirs   = [];
        field $paths_seen     = {};
        field $file_cache     = {};
        field $last_seen_file = undef;
        field $clang //= 'clang';
        method _basename ($path) { return '' unless defined $path; $path =~ s{^.*[/\\]}{}; return lc($path); }

        method _normalize ($path) {
            return '' unless defined $path && length $path;
            my $abs = Path::Tiny::path($path)->absolute->stringify;
            $abs =~ s{\\}{/}g;
            return $abs;
        }
        ADJUST {
            my %seen_dirs;
            for my $f (@$project_files) {
                next unless defined $f && length $f;
                my $abs = $self->_normalize($f);
                next unless length $abs;
                $allowed_files->{$abs} = 1;
                my $dir = Path::Tiny::path($abs)->parent->stringify;
                $dir =~ s{\\}{/}g;
                unless ( $seen_dirs{$dir}++ ) { push @$project_dirs, $dir; }
            }
        }

        method parse ( $entry_point, $include_dirs //= [] ) {
            if ( !defined $entry_point || !length $entry_point ) {
                ($entry_point) = grep { defined $_ && length $_ } @$project_files;
            }
            return () unless defined $entry_point && length $entry_point;
            my $ep_abs = $self->_normalize($entry_point);
            return () unless length $ep_abs;
            $allowed_files->{$ep_abs} = 1;
            $last_seen_file = $ep_abs;
            my $ep_dir = Path::Tiny::path($ep_abs)->parent->stringify;
            $ep_dir =~ s{\\}{/}g;
            my $found = 0;

            for my $pd (@$project_dirs) {
                if ( $ep_dir eq $pd ) { $found = 1; last; }
            }
            push @$project_dirs, $ep_dir unless $found;
            my @includes = map { "-I" . $self->_normalize($_) } @$include_dirs;
            for my $d (@$project_dirs) { push @includes, "-I$d"; }
            my @cmd = (
                $clang,                 '-target',         $self->_get_triple(),             '-Xclang',
                '-ast-dump=json',       '-Xclang',         '-detailed-preprocessing-record', '-fsyntax-only',
                '-fparse-all-comments', '-Wno-everything', @includes,                        $ep_abs
            );
            my ( $stdout, $stderr, $exit ) = Capture::Tiny::capture { system(@cmd); };
            if ( $exit != 0 )               { die "Clang Error:\n$stderr"; }
            if ( $stdout =~ /^.*?(\{.*)/s ) { $stdout = $1; }
            my $ast = JSON::PP::decode_json($stdout);
            my @objects;
            $self->_walk( $ast, \@objects, $ep_abs );
            $self->_scan_macros_fallback( \@objects );
            $self->_merge_typedefs( \@objects );
            $self->_wrap_named_types( \@objects );

            #~ @objects = sort { ( $a->file cmp $b->file ) || ( $a->start_offset <=> $b->start_offset ) } @objects;
            @objects;
        }

        method _walk( $node, $acc, $current_file ) {
            return unless ref $node eq 'HASH';
            my $kind      = $node->{kind} // 'Unknown';
            my $node_file = $self->_get_node_file($node);
            if ($node_file) {
                $current_file   = $self->_normalize($node_file);
                $last_seen_file = $current_file;
            }
            elsif ( defined $last_seen_file ) { $current_file = $last_seen_file; }
            if    ( $self->_is_valid_file($current_file) && !$node->{isImplicit} ) {
                if ( $kind eq 'MacroDefinitionRecord' ) {
                    if ( $node->{range} ) { $self->_macro( $node, $acc, $current_file ); }
                }
                elsif ( $kind eq 'TypedefDecl' ) { $self->_typedef( $node, $acc, $current_file ); }
                elsif ( $kind eq 'RecordDecl' || $kind eq 'CXXRecordDecl' ) {
                    $self->_record( $node, $acc, $current_file );
                    return;
                }
                elsif ( $kind eq 'EnumDecl' ) {
                    $self->_enum( $node, $acc, $current_file );
                    return;
                }
                elsif ( $kind eq 'VarDecl' ) {
                    if ( ( $node->{storageClass} // '' ) ne 'static' ) { $self->_var( $node, $acc, $current_file ); }
                }
                elsif ( $kind eq 'FunctionDecl' ) {
                    $self->_func( $node, $acc, $current_file );
                    return;
                }
                elsif ( $kind eq 'BuiltinType' ) { return; }
            }
            if ( $node->{inner} ) {
                for ( @{ $node->{inner} } ) { $self->_walk( $_, $acc, $current_file ); }
            }
        }

        method _is_valid_file ($f) {
            return 0 unless defined $f && length $f;
            return 0 if $f =~ m{^/usr/(include|lib|share|local/include)};
            return 0 if $f =~ m{^/System/Library};
            return 1 if $allowed_files->{$f};
            for my $dir (@$project_dirs) { return 1 if index( $f, $dir ) == 0; }
            return 0;
        }

        method _get_node_file($node) {
            my $loc = $node->{loc};
            return undef unless $loc;
            my $f;
            if ( ref($loc) eq 'HASH' ) {