view release on metacpan or  search on metacpan

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

                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];
                #
                $_lib
            PERL
            for my $name (@fwd) {
                $out .= "    typedef '$name';\n";
            }
            $out .= $batch_str;
            $out .= "\n    #\n";
            for my $node (@nodes) {
                $out .= "    " . $node->perl_constants . "\n" if $node isa Affix::Wrap::Enum;
            }
            $out .= "\n    #\n";
            for my $node (@nodes) {
                my $code = $node->affix_type;
                if ( $code && ( $node isa Affix::Wrap::Function || $node isa Affix::Wrap::Variable || $node isa Affix::Wrap::Macro ) ) {
                    $out .= "    $code;\n";
                }
            }
            $out .= "};\n1;\n";
        }

        method generate( $lib, $pkg, $file ) {
            my ( $code, $nodes ) = $self->_generate_code( $lib, $pkg );
            Path::Tiny::path($file)->spew_utf8($code);
        }

        method wrap ( $lib, $pkg //= [caller]->[0] ) {
            my ( $code, $nodes ) = $self->_generate_code( $lib, $pkg );
            eval $code;
            if ($@) {
                Carp::croak("Affix::Wrap wrap() compilation failed: $@\n\nCode:\n$code");
            }
            return grep { $_ isa Affix::Wrap::Function || $_ isa Affix::Wrap::Variable || $_ isa Affix::Wrap::Macro } @$nodes;
        }

        method list_symbols ($lib_path) {
            my $abs = path($lib_path)->absolute->stringify;
            return [] unless -e $abs;
            my @symbols;
            my ( $out, $err, $exit );

            # llvm-nm
            # We use --extern-only to find the public API
            ( $out, $err, $exit ) = capture { system( 'llvm-nm', '--extern-only', '--defined-only', $abs ) };
            if ( $exit == 0 && $out ) {
                for ( split /\n/, $out ) {
                    if (/ [TRG] (?:_)?(\w+)$/) { push @symbols, $1; }
                }
            }

            # objdump for Strawberry Perl
            if ( !@symbols ) {
                ( $out, $err, $exit ) = capture { system( 'objdump', '-p', $abs ) };
                if ( $exit == 0 && $out ) {

                    # objdump -p displays the "Export Address Table"
                    # We look for the lines following the table header
                    my $in_exports = 0;
                    for ( split /\n/, $out ) {
                        if (/^\[Ordinal\/Name Pointer\] Table$/) { $in_exports = 1; next; }
                        if ($in_exports) {
                            last if /^\s*$/;    # End of table

                            # Format:[   0] lsquic_engine_new
                            if (/\[\s*\d+\]\s+(\w+)/) { push @symbols, $1; }
                        }
                    }
                }
            }

            # dumpbin for MSVC
            if ( !@symbols ) {
                ( $out, $err, $exit ) = capture { system( 'dumpbin', '/EXPORTS', $abs ) };
                if ( $exit == 0 && $out ) {
                    my $in_exports = 0;
                    for ( split /\n/, $out ) {
                        if (/ordinal\s+hint\s+RVA\s+name/) { $in_exports = 1; next; }
                        if ($in_exports) {

                            # Format: 1    0 00001234 lsquic_engine_new
                            if (/^\s+\d+\s+[A-F0-9]+\s+[A-F0-9]+\s+(\w+)/) { push @symbols, $1; }
                        }
                    }
                }
            }
            @symbols = sort @symbols;
            if ( !@symbols ) {
                warn "[!] list_symbols: No symbols found in $abs using llvm-nm, objdump, or dumpbin.\n";
            }
            return \@symbols;
        }
    }
}
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.