api.pm

WIN32::API for perl dev 5

package Win32::API;

# See the bottom of this file for the POD documentation.  Search for the
# string '=head'.

#######################################################################
#
# Win32::API - Perl Win32 API Import Facility
# 
# Version: 0.41 
# Date: 10 Mar 2003
# Author: Aldo Calpini <[e-mail]>
# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $
#######################################################################

require Exporter;       # to export the constants to the main:: space
require DynaLoader;     # to dynuhlode the module.
@ISA = qw( Exporter DynaLoader );

use vars qw( $DEBUG );
$DEBUG = 0;

sub DEBUG { 
    if ($Win32::API::DEBUG) { 
        printf @_ if @_ or return 1; 
    } else {
        return 0;
    }
}

use Win32::API::Type;
use Win32::API::Struct;

#######################################################################
# STATIC OBJECT PROPERTIES
#
$VERSION = "0.41";

#### some package-global hash to 
#### keep track of the imported 
#### libraries and procedures
my %Libraries = ();
my %Procedures = ();


#######################################################################
# dynamically load in the API extension module.
#
bootstrap Win32::API;

#######################################################################
# PUBLIC METHODS
#
sub new {
    my($class, $dll, $proc, $in, $out) = @_;
    my $hdll;   
    my $self = {};
  
    #### avoid loading a library more than once
    if(exists($Libraries{$dll})) {
        # print "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
        $hdll = $Libraries{$dll};
    } else {
        # print "Win32::API::new: Loading library '$dll'\n";
        $hdll = Win32::API::LoadLibrary($dll);
        $Libraries{$dll} = $hdll;
    }

    #### if the dll can't be loaded, set $! to Win32's GetLastError()
    if(!$hdll) {
        $! = Win32::GetLastError();
        return undef;
    }

    #### determine if we have a prototype or not
    if( (not defined $in) and (not defined $out) ) {
        ($proc, $self->{in}, $self->{intypes}, $self->{out}) = parse_prototype( $proc );
        return undef unless $proc;
        $self->{proto} = 1;
    } else {
        $self->{in} = [];
        if(ref($in) eq 'ARRAY') {
            foreach (@$in) {
                push(@{ $self->{in} }, type_to_num($_));
            }   
        } else {
            my @in = split '', $in;
            foreach (@in) {
                push(@{ $self->{in} }, type_to_num($_));
            }           
        }
        $self->{out} = type_to_num($out);
    }

    #### first try to import the function of given name...
    my $hproc = Win32::API::GetProcAddress($hdll, $proc);

    #### ...then try appending either A or W (for ASCII or Unicode)
    if(!$hproc) {
        my $tproc = $proc;
        $tproc .= (IsUnicode() ? "W" : "A");
        # print "Win32::API::new: procedure not found, trying '$tproc'...\n";
        $hproc = Win32::API::GetProcAddress($hdll, $tproc);
    }

    #### ...if all that fails, set $! accordingly
    if(!$hproc) {
        $! = Win32::GetLastError();
        return undef;
    }
    
    #### ok, let's stuff the object
    $self->{procname} = $proc;
    $self->{dll} = $hdll;
    $self->{dllname} = $dll;
    $self->{proc} = $hproc;

    #### keep track of the imported function
    $Libraries{$dll} = $hdll;
    $Procedures{$dll}++;

    #### cast the spell
    bless($self, $class);
    return $self;
}

sub Import {
    my($class, $dll, $proc, $in, $out) = @_;
    $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out) or return 0;
    my $P = (caller)[0];
    eval qq(
        sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
    );
    return $@ ? 0 : 1;
}


