summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Win32/API.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Win32/API.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Win32/API.pm266
1 files changed, 147 insertions, 119 deletions
diff --git a/Master/tlpkg/tlperl/lib/Win32/API.pm b/Master/tlpkg/tlperl/lib/Win32/API.pm
index 365ce6b46c5..8a08b01033a 100644
--- a/Master/tlpkg/tlperl/lib/Win32/API.pm
+++ b/Master/tlpkg/tlperl/lib/Win32/API.pm
@@ -4,30 +4,29 @@
#######################################################################
#
# Win32::API - Perl Win32 API Import Facility
-#
+#
# Author: Aldo Calpini <dada@perl.it>
# Maintainer: Cosimo Streppone <cosimo@cpan.org>
#
# Changes for gcc/cygwin: Daniel Risacher <magnus@alum.mit.edu>
# ported from 0.41 based on Daniel's patch by Reini Urban <rurban@x-ray.at>
#
-# $Id: API.pm 458 2009-01-17 17:27:43Z cosimo.streppone $
-#
#######################################################################
package Win32::API;
-require Exporter; # to export the constants to the main:: space
-require DynaLoader; # to dynuhlode the module.
+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 {
+sub DEBUG {
+ if ($Win32::API::DEBUG) {
+ printf @_ if @_ or return 1;
+ }
+ else {
return 0;
}
}
@@ -39,12 +38,12 @@ use File::Basename ();
#######################################################################
# STATIC OBJECT PROPERTIES
#
-$VERSION = '0.59';
+$VERSION = '0.68';
-#### some package-global hash to
-#### keep track of the imported
+#### some package-global hash to
+#### keep track of the imported
#### libraries and procedures
-my %Libraries = ();
+my %Libraries = ();
my %Procedures = ();
@@ -57,11 +56,12 @@ bootstrap Win32::API;
# PUBLIC METHODS
#
sub new {
- my($class, $dll, $proc, $in, $out, $callconvention) = @_;
- my $hdll;
+ my ($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ my $hdll;
my $self = {};
if ($^O eq 'cygwin' and $dll ne File::Basename::basename($dll)) {
+
# need to convert $dll to win32 path
# isn't there an API for this?
my $newdll = `cygpath -w "$dll"`;
@@ -71,41 +71,46 @@ sub new {
}
#### avoid loading a library more than once
- if(exists($Libraries{$dll})) {
+ if (exists($Libraries{$dll})) {
DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n";
$hdll = $Libraries{$dll};
- } else {
+ }
+ else {
DEBUG "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) {
+ if (!$hdll) {
$! = Win32::GetLastError();
- DEBUG "FAILED Loading library '$dll': $!\n";
- delete $Libraries{$dll};
+ DEBUG "FAILED Loading library '$dll': $!\n";
+ delete $Libraries{$dll};
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}, $self->{cdecl}) = parse_prototype( $proc );
+ if ((not defined $in) and (not defined $out)) {
+ ($proc, $self->{in}, $self->{intypes}, $self->{out}, $self->{cdecl}) =
+ parse_prototype($proc);
return undef unless $proc;
$self->{proto} = 1;
- } else {
+ }
+ else {
$self->{in} = [];
- if(ref($in) eq 'ARRAY') {
+ if (ref($in) eq 'ARRAY') {
foreach (@$in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
- } else {
+ push(@{$self->{in}}, type_to_num($_));
+ }
+ }
+ else {
my @in = split '', $in;
foreach (@in) {
- push(@{ $self->{in} }, type_to_num($_));
- }
+ push(@{$self->{in}}, type_to_num($_));
+ }
}
- $self->{out} = type_to_num($out);
+ $self->{out} = type_to_num($out);
$self->{cdecl} = calltype_to_num($callconvention);
}
@@ -113,20 +118,21 @@ sub new {
my $hproc = Win32::API::GetProcAddress($hdll, $proc);
#### ...then try appending either A or W (for ASCII or Unicode)
- if(!$hproc) {
+ 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) {
+ if (!$hproc) {
$! = Win32::GetLastError();
- DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
+ DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n";
return undef;
}
- DEBUG "GetProcAddress('$proc') = '$hproc'\n";
+ DEBUG "GetProcAddress('$proc') = '$hproc'\n";
#### ok, let's stuff the object
$self->{procname} = $proc;
@@ -138,7 +144,7 @@ sub new {
$Libraries{$dll} = $hdll;
$Procedures{$dll}++;
- DEBUG "Object blessed!\n";
+ DEBUG "Object blessed!\n";
#### cast the spell
bless($self, $class);
@@ -146,8 +152,9 @@ sub new {
}
sub Import {
- my($class, $dll, $proc, $in, $out, $callconvention) = @_;
- $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention) or return 0;
+ my ($class, $dll, $proc, $in, $out, $callconvention) = @_;
+ $Imported{"$dll:$proc"} = Win32::API->new($dll, $proc, $in, $out, $callconvention)
+ or return 0;
my $P = (caller)[0];
eval qq(
sub ${P}::$Imported{"$dll:$proc"}->{procname} { \$Win32::API::Imported{"$dll:$proc"}->Call(\@_); }
@@ -159,17 +166,17 @@ sub Import {
# PRIVATE METHODS
#
sub DESTROY {
- my($self) = @_;
+ my ($self) = @_;
#### decrease this library's procedures reference count
$Procedures{$self->{dllname}}--;
#### once it reaches 0, free it
- if($Procedures{$self->{dllname}} == 0) {
+ if ($Procedures{$self->{dllname}} == 0) {
DEBUG "Win32::API::DESTROY: Freeing library '$self->{dllname}'\n";
Win32::API::FreeLibrary($Libraries{$self->{dllname}});
delete($Libraries{$self->{dllname}});
- }
+ }
}
# Convert calling convention string (_cdecl|__stdcall)
@@ -192,132 +199,153 @@ sub calltype_to_num {
sub type_to_num {
my $type = shift;
- my $out = shift;
+ my $out = shift;
my $num;
-
- if( $type eq 'N'
- or $type eq 'n'
- or $type eq 'l'
- or $type eq 'L'
- ) {
+
+ 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'
- ) {
+ }
+ elsif ($type eq 'P'
+ or $type eq 'p')
+ {
$num = 2;
- } elsif($type eq 'I'
- or $type eq 'i'
- ) {
+ }
+ elsif ($type eq 'I'
+ or $type eq 'i')
+ {
$num = 3;
- } elsif($type eq 'f'
- or $type eq 'F'
- ) {
+ }
+ elsif ($type eq 'f'
+ or $type eq 'F')
+ {
$num = 4;
- } elsif($type eq 'D'
- or $type eq 'd'
- ) {
+ }
+ elsif ($type eq 'D'
+ or $type eq 'd')
+ {
$num = 5;
- } elsif($type eq 'c'
- or $type eq 'C'
- ) {
+ }
+ elsif ($type eq 'c'
+ or $type eq 'C')
+ {
$num = 6;
- } else {
+ }
+ else {
$num = 0;
- }
- unless(defined $out) {
- if( $type eq 's'
- or $type eq 'S'
- ) {
+ }
+ unless (defined $out) {
+ if ( $type eq 's'
+ or $type eq 'S')
+ {
$num = 51;
- } elsif($type eq 'b'
- or $type eq 'B'
- ) {
+ }
+ elsif ($type eq 'b'
+ or $type eq 'B')
+ {
$num = 22;
- } elsif($type eq 'k'
- or $type eq 'K'
- ) {
+ }
+ elsif ($type eq 'k'
+ or $type eq 'K')
+ {
$num = 101;
- }
+ }
}
return $num;
}
sub parse_prototype {
- my($proto) = @_;
-
+ my ($proto) = @_;
+
my @in_params = ();
- my @in_types = ();
- if($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
- my $ret = $1;
- my $callconvention= $2;
- my $proc = $3;
- my $params = $4;
-
+ my @in_types = ();
+ if ($proto =~ /^\s*(\S+)(?:\s+(\w+))?\s+(\S+)\s*\(([^\)]*)\)/) {
+ my $ret = $1;
+ my $callconvention = $2;
+ my $proc = $3;
+ my $params = $4;
+
$params =~ s/^\s+//;
$params =~ s/\s+$//;
-
- DEBUG "(PM)parse_prototype: got PROC '%s'\n", $proc;
+
+ 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+)/) {
+ 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)) {
+
+ 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,
+ Win32::API::Type->packing($type),
type_to_num('P');
push(@in_params, type_to_num('P'));
- } else {
+ }
+ 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 ) ));
+ $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 ) ) {
+ }
+ 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'";
+ }
+ 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)) {
+ 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 ),
+ $ret,
+ Win32::API::Type->packing($ret),
type_to_num('P');
- return ( $proc, \@in_params, \@in_types, type_to_num('P'), calltype_to_num($callconvention) );
- } else {
+ return ($proc, \@in_params, \@in_types, type_to_num('P'),
+ calltype_to_num($callconvention));
+ }
+ 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)), calltype_to_num($callconvention) );
+ $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)),
+ calltype_to_num($callconvention)
+ );
}
- } else {
- warn "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
- return ( $proc, \@in_params, \@in_types, type_to_num('I'), calltype_to_num($callconvention) );
+ }
+ else {
+ warn
+ "Win32::API::parse_prototype: WARNING unknown output parameter type '$ret'";
+ return ($proc, \@in_params, \@in_types, type_to_num('I'),
+ calltype_to_num($callconvention));
}
- } else {
+ }
+ else {
warn "Win32::API::parse_prototype: bad prototype '$proto'";
return undef;
}
-}
+}
1;
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-19 08:30:23 +0000