view release on metacpan or  search on metacpan

lib/Affix.pm  view on Meta::CPAN

package Affix v1.0.9 {    # 'FFI' is my middle name!

    #~ |-----------------------------------|-----------------------------------||
    #~ |--------------------------4---5~---|--4--------------------------------||
    #~ |--7~\-----4---44-/777--------------|------7/4~-------------------------||
    #~ |-----------------------------------|-----------------------------------||
    use v5.40;
    use Exporter           qw[import];
    use vars               qw[@EXPORT_OK @EXPORT %EXPORT_TAGS];
    use warnings::register qw[Type];
    no warnings qw[experimental::try];
    use Carp                  qw[];
    use Config                qw[%Config];
    use File::Spec::Functions qw[rel2abs canonpath curdir path catdir];
    use File::Basename        qw[basename dirname];
    use File::Find            qw[find];
    use File::Temp            qw[tempdir];
    my $okay = 0;

    BEGIN {
        use XSLoader;
        $DynaLoad::dl_debug = $DynaLoad::dl_debug = 1;
        $okay               = XSLoader::load();
        my $platform
            = 'Affix::Platform::' .
            ( ( $^O eq 'MSWin32' ) ? 'Windows' :
                $^O eq 'darwin'                                                                   ? 'MacOS' :
                ( $^O eq 'freebsd' || $^O eq 'openbsd' || $^O eq 'netbsd' || $^O eq 'dragonfly' ) ? 'BSD' :
                'Unix' );

        #~ warn $platform;
        #~ use base $platform;
        eval 'use ' . $platform . ' qw[:all];';
        $@ && die $@;
        our @ISA = ($platform);
    }
    push @{ $EXPORT_TAGS{lib} }, qw[libm libc];
    $EXPORT_TAGS{types} = [
        qw[ typedef
            Void Bool
            Char UChar SChar WChar
            Short UShort
            Int UInt
            Long ULong
            LongLong ULongLong
            Float16 Float Double LongDouble
            Int8 SInt8 UInt8 Int16 SInt16 UInt16 Int32 SInt32 UInt32 Int64 SInt64 UInt64 Int128 SInt128 UInt128
            Float32 Float64
            Size_t SSize_t
            String WString
            Pointer Array Live Struct Union Enum Callback CodeRef Complex Vector Live
            ThisCall attach_destructor
            Packed VarArgs
            SV
            File PerlIO
            StringList
            Buffer SockAddr
            M256 M256d M512 M512d M512i
        ]
    ];
    {
        my %seen;
        push @{ $EXPORT_TAGS{default} }, grep { !$seen{$_}++ } @{ $EXPORT_TAGS{$_} } for qw[core types lib];
    }
    {
        my %seen;
        push @{ $EXPORT_TAGS{all} }, grep { !$seen{$_}++ } @{ $EXPORT_TAGS{$_} } for keys %EXPORT_TAGS;
    }
    #
    @EXPORT    = sort @{ $EXPORT_TAGS{default} };    # XXX: Don't do this...
    @EXPORT_OK = sort @{ $EXPORT_TAGS{all} };
    #
    sub libm() { CORE::state $m //= find_library('m'); $m }
    sub libc() { CORE::state $c //= find_library('c'); $c }

    sub attach_destructor ( $pin, $destructor, $lib //= () ) {
        Affix::_attach_destructor( $pin, $destructor, $lib );
    }
    #
    our $OS = $^O;
    my $is_win = $OS eq 'MSWin32';
    my $is_mac = $OS eq 'darwin';
    my $is_bsd = $OS =~ /bsd/;
    my $is_sun = $OS =~ /(solaris|sunos)/;
    #
    sub locate_libs ( $lib, $version //= () ) {
        $lib =~ s[^lib][];
        my $ver;
        if ( defined $version ) {
            require version;
            $ver = version->parse($version);
        }

        #~ warn $lib;
        #~ warn $version;
        #~ warn "Win: $is_win";
        #~ warn "Mac: $is_mac";
        #~ warn "BSD: $is_bsd";
        #~ warn "Sun: $is_sun";
        CORE::state $libdirs;
        if ( !defined $libdirs ) {
            if ($is_win) {
                require Win32;
                $libdirs = [ Win32::GetFolderPath( Win32::CSIDL_SYSTEM() ) . '/', Win32::GetFolderPath( Win32::CSIDL_WINDOWS() ) . '/', ];
            }
            else {
                $libdirs = [
                    ( split ' ', $Config{libsdirs} ),
                    map { split /[:;]/, ( $ENV{$_} ) } grep { $ENV{$_} } qw[LD_LIBRARY_PATH DYLD_LIBRARY_PATH DYLD_FALLBACK_LIBRARY_PATH]
                ];
            }
            no warnings qw[once];
            require DynaLoader;
            $libdirs = [
                grep { -d $_ } map { rel2abs($_) } qw[. ./lib ~/lib /usr/local/lib /usr/lib /lib /usr/lib/system], @DynaLoader::dl_library_path,
                @$libdirs
            ];
        }
        CORE::state $regex;
        if ( !defined $regex ) {
            $regex = $is_win ?
                qr/^
    (?:lib)?(?<name>\w+)
    (?:[_-](?<version>[0-9\-\._]+))?_*
    \.$Config{so}
    $/ix :
                $is_mac ?
                qr/^
    (?:lib)?(?<name>\w+)
    (?:\.(?<version>[0-9]+(?:\.[0-9]+)*))?
    \.(?:so|dylib|bundle)
    $/x :
                qr/^
    (?:lib)?(?<name>\w+)
    \.$Config{so}
    (?:\.(?<version>[0-9]+(?:\.[0-9]+)*))?
    $/x;

lib/Affix.pm  view on Meta::CPAN

                    ( !builtin::blessed($curr) || !$curr->isa('Affix::Type') ) ) {
                    my $name = $curr;
                    my $type = $next;
                    $i++;
                    my $width = $members->[ $i + 1 ];
                    if ( defined $width && !ref($width) && $width =~ /^\d+$/ ) { push @parts, "$name:$type:$width"; $i++; }
                    else                                                       { push @parts, "$name:$type"; }
                }
                else { push @parts, "$curr"; }
            }
            return sprintf( $kind, join( ',', @parts ) );
        }
    }
    package    #
        Affix::Type::Struct {
        our @ISA = qw[Affix::Type::Aggregate];
        sub new { my $class = shift; my %args = @_; $args{kind} = '{%s}'; bless \%args, $class }
    }
    package    #
        Affix::Type::Union {
        our @ISA = qw[Affix::Type::Aggregate];
        sub new { my $class = shift; my %args = @_; $args{kind} = '<%s>'; bless \%args, $class }
    }
    package    #
        Affix::Type::Array {
        our @ISA = qw[Affix::Type];
        sub signature { my $self = shift; my $c = $self->{count} // '?'; return "[$c:" . $self->{type} . "]"; }
    }
    package    #
        Affix::Type::Pointer {
        our @ISA = qw[Affix::Type];
        sub signature { '*' . ( shift->{subtype} // 'void' ) }
    }
    package    #
        Affix::Type::Callback {
        our @ISA = qw[Affix::Type];
        sub params { shift->{params} }

        sub signature {
            my $self = shift;
            my @args = map { builtin::blessed($_) ? $_->signature : $_ } @{ $self->{params} };
            my $args = join( ',', @args );
            $args =~ s/,\;,/;/g;
            $args =~ s/,\;$/;/;
            my $r = builtin::blessed( $self->{ret} ) ? $self->{ret}->signature : $self->{ret};
            return "*(($args)->$r)";
        }
    }
    package    #
        Affix::Pointer {
        use v5.40;
        use overload '""' => \&address, '@{}' => \&_as_array, '%{}' => \&_as_hash, fallback => 1;
        sub address           { Affix::address(shift) }
        sub type              { Affix::_pin_type(shift) }
        sub element_type      { Affix::_pin_element_type(shift) }
        sub size              { Affix::_pin_size(shift) }
        sub count             { Affix::_pin_count(shift) }
        sub cast              { Affix::cast( shift, shift ) }
        sub _as_array         { my $self = shift; my @proxy; tie @proxy, 'Affix::Pointer::TiedArray', $self; return \@proxy; }
        sub _as_hash          { my $self = shift; my %proxy; tie %proxy, 'Affix::Pointer::TiedHash',  $self; return \%proxy; }
        sub attach_destructor { my ( $self, $destructor, $lib ) = @_; Affix::attach_destructor( $self, $destructor, $lib ); }
    }
    package    #
        Affix::Pointer::TiedHash {
        use v5.40;
        sub TIEHASH  { my ( $class, $ptr ) = @_; my $obj = $ptr->cast( "+" . $ptr->element_type ); return $obj; }
        sub FETCH    { my ( $self, $key ) = @_; return $self->{$key}; }
        sub STORE    { my ( $self, $key, $val ) = @_; $self->{$key} = $val; }
        sub EXISTS   { my ( $self, $key ) = @_; return exists $self->{$key}; }
        sub FIRSTKEY { my ($self) = @_; keys %$self; return each %$self; }
        sub NEXTKEY  { my ( $self, $last ) = @_; return each %$self; }
        sub SCALAR   { my ($self) = @_; return scalar %$self; }
        };
    package    #
        Affix::Pointer::TiedArray {
        use v5.40;
        sub TIEARRAY  { bless { pin => $_[1] }, $_[0] }
        sub FETCH     { my ( $self, $index ) = @_; Affix::_pin_get_at( $self->{pin}, $index ); }
        sub STORE     { my ( $self, $index, $value ) = @_; Affix::_pin_set_at( $self->{pin}, $index, $value ); }
        sub FETCHSIZE { my $self = shift; Affix::_pin_count( $self->{pin} ) // 0x7FFFFFFF; }
        sub EXISTS    { my ( $self, $index ) = @_; my $count = Affix::_pin_count( $self->{pin} ); return defined($count) ? ( $index < $count ) : 1; }
        sub DELETE    { die "Cannot delete elements from a C array" }
        sub CLEAR     { die "Cannot clear a C array" }
        };
    package    #
        Affix::Live {
        use v5.40;
        sub new      { my ( $class, $ref ) = @_; return bless $ref // {}, $class; }
        sub FETCH    { my ( $self, $key ) = @_; return $self->{$key}; }
        sub STORE    { my ( $self, $key, $val ) = @_; $self->{$key} = $val; }
        sub EXISTS   { my ( $self, $key ) = @_; return exists $self->{$key}; }
        sub FIRSTKEY { my ($self) = @_; keys %$self; return each %$self; }
        sub NEXTKEY  { my ( $self, $last ) = @_; return each %$self; }
        sub SCALAR   { my ($self) = @_; return scalar %$self; }
    }
};
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.