view release on metacpan or  search on metacpan

API.pm  view on Meta::CPAN

    }
    #### ok, let's stuff the object
    $self->{procname} = $proc;
    $self->{dll}      = $hdll;
    $self->{dllname}  = $dll;

    $outnum &= ~T_FLAG_NUMERIC;
    my $control;
    $self->{weakapi} = \$control;
    weaken($self->{weakapi});
    $control = pack(         'L'
                             .'L'
                             .(PTRSIZE == 8 ? 'Q' : 'L')
                             .(PTRSIZE == 8 ? 'Q' : 'L')
                             .(PTRSIZE == 8 ? 'Q' : 'L')
                             .(PTRSIZE == 8 ? '' : 'L')
                        ,($class eq "Win32::API::More" ? APICONTROL_is_more : 0)
                        | ($proto ? APICONTROL_has_proto : 0)
                        | $ccnum
                        | (PTRSIZE == 8 ? 0 :  $stackunwind << 8)
                        | $outnum << 24
                        , scalar(@{$self->{in}}) * PTRSIZE #in param count, in SV * units
                        , $hproc
                        , \($self->{weakapi})+0 #weak api obj ref
                        , (exists $self->{intypes} ? ($self->{intypes})+0 : 0)
                        , 0); #padding to align to 8 bytes on 32 bit only
    #align to 16 bytes
    $control .= "\x00" x ((((length($control)+ 15) >> 4) << 4)-length($control));
    #make a APIPARAM template array
    my ($i, $arr_end) = (0, scalar(@{$self->{in}}));
    for(; $i< $arr_end; $i++) {
        my $tin = $self->{in}[$i];
        #unsigned meaningless no sign vs zero extends are done bc uv/iv is
        #the biggest native integer on the cpu, big to small is truncation
        #numeric is implemented as T_NUMCHAR for in, keeps asm jumptable clean
        $tin &= ~(T_FLAG_UNSIGNED|T_FLAG_NUMERIC);
        $tin--; #T_VOID doesn't exist as in param in XS
        #put index of param array slice in unused space for croaks, why not?
        $control .= "\x00" x 8 . pack('CCSSS', $tin, 0, 0, $i, $i+1);
    }
    _Align($control, 16); #align the whole PVX to 16 bytes for SSE moves

    #### keep track of the imported function
    if(defined $dll){
        $Libraries{$dll} = $hdll;
        $Procedures{$dll}++;
    }
    DEBUG "Object blessed!\n" if DEBUGCONST;

    my $ref = bless(\$control, $class);
    SetMagicSV($ref, $self);
    return $ref;
}

sub Import {
    my $closure = shift->new(@_)
        or return undef;
    my $procname = ${Win32::API::GetMagicSV($closure)}{procname};
    #dont allow "sub main:: {0;}"
    Win32::SetLastError(ERROR_INVALID_PARAMETER), return undef if $procname eq '';
    _ImportXS($closure, (caller)[0].'::'.$procname);
    return $closure;
}

#######################################################################
# PRIVATE METHODS
#
sub DESTROY {
    my ($self) = GetMagicSV($_[0]);

    return if ! defined $self->{dllname};
    #### decrease this library's procedures reference count
    $Procedures{$self->{dllname}}--;

    #### once it reaches 0, free it
    if ($Procedures{$self->{dllname}} == 0) {
        DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n" if DEBUGCONST;
        Win32::API::FreeLibrary($Libraries{$self->{dllname}});
        delete($Libraries{$self->{dllname}});
    }
}

# Convert calling convention string (_cdecl|__stdcall)
# to a C const. Unknown counts as __stdcall
#
sub calltype_to_num {
    my $type = shift;

    if (!$type || $type eq "__stdcall" || $type eq "WINAPI" || $type eq "NTAPI"
        || $type eq "CALLBACK"  ) {
        return APICONTROL_CC_STD;
    }
    elsif ($type eq "_cdecl" || $type eq "__cdecl" || $type eq "WINAPIV") {
        return APICONTROL_CC_C;
    }
    else {
        warn "unknown calling convention: '$type'";
        return APICONTROL_CC_STD;
    }
}


sub type_to_num {
    die "wrong class" if shift ne "Win32::API";
    my $type = shift;
    my $out  = shift;
    my ($num, $numeric);
    if(index($type, 'num', 0) == 0){
        substr($type, 0, length('num'), '');
        $numeric = 1;
    }
    else{
        $numeric = 0;
    }

    if (   $type eq 'N'
        or $type eq 'n'
        or $type eq 'l'
        or $type eq 'L'
        or ( PTRSIZE == 8  and $type eq 'Q' || $type eq 'q'))
    {