#######################################################################
# PRIVATE METHODS
#
sub DESTROY {
    my($self) = @_;

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

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

sub type_to_num {
    my $type = shift;
    my $out = shift;
    my $num;
    
    if(     $type eq 'N'
    or      $type eq 'n'
    or      $type eq 'l'
    or      $type eq 'L'
    ) {
        $num = 1;
    } elsif($type eq 'P'
    or      $type eq 'p'
    ) {
        $num = 2;
    } elsif($type eq 'I'
    or      $type eq 'i'
    ) {
        $num = 3;
    } elsif($type eq 'f'
    or      $type eq 'F'
    ) {
        $num = 4;
    } elsif($type eq 'D'
    or      $type eq 'd'
    ) {
        $num = 5;
    } elsif($type eq 'c'
    or      $type eq 'C'
    ) {
        $num = 6;
    } else {
        $num = 0;
    }       
    unless(defined $out) {
        if(     $type eq 's'
        or      $type eq 'S'
        ) {
            $num = 51;
        } elsif($type eq 'b'
        or      $type eq 'B'
        ) {
            $num = 22;
        } elsif($type eq 'k'
        or      $type eq 'K'
        ) {
            $num = 101;
        }       
    }
    return $num;
}

sub parse_prototype {
    my($proto) = @_;
    
    my @in_params = ();
    my @in_types = ();
    if($proto =~ /^\s*(\S+)\s+(\S+)\s*\(([^\)]*)\)/) {
        my $ret = $1;
        my $proc = $2;
        my $params = $3;
        
        $params =~ s/^\s+//;
        $params =~ s/\s+$//;
        
        DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
        DEBUG "(PM)parse_prototype: got PARAMS '%s'\n", $params;
        
        foreach my $param (split(/\s*,\s*/, $params)) {
            my($type, $name);
            if($param =~ /(\S+)\s+(\S+)/) {
                ($type, $name) = ($1, $2);
            }
            
            if(Win32::API::Type::is_known($type)) {
                if(Win32::API::Type::is_pointer($type)) {
                    DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
                        $type, 
                        Win32::API::Type->packing( $type ), 
                        type_to_num('P');
                    push(@in_params, type_to_num('P'));
                } else {        
                    DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
                        $type, 
                        Win32::API::Type->packing( $type ), 
                        type_to_num( Win32::API::Type->packing( $type ) );
                    push(@in_params, type_to_num( Win32::API::Type->packing( $type ) ));
                }
            } elsif( Win32::API::Struct::is_known( $type ) ) {
                DEBUG "(PM)parse_prototype: IN='%s' PACKING='%s' API_TYPE=%d\n",
                    $type, 'S', type_to_num('S');
                push(@in_params, type_to_num('S'));
            } else {
                warn "Win32::API::parse_prototype: WARNING unknown parameter type '$type'";
                push(@in_params, type_to_num('I'));
            }
            push(@in_types, $type);
            
        }
        DEBUG "parse_prototype: IN=[ @in_params ]\n";


            
        if(Win32::API::Type::is_known($ret)) {
            if(Win32::API::Type::is_pointer($ret)) {
                DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
                    $ret, 
                    Win32::API::Type->packing( $ret ), 
                    type_to_num('P');
                return ( $proc, \@in_params, \@in_types, type_to_num('P') );
            } else {        
                DEBUG "parse_prototype: OUT='%s' PACKING='%s' API_TYPE=%d\n",
                    $ret, 
                    Win32::API::Type->packing( $ret ), 
                    type_to_num( Win32::API::Type->packing( $ret ) );
                return ( $proc, \@in_params, \@in_types, type_to_num(Win32::API::Type->packing($ret)) );
            }
        } else {
            warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
            return ( $proc, \@in_params, \@in_types, type_to_num('I') );
        }

    } else {
        warn "Win32::API::parse_prototype: bad prototype '$proto'";
        return undef;
    }
}   

1;

__END__

#######################################################################
# DOCUMENTATION
#

=head1 NAME

Win32::API - Perl Win32 API Import Facility

=head1 SYNOPSIS

  #### Method 1: with prototype

  use Win32::API;
  $function = Win32::API->new(
      'mydll, 'int sum_integers(int a, int b)',
  );
  $return = $function->Call(3, 2);
  
  #### Method 2: with parameter list
  
  use Win32::API;
  $function = Win32::API->new(
      'mydll', 'sum_integers', 'II', 'I',
  );
  $return = $function->Call(3, 2);
  
  #### Method 3: with Import
  
  use Win32::API;
  Win32::API->Import(
      'mydll', 'int sum_integers(int a, int b)',
  );  
  $return = sum_integers(3, 2);


=for LATER-UNIMPLEMENTED
  #### or
  use Win32::API mydll => 'int sum_integers(int a, int b)';
  $return = sum_integers(3, 2);


=head1 ABSTRACT

With this module you can import and call arbitrary functions
from Win32's Dynamic Link Libraries (DLL), without having
to write an XS extension. Note, however, that this module 
can't do anything (parameters input and output is limited 
to simpler cases), and anyway a regular XS extension is
always safer and faster. 

The current version of Win32::API is available at my website:

  http://dada.perl.it/

It's also available on your nearest CPAN mirror (but allow a few days 
for worldwide spreading of the latest version) reachable at:

  http://www.perl.com/CPAN/authors/Aldo_Calpini/

A short example of how you can use this module (it just gets the PID of 
the current process, eg. same as Perl's internal C<$$>):

    use Win32::API;
    Win32::API->Import("kernel32", "int GetCurrentProcessId()");
    $PID = GetCurrentProcessId();

The possibilities are nearly infinite (but not all are good :-).
Enjoy it.


=head1 CREDITS

All the credits go to Andrea Frosini 
for the neat assembler trick that makes this thing work.