view release on metacpan or  search on metacpan

lib/Affix.pm  view on Meta::CPAN

    (?:[_-](?<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;
        }
        my %store;
        find(
            sub {
                $File::Find::prune = 1 if !grep { canonpath $_ eq canonpath $File::Find::name } @$libdirs;
                return unless $_ =~ $regex;
                return unless defined $+{name};
                return unless $+{name} eq $lib;
                return unless -B $File::Find::name;
                my $lib_ver;
                $lib_ver = version->parse( $+{version} ) if defined $+{version};
                return unless ( defined $lib_ver && defined($ver) ? $ver == $lib_ver : 1 );
                $store{ canonpath $File::Find::name } //= { %+, path => $File::Find::name, ( defined $lib_ver ? ( version => $lib_ver ) : () ) };
            },
            @$libdirs
        );
        values %store;
    }

    sub locate_lib( $name, $version //= () ) {
        return $name if $name && -B $name;
        CORE::state $cache //= {};
        return $cache->{$name}{ $version // '' }->{path} if defined $cache->{$name}{ $version // '' };
        if ( !$version ) {
            return $cache->{$name}{''}{path} = rel2abs($name)                       if -B rel2abs($name);
            return $cache->{$name}{''}{path} = rel2abs( $name . '.' . $Config{so} ) if -B rel2abs( $name . '.' . $Config{so} );
        }
        my $libname = basename $name;
        $libname =~ s/^lib//;
        $libname =~ s/\..*$//;
        return $cache->{$libname}{ $version // '' }->{path} if defined $cache->{$libname}{ $version // '' };
        my @libs = locate_libs( $name, $version );

        #~ warn;
        #~ use Data::Dump;
        #~ warn join ', ', @_;
        #~ ddx \@_;
        #~ ddx $cache;
        if (@libs) {
            ( $cache->{$name}{ $version // '' } ) = @libs;
            return $cache->{$name}{ $version // '' }->{path};
        }
        ();
    }

    sub _is_type ($thing) {
        return 1 if builtin::blessed($thing) && $thing->isa('Affix::Type');
        return 1 if !ref($thing) && defined $thing && index( '*@({;<', substr( $thing, 0, 1 ) ) >= 0;
        return 0;
    }

    # Abstract
    CORE::state $wchar_size = $Config{wcharsize} // ( $^O eq 'MSWin32' ? 2 : 4 );
    sub Void () { Affix::Type::Primitive->new( name => 'void' ) }
    sub Bool () { Affix::Type::Primitive->new( name => 'bool' ) }
    sub Char () { Affix::Type::Primitive->new( name => 'char' ) }
    sub UChar() { Affix::Type::Primitive->new( name => 'uchar' ) }
    sub SChar() { Affix::Type::Primitive->new( name => 'char' ) }

    #~ sub WChar()       { Affix::Type::Primitive->new( name => ( $wchar_size == 2 ? 'uint16' : 'uint32' ) ) }
    sub WChar()       { Affix::Type::Primitive->new( name => 'wchar_t' ) }
    sub Short ()      { Affix::Type::Primitive->new( name => 'short' ) }
    sub UShort ()     { Affix::Type::Primitive->new( name => 'ushort' ) }
    sub Int ()        { Affix::Type::Primitive->new( name => 'int' ) }
    sub UInt ()       { Affix::Type::Primitive->new( name => 'uint' ) }
    sub Long ()       { Affix::Type::Primitive->new( name => 'long' ) }
    sub ULong ()      { Affix::Type::Primitive->new( name => 'ulong' ) }
    sub LongLong ()   { Affix::Type::Primitive->new( name => 'longlong' ) }
    sub ULongLong ()  { Affix::Type::Primitive->new( name => 'ulonglong' ) }
    sub Float ()      { Affix::Type::Primitive->new( name => 'float' ) }
    sub Double ()     { Affix::Type::Primitive->new( name => 'double' ) }
    sub LongDouble () { Affix::Type::Primitive->new( name => 'longdouble' ) }
    sub Size_t ()     { Affix::Type::Primitive->new( name => 'size_t' ) }
    sub SSize_t ()    { Affix::Type::Primitive->new( name => 'ssize_t' ) }

    # Fixed-width
    sub SInt8()    { Affix::Type::Primitive->new( name => 'sint8' ) }
    sub Int8()     { Affix::Type::Primitive->new( name => 'sint8' ) }
    sub UInt8()    { Affix::Type::Primitive->new( name => 'uint8' ) }
    sub SInt16()   { Affix::Type::Primitive->new( name => 'sint16' ) }
    sub Int16()    { Affix::Type::Primitive->new( name => 'sint16' ) }
    sub UInt16()   { Affix::Type::Primitive->new( name => 'uint16' ) }
    sub SInt32()   { Affix::Type::Primitive->new( name => 'sint32' ) }
    sub Int32()    { Affix::Type::Primitive->new( name => 'sint32' ) }
    sub UInt32()   { Affix::Type::Primitive->new( name => 'uint32' ) }
    sub SInt64()   { Affix::Type::Primitive->new( name => 'sint64' ) }
    sub Int64()    { Affix::Type::Primitive->new( name => 'sint64' ) }
    sub UInt64()   { Affix::Type::Primitive->new( name => 'uint64' ) }
    sub SInt128()  { Affix::Type::Primitive->new( name => 'sint128' ) }
    sub Int128()   { Affix::Type::Primitive->new( name => 'sint128' ) }
    sub UInt128()  { Affix::Type::Primitive->new( name => 'uint128' ) }
    sub Float16()  { Affix::Type::Primitive->new( name => 'float16' ) }
    sub Float32()  { Affix::Type::Primitive->new( name => 'float32' ) }
    sub Float64 () { Affix::Type::Primitive->new( name => 'float64' ) }
    sub Char8()    { Affix::Type::Primitive->new( name => 'char8_t' ) }
    sub Char16()   { Affix::Type::Primitive->new( name => 'char16_t' ) }
    sub Char32()   { Affix::Type::Primitive->new( name => 'char32_t' ) }

    # SIMD aliases
    sub M256 ()  { Affix::Type::Primitive->new( name => 'm256' ) }
    sub M256d () { Affix::Type::Primitive->new( name => 'm256d' ) }
    sub M512 ()  { Affix::Type::Primitive->new( name => 'm512' ) }
    sub M512d () { Affix::Type::Primitive->new( name => 'm512d' ) }
    sub M512i () { Affix::Type::Primitive->new( name => 'm512i' ) }

    # Composites
    sub Pointer : prototype($) {
        my $t = ref( $_[0] ) ? $_[0]->[0] : $_[0];
        Affix::Type::Pointer->new( subtype => $t );
    }
    sub Struct : prototype($) { Affix::Type::Struct->new( members => $_[0] ) }

    sub Const : prototype($) {
        my $t = $_[0];
        $t = $t->() if ref($t) eq 'CODE';
        if ( ref($t) eq 'ARRAY' ) {
            if   ( @$t == 1 ) { $t = $t->[0]; }
            else              { $t = ( @$t == 2 && !ref( $t->[1] ) && $t->[1] =~ /^\d+$/ ) ? Array($t) : Struct($t); }
        }
        return Affix::Type::Const->new( inner => $t );
    }

    # Union[ i => Int, f => Float ] -> <i:int,f:float>
    sub Union : prototype($) { Affix::Type::Union->new( members => $_[0] ) }

    sub Array : prototype($) {
        my ( $type, $size ) = @{ $_[0] };
        return Affix::Type::Array->new( type => $type, count => $size );
    }

    # Callback[ [Int, Int] => Void ] -> (int,int)->void
    # Callback[ [String, VarArgs, Int] => Void ] -> (*char;int)->void
    sub Callback : prototype($) {
        my $args = $_[0];
        Affix::Type::Callback->new( params => $args->[0], ret => $args->[1] );
    }

    # Complex[ Double ] -> c[double]
    sub Complex : prototype($) {
        my $type = ref( $_[0] ) ? $_[0]->[0] : $_[0];
        return "c[$type]";
    }

    # Vector[ 4, Float ] -> v[4:float]
    sub Vector : prototype($) {
        my ( $size, $type ) = @{ $_[0] };
        return "v[$size:$type]";
    }

    sub ThisCall : prototype($) {
        my $cb = $_[0];
        if ( builtin::blessed($cb) && $cb->isa('Affix::Type::Callback') ) {

            # Prepend 'this' pointer
            unshift @{ $cb->params }, Pointer [Void];
            return $cb;
        }
        elsif ( !ref $cb && $cb =~ /^\*\(\((.*)\)->(.*)\)$/ ) {
            my ( $args, $ret ) = ( $1, $2 );
            $args = $args ? "*void,$args" : "*void";
            return "*(($args)->$ret)";
        }
        return $cb;
    }

    # Enum[ Int ] -> e:int
    # Enum[ [ K=>V, ... ], Int ] -> e:int (We ignore the values for the signature)
    sub Enum : prototype($) {
        my $args = $_[0];
        return Affix::Type::Enum->new( elements => $args, type => Int() );
    }

    sub IntEnum : prototype($) {
        my $args = $_[0];
        return Affix::Type::Enum->new( elements => $args, type => Int() );
    }

    sub CharEnum : prototype($) {
        my $args = $_[0];
        return Affix::Type::Enum->new( elements => $args, type => Char() );
    }

    sub UIntEnum : prototype($) {
        my $args = $_[0];
        return Affix::Type::Enum->new( elements => $args, type => UInt() );
    }

    # Packed[ Struct[...] ]        -> !{...}
    # Packed[ N, Struct[...] ]     -> !N:{...}
    sub Packed : prototype($) {
        my $content = $_[0];
        if ( ref($content) eq 'ARRAY' && @$content == 2 && !ref( $content->[0] ) ) {
            my ( $align, $struct ) = @$content;
            my $agg = ref($struct) eq 'ARRAY' ? _build_aggregate( $struct, '{%s}' ) : $struct;
            return "!$align:$agg";
        }
        my $agg = ref($content) eq 'ARRAY' ? _build_aggregate( $content, '{%s}' ) : $content;
        return "!$agg";
    }

    # Special marker for Variadic functions
    sub VarArgs () {';'}

    # Semantic aliases and convienient types
    sub String ()     {'*char'}
    sub WString ()    { $wchar_size == 2 ? '*uint16' : '*uint32' }
    sub SV()          {'@SV'}
    sub File ()       {'@File'}
    sub PerlIO ()     {'@PerlIO'}
    sub StringList () { Pointer [ Pointer [Char] ] }
    sub Buffer ()     {'@Buffer'}
    sub SockAddr ()   {'@SockAddr'}

    # Helper for Struct/Union to handle "Name => Type" syntax
    sub _build_aggregate {
        my ( $args, $wrapper ) = @_;
        my @parts;
        for ( my $i = 0; $i < @$args; $i++ ) {
            my $curr = $args->[$i];
            if ( ref($curr) eq 'ARRAY' ) {
                push @parts, $curr->[0] . ':' . $curr->[1];
                next;
            }
            my $next = $args->[ $i + 1 ];
            if ( defined $next && _is_type($next) && !ref($curr) ) {
                push @parts, "$curr:$next";
                $i++;
            }
            else {
                push @parts, "$curr";
            }
        }
        my $content = join( ',', @parts );
        return sprintf( $wrapper, $content );
    }

    sub typedef ( $name, $type //= () ) {
        ( my $clean_name = $name ) =~ s/^@//;
        if ( !defined $type ) {
            Affix::_typedef($clean_name);
        }
        else {
            if ( builtin::blessed($type) && $type->isa('Affix::Type::Enum') ) {
                my ( $const_map, $val_map ) = $type->resolve();
                my $pkg = caller;
                no strict 'refs';
                while ( my ( $const_name, $val ) = each %$const_map ) {
                    *{"${pkg}::${const_name}"} = sub () {$val};
                }
                &Affix::_register_enum_values( $clean_name, $val_map, $const_map );
            }
            if ( builtin::blessed($type) && $type->isa('Affix::Type') ) {
                Affix::_typedef("$clean_name = $type");
            }
            else {
                if ( $type =~ /^@/ ) {
                    Affix::_typedef($type);
                }
                else {
                    Affix::_typedef("$clean_name = $type");
                }
            }
        }
        my $pkg = caller;
        {
            no strict 'refs';
            if ( !defined &{"${pkg}::${name}"} ) {
                *{"${pkg}::${name}"} = sub {
                    return Affix::Type::Reference->new( name => $clean_name );
                };
            }
        }
        return 1;
    }

    # Update @EXPORT_OK or %EXPORT_TAGS to include 'cast' if not already there
    package    #
        Affix::Type {
        use overload '""' => sub { shift->signature() }, fallback => 1;
        sub new       { my ( $class, %args ) = @_; bless \%args, $class }
        sub signature {...}
    }
    package    #
        Affix::Type::Const {
        our @ISA = qw[Affix::Type];
        sub new { my ( $class, %args ) = @_; bless \%args, $class }

        sub signature {
            my $self = shift;
            return builtin::blessed( $self->{inner} ) ? $self->{inner}->signature : $self->{inner};
        }
    }
    package    #
        Affix::Type::Reference {
        our @ISA = qw[Affix::Type];
        sub signature { '@' . shift->{name} }
    }
    package    #
        Affix::Type::Primitive {
        our @ISA = qw[Affix::Type];
        use overload
            '|'      => sub { Affix::Type::Bitfield->new( type => $_[0], width => $_[1] ) },
            '""'     => sub { shift->signature() },
            fallback => 1;
        sub signature { shift->{name} }
    }
    package    #
        Affix::Type::Bitfield {
        our @ISA = qw[Affix::Type];
        sub signature { my $self = shift; $self->{type}->signature . ':' . $self->{width} }
    }
    package    #
        Affix::Type::Enum {
        our @ISA = qw[Affix::Type];
        use Carp;
        sub signature { 'e:' . shift->{type} }

        sub resolve {
            my $self = shift;
            return ( $self->{const_map}, $self->{values_map} ) if defined $self->{values_map};
            $self->{const_map}  = {};
            $self->{values_map} = {};
            my $counter = 0;
            my @elems   = @{ $self->{elements} };
            for ( my $i = 0; $i < @elems; $i++ ) {
                my $item = $elems[$i];
                my ( $name, $final_val );
                if ( !ref $item ) {
                    $name = $item;
                    my $next     = $elems[ $i + 1 ];
                    my $is_value = 0;
                    if ( defined $next && !ref $next ) {
                        if ( $next =~ /^-?\d+$/ || $next =~ /^0x[0-9a-fA-F]+$/ || $next =~ /[\+\|\-\*\/\<\>\~\!\^\(\)]/ ) {
                            $is_value = 1;
                        }
                        elsif ( exists $self->{const_map}->{$next} ) {
                            $is_value = 1;
                        }
                    }
                    if ($is_value) {
                        if ( $next =~ /^-?\d+$/ ) {
                            $final_val = $next;
                        }
                        elsif ( $next =~ /^0x[0-9a-fA-F]+$/ ) {
                            $final_val = hex($next);
                        }
                        else {
                            $final_val = $self->_calculate_expr( $next, $self->{const_map} );
                        }
                        $i++;

lib/Affix.pm  view on Meta::CPAN

                    elsif ( $token eq '-' )  { push @stack, $a - $b; }
                    elsif ( $token eq '*' )  { push @stack, $a * $b; }
                    elsif ( $token eq '/' )  { push @stack, $b ? int( $a / $b ) : 0; }
                    elsif ( $token eq '%' )  { push @stack, $b ? $a % $b        : 0; }
                    elsif ( $token eq '<<' ) { push @stack, $a << $b; }
                    elsif ( $token eq '>>' ) { push @stack, $a >> $b; }
                    elsif ( $token eq '|' )  { push @stack, $a | $b; }
                    elsif ( $token eq '&' )  { push @stack, $a & $b; }
                    elsif ( $token eq '^' )  { push @stack, $a ^ $b; }
                    elsif ( $token eq '==' ) { push @stack, int( $a == $b ); }
                    elsif ( $token eq '!=' ) { push @stack, int( $a != $b ); }
                    elsif ( $token eq '<' )  { push @stack, int( $a < $b ); }
                    elsif ( $token eq '<=' ) { push @stack, int( $a <= $b ); }
                    elsif ( $token eq '>' )  { push @stack, int( $a > $b ); }
                    elsif ( $token eq '>=' ) { push @stack, int( $a >= $b ); }
                    elsif ( $token eq '&&' ) { push @stack, int( $a && $b ); }
                    elsif ( $token eq '||' ) { push @stack, int( $a || $b ); }
                }
            }
            return $stack[0];
        }
    }
    package    #
        Affix::Type::Aggregate {
        our @ISA = qw[Affix::Type];

        sub signature {
            my $self    = shift;
            my $members = $self->{members};
            my $kind    = $self->{kind} // '{%s}';
            my @parts;
            for ( my $i = 0; $i < @$members; $i++ ) {
                my $curr = $members->[$i];
                if ( ref($curr) eq 'ARRAY' ) {
                    my ( $name, $type, $width ) = @$curr;
                    if ( defined $width && !ref($width) && $width =~ /^\d+$/ ) {
                        push @parts, "$name:$type:$width";
                    }
                    else {
                        push @parts, "$name:$type";
                    }
                    next;
                }
                my $next = $members->[ $i + 1 ];
                if ( defined $next && Affix::_is_type($next) && !Affix::_is_type($curr) ) {
                    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)";
        }
    }
};
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.