From e4e4edd07f3c87ab2cee948e63a70ba233547512 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Mon, 21 Jan 2008 12:21:36 +0000 Subject: Also updated API stuff in Perl5_lib-TL_ins git-svn-id: svn://tug.org/texlive/trunk@6348 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm | 745 +++++++++++++++++++++ .../tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig | 741 ++++++++++++++++++++ .../lib/Perl5_lib-TL_inst/Win32/API/Callback.pm | 174 +++++ .../lib/Perl5_lib-TL_inst/Win32/API/Struct.pm | 532 +++++++++++++++ .../tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm | 120 ++++ .../tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm | 446 ++++++++++++ .../lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs | 0 .../lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll | Bin 0 -> 20480 bytes .../auto/Win32/API/Callback/Callback.bs | 0 .../auto/Win32/API/Callback/Callback.dll | Bin 0 -> 16384 bytes Master/wingoo-demo.bat | 4 + Master/wingoo-demo.pl | 24 +- 12 files changed, 2780 insertions(+), 6 deletions(-) create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.bs create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm new file mode 100644 index 00000000000..e1bac5cda48 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm @@ -0,0 +1,745 @@ +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.47 +# Date: 12 Nov 2007 +# Author: Aldo Calpini +# Maintainer: Cosimo Streppone +# +# Changes for gcc/cygwin: Daniel Risacher +# ported from 0.41 based on Daniel's patch by Reini Urban +# +# $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; +BEGIN { + if ($^O eq 'cygwin') { + require File::Basename; + } +} + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = '0.47'; + +#### 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 = {}; + + 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"`; + chomp $newdll; + DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n"; + $dll = $newdll; + } + + #### avoid loading a library more than once + if(exists($Libraries{$dll})) { + DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; + $hdll = $Libraries{$dll}; + } 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) { + $! = Win32::GetLastError(); + 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}) = 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(); + DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n"; + return undef; + } + DEBUG "GetProcAddress('$proc') = '$hproc'\n"; + + #### 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}++; + + DEBUG "Object blessed!\n"; + + #### 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) { + DEBUG "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. +I've also used some work by Dave Roth for the prototyping stuff. +A big thank you also to Gurusamy Sarathy for his +unvaluable help in XS development, and to all the Perl community for +being what it is. + + +=head1 DESCRIPTION + +To use this module put the following line at the beginning of your script: + + use Win32::API; + +You can now use the C function of the Win32::API module to create a +new Win32::API object (see L) and then invoke the +C method on this object to perform a call to the imported API +(see L). + +Starting from version 0.40, you can also avoid creating a Win32::API object +and instead automatically define a Perl sub with the same name of the API +function you're importing. The details of the API definitions are the same, +just the call is different: + + my $GetCurrentProcessId = Win32::API->new( + "kernel32", "int GetCurrentProcessId()" + ); + my $PID = $GetCurrentProcessId->Call(); + + #### vs. + + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +Note that C returns 1 on success and 0 on failure (in which case you +can check the content of C<$^E>). + +=head2 IMPORTING A FUNCTION + +You can import a function from a 32 bit Dynamic Link Library (DLL) file +with the C function. This will create a Perl object that contains the +reference to that function, which you can later C. + +What you need to know is the prototype of the function you're going to import +(eg. the definition of the function expressed in C syntax). + +Starting from version 0.40, there are 2 different approaches for this step: +(the preferred) one uses the prototype directly, while the other (now deprecated) +one uses Win32::API's internal representation for parameters. + +=head2 IMPORTING A FUNCTION BY PROTOTYPE + +You need to pass 2 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The C prototype of the function. + +=back + +See L for a list of the known parameter types and +L for information on how to define a structure. + +=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST + +You need to pass 4 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The name of the function (as exported by the library). + +=item 3. +The number and types of the arguments the function expects as input. + +=item 4. +The type of the value returned by the function. + +=back + +To better explain their meaning, let's suppose that we +want to import and call the Win32 API C. +This function is defined in C as: + + DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); + +This is documented in the B; you can look +for it on the Microsoft's WWW site, or in your C compiler's +documentation, if you own one. + +=over 4 + +=item B<1.> + +The first parameter is the name of the library file that +exports this function; our function resides in the F +system file. +When specifying this name as parameter, the F<.DLL> extension +is implicit, and if no path is given, the file is searched through +a couple of directories, including: + +=over 4 + +=item 1. The directory from which the application loaded. + +=item 2. The current directory. + +=item 3. The Windows system directory (eg. c:\windows\system or system32). + +=item 4. The Windows directory (eg. c:\windows). + +=item 5. The directories that are listed in the PATH environment variable. + +=back + +So, you don't have to write F; +only F is enough: + + $GetTempPath = new Win32::API('kernel32', ... + +=item B<2.> + +Now for the second parameter: the name of the function. +It must be written exactly as it is exported +by the library (case is significant here). +If you are using Windows 95 or NT 4.0, you can use the B +command on the DLL file to see the function it exports. +Remember that you can only import functions from 32 bit DLLs: +in Quick View, the file's characteristics should report +somewhere "32 bit word machine"; as a rule of thumb, +when you see that all the exported functions are in upper case, +the DLL is a 16 bit one and you can't use it. +If their capitalization looks correct, then it's probably a 32 bit +DLL. + +Also note that many Win32 APIs are exported twice, with the addition of +a final B or B to their name, for - respectively - the ASCII +and the Unicode version. +When a function name is not found, Win32::API will actually append +an B to the name and try again; if the extension is built on a +Unicode system, then it will try with the B instead. +So our function name will be: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... + +In our case C is really loaded as C. + +=item B<3.> + +The third parameter, the input parameter list, specifies how many +arguments the function wants, and their types. It can be passed as +a single string, in which each character represents one parameter, +or as a list reference. The following forms are valid: + + "abcd" + [a, b, c, d] + \@LIST + +But those are not: + + (a, b, c, d) + @LIST + +The number of characters, or elements in the list, specifies the number +of parameters, and each character or element specifies the type of an +argument; allowed types are: + +=over 4 + +=item C: +value is an integer (int) + +=item C: +value is a number (long) + +=item C: +value is a floating point number (float) + +=item C: +value is a double precision number (double) + +=item C: +value is a char (char) + +=item C

: +value is a pointer (to a string, structure, etc...) + +=item C: +value is a Win32::API::Struct object (see below) + +=item C: +value is a Win32::API::Callback object (see L) + +=back + +Our function needs two parameters: a number (C) and a pointer to a +string (C): + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... + +=item B<4.> + +The fourth and final parameter is the type of the value returned by the +function. It can be one of the types seen above, plus another type named B +(for C), used for functions that do not return a value. +In our example the value returned by GetTempPath() is a C, so +our return type will be B: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + +Now the line is complete, and the GetTempPath() API is ready to be used +in Perl. Before calling it, you should test that $GetTempPath is +C, otherwise either the function or the library could not be +loaded; in this case, C<$!> will be set to the error message reported +by Windows. +Our definition, with error checking added, should then look like this: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + if(not defined $GetTempPath) { + die "Can't import API GetTempPath: $!\n"; + } + +=back + +=head2 CALLING AN IMPORTED FUNCTION + +To effectively make a call to an imported function you must use the +Call() method on the Win32::API object you created. +Continuing with the example from the previous paragraph, +the GetTempPath() API can be called using the method: + + $GetTempPath->Call(... + +Of course, parameters have to be passed as defined in the import phase. +In particular, if the number of parameters does not match (in the example, +if GetTempPath() is called with more or less than two parameters), +Perl will C an error message and C. + +The two parameters needed here are the length of the buffer +that will hold the returned temporary path, and a pointer to the +buffer itself. +For numerical parameters, you can use either a constant expression +or a variable, while B (no +Perl references, just a plain variable name). +Also note that B, +just like in C. +For example, to pass a buffer of 80 characters to GetTempPath(), +it must be initialized before with: + + $lpBuffer = " " x 80; + +This allocates a string of 80 characters. If you don't do so, you'll +probably get C errors, and generally nothing will +work. The call should therefore include: + + $lpBuffer = " " x 80; + $GetTempPath->Call(80, $lpBuffer); + +And the result will be stored in the $lpBuffer variable. +Note that you don't need to pass a reference to the variable +(eg. you B C<\$lpBuffer>), even if its value will be set +by the function. + +A little problem here is that Perl does not trim the variable, +so $lpBuffer will still contain 80 characters in return; the exceeding +characters will be spaces, because we said C<" " x 80>. + +In this case we're lucky enough, because the value returned by +the GetTempPath() function is the length of the string, so to get +the actual temporary path we can write: + + $lpBuffer = " " x 80; + $return = $GetTempPath->Call(80, $lpBuffer); + $TempPath = substr($lpBuffer, 0, $return); + +If you don't know the length of the string, you can usually +cut it at the C<\0> (ASCII zero) character, which is the string +delimiter in C: + + $TempPath = ((split(/\0/, $lpBuffer))[0]; + # or + $lpBuffer =~ s/\0.*$//; + +=head2 USING STRUCTURES + +Starting from version 0.40, Win32::API comes with a support package +named Win32::API::Struct. The package is loaded automatically with +Win32::API, so you don't need to use it explicitly. + +With this module you can conveniently define structures and use +them as parameters to Win32::API functions. A short example follows: + + + # the 'POINT' structure is defined in C as: + # typedef struct { + # LONG x; + # LONG y; + # } POINT; + + + #### define the structure + Win32::API::Struct->typedef( POINT => qw{ + LONG x; + LONG y; + }); + + #### import an API that uses this structure + Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); + + #### create a 'POINT' object + my $pt = Win32::API::Struct->new('POINT'); + + #### call the function passing our structure object + GetCursorPos($pt); + + #### and now, access its members + print "The cursor is at: $pt->{x}, $pt->{y}\n"; + +Note that this works only when the function wants a +B: as you can see, our structure is named +'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at +the beginning of the structure name when feeding it to a Win32::API +call. + +For more information, see also L. + +If you don't want (or can't) use the Win32::API::Struct facility, +you can still use the low-level approach to use structures: + + +=over 4 + +=item 1. +you have to pack() the required elements in a variable: + + $lpPoint = pack('LL', 0, 0); # store two LONGs + +=item 2. to access the values stored in a structure, unpack() it as required: + + ($x, $y) = unpack('LL', $lpPoint); # get the actual values + +=back + +The rest is left as an exercise to the reader... + +=head1 AUTHOR + +Aldo Calpini ( I ). + +=head1 MAINTAINER + +Cosimo Streppone ( I ) + +=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm new file mode 100644 index 00000000000..22de9d4f46a --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Callback.pm @@ -0,0 +1,174 @@ +package Win32::API::Callback; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Callback - Perl Win32 API Import Facility +# +# Author: Aldo Calpini +# Maintainer: Cosimo Streppone +# +# $Id: Callback.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +# +####################################################################### + +$VERSION = '0.47'; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +sub DEBUG { + if ($WIN32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +use Win32::API; +use Win32::API::Type; +use Win32::API::Struct; + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + $!=0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::API::Callback macro $constname, used at $file line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# dynamically load in the API extension module. +# +bootstrap Win32::API::Callback; + +####################################################################### +# PUBLIC METHODS +# +sub new { + my($class, $proc, $in, $out) = @_; + my %self = (); + + # printf "(PM)Callback::new: got proc='%s', in='%s', out='%s'\n", $proc, $in, $out; + + $self{in} = []; + if(ref($in) eq 'ARRAY') { + foreach (@$in) { + push(@{ $self{in} }, Win32::API::type_to_num($_)); + } + } else { + my @in = split '', $in; + foreach (@in) { + push(@{ $self{in} }, Win32::API::type_to_num($_)); + } + } + $self{out} = Win32::API::type_to_num($out); + $self{sub} = $proc; + my $self = bless \%self, $class; + + DEBUG "(PM)Callback::new: calling CallbackCreate($self)...\n"; + my $hproc = CallbackCreate($self); + + DEBUG "(PM)Callback::new: hproc=$hproc\n"; + + #### ...if that fails, set $! accordingly + if(!$hproc) { + $! = Win32::GetLastError(); + return undef; + } + + #### ok, let's stuff the object + $self->{code} = $hproc; + $self->{sub} = $proc; + + #### cast the spell + return $self; +} + +sub MakeStruct { + my($self, $n, $addr) = @_; + DEBUG "(PM)Win32::API::Callback::MakeStruct: got self='$self'\n"; + my $struct = Win32::API::Struct->new($self->{intypes}->[$n]); + $struct->FromMemory($addr); + return $struct; +} + +1; + +__END__ + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Callback - Callback support for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + use Win32::API::Callback; + + my $callback = Win32::API::Callback->new( + sub { my($a, $b) = @_; return $a+$b; }, + "NN", "N", + ); + + Win32::API->Import( + 'mydll', 'two_integers_cb', 'KNN', 'N', + ); + + $sum = two_integers_cb( $callback, 3, 2 ); + + +=head1 FOREWORDS + +=over 4 + +=item * +Support for this module is B at this point. + +=item * +I won't be surprised if it doesn't work for you. + +=item * +Feedback is very appreciated. + +=item * +Documentation is in the work. Either see the SYNOPSIS above +or the samples in the F directory. + +=back + +=head1 AUTHOR + +Aldo Calpini ( I ). + +=head1 MAINTAINER + +Cosimo Streppone ( I ). + +=cut + diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm new file mode 100644 index 00000000000..05a4c8c60a5 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Struct.pm @@ -0,0 +1,532 @@ +package Win32::API::Struct; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Struct - Perl Win32 API struct Facility +# +# Author: Aldo Calpini +# Maintainer: Cosimo Streppone +# +# $Id: Struct.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +$VERSION = '0.47'; + +use Win32::API::Type; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +my %Known = (); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +sub typedef { + my $class = shift; + my $struct = shift; + my($type, $name); + my $self = { + align => undef, + typedef => [], + }; + while(defined($type = shift)) { + $name = shift; + $name =~ s/;$//; + push( @{ $self->{typedef} }, [ recognize($type, $name) ] ); + } + + $Known{$struct} = $self; + return 1; +} + + +sub recognize { + my($type, $name) = @_; + my($size, $packing); + if(exists $Known{$type}) { + $packing = ">"; + return $name, $packing, $type; + } else { + $packing = Win32::API::Type::packing($type); + return undef unless defined $packing; + if($name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $packing."*".$size; + } + DEBUG "(PM)Struct::recognize got '$name', '$type' -> '$packing'\n"; + return $name, $packing, $type; + } +} + +sub new { + my $class = shift; + my($type, $name); + my $self = { + typedef => [], + }; + if($#_ == 0) { + if(exists $Known{$_[0]}) { + DEBUG "(PM)Struct::new: got '$_[0]'\n"; + $self->{typedef} = $Known{$_[0]}->{typedef}; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if($packing eq '>') { + $self->{$name} = Win32::API::Struct->new($type); + } + } + $self->{__typedef__} = $_[0]; + } else { + carp "Unknown Win32::API::Struct '$_[0]'"; + return undef; + } + } else { + while(defined($type = shift)) { + $name = shift; + # print "new: found member $name ($type)\n"; + if(not exists $Win32::API::Type::Known{$type}) { + warn "Unknown Win32::API::Struct type '$type'"; + return undef; + } else { + push( @{ $self->{typedef} }, [ $name, $Win32::API::Type::Known{$type}, $type ] ); + } + } + } + return bless $self; +} + +sub members { + my $self = shift; + return map {$_->[0]} @{ $self->{typedef} }; +} + +sub sizeof { + my $self = shift; + my $size = 0; + my $align = 0; + my $first = undef; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + $size += $self->{$name}->sizeof(); + # $align = $self->{$name}->sizeof() if $self->{$name}->sizeof() > $align; + } else { + if($packing =~ /\w\*(\d+)/) { + $size += Win32::API::Type::sizeof($type) * $1; + $first = Win32::API::Type::sizeof($type) * $1 unless defined $first; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } else { + $size += Win32::API::Type::sizeof($type); + $first = Win32::API::Type::sizeof($type) unless defined $first; + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + DEBUG "(PM)Struct::sizeof: sizeof with member($name) now = ". $size. "\n"; + } + } + } + DEBUG "(PM)Struct::sizeof first=$first align=$align\n"; + #DEBUG "(PM)Struct::sizeof returning %d\n", $first + (scalar(@{ $self->{typedef} })-1) * $align; + #return $first + (scalar(@{ $self->{typedef} })-1) * $align; + DEBUG "(PM)Struct::sizeof returning %d\n", scalar(@{ $self->{typedef} }) * $align; + if(defined $align and $align > 0) { + return scalar(@{ $self->{typedef} }) * $align; + } else { + return $size; + } + return $size; +} + +sub align { + my $self = shift; + my $align = shift; + + if(not defined $align) { + return $self->{align} unless $self->{align} eq 'auto'; + $align = 0; + foreach my $member (@{ $self->{typedef} }) { + my($name, $packing, $type) = @$member; + + if(ref( $self->{$name} ) eq "Win32::API::Struct") { + #### ???? + } else { + if($packing =~ /\w\*(\d+)/) { + #### ???? + } else { + $align = Win32::API::Type::sizeof($type) + if Win32::API::Type::sizeof($type) > $align; + } + } + } + return $align; + } else { + $self->{align} = $align; + + } +} + +sub getPack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my @recipients = (); + + my $align = $self->align(); + + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, $subitems, $subrecipients) = $self->{$name}->getPack(); + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $subpacking\n"; + + $packing .= $subpacking; + push(@items, @$subitems); + push(@recipients, @$subrecipients); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "a$size"; + } + + DEBUG "(PM)Struct::getPack($self->{__typedef__}) ++ $type\n"; + + if($type eq 'p') { + $type = "L"; + push(@items, Win32::API::PointerTo($self->{$name})); + } else { + push(@items, $self->{$name}); + } + $packing .= $type; + + if($Win32::API::Type::PackSize{$type} < $align) { + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@recipients, $self); + } + } + DEBUG "(PM)Struct::getPack: $self->{__typedef__}(buffer) = pack($packing, @items)\n"; + return($packing, [@items], [@recipients]); +} + + +sub Pack { + my $self = shift; + my($packing, $items, $recipients) = $self->getPack(); + DEBUG "(PM)Struct::Pack: $self->{__typedef__}(buffer) = pack($packing, @$items)\n"; + $self->{buffer} = pack($packing, @$items); + if(DEBUG) { + for my $i (0..$self->sizeof-1) { + printf " %3d: 0x%02x\n", $i, ord(substr($self->{buffer}, $i, 1)); + } + } + $self->{buffer_recipients} = $recipients +} + +sub getUnpack { + my $self = shift; + my $packing = ""; + my($type, $name); + my @items = (); + my $align = $self->align(); + foreach my $member (@{ $self->{typedef} }) { + ($name, $type, $orig) = @$member; + if($type eq '>') { + my($subpacking, @subitems) = $self->{$name}->getUnpack(); + + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $subpacking\n"; + $packing .= $subpacking; + + + push(@items, @subitems); + } else { + if($type =~ /\w\*(\d+)/) { + my $size = $1; + $type = "Z$size"; + } + + #if($type eq 'p') { + # $packing .= 'Z*'; + # DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ Z*\n"; + #} else { + $packing .= $type; + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}) ++ $type\n"; + #} + if($type ne 'p' and $type !~ /^Z(\d+)/ and $Win32::API::Type::PackSize{$type} < $align) { + DEBUG "(PM)Struct::getUnpack %s(%d) < %d\n", + $type, $Win32::API::Type::PackSize{$type}, $align + ; + $packing .= ("x" x ($align - $Win32::API::Type::PackSize{$type})); + } + + push(@items, $name); + } + } + DEBUG "(PM)Struct::getUnpack($self->{__typedef__}): unpack($packing, @items)\n"; + return($packing, @items); +} + +sub Unpack { + my $self = shift; + my($packing, @items) = $self->getUnpack(); + my @itemvalue = unpack($packing, $self->{buffer}); + DEBUG "(PM)Struct::Unpack: unpack($packing, buffer) = @itemvalue\n"; + foreach my $i (0..$#items) { + my $recipient = $self->{buffer_recipients}->[$i]; + DEBUG "(PM)Struct::Unpack: %s(%s) = '%s' (0x%08x)\n", + $recipient->{__typedef__}, + $items[$i], + $itemvalue[$i], + $itemvalue[$i], + ; + $recipient->{$items[$i]} = $itemvalue[$i]; + DEBUG "(PM)Struct::Unpack: self.$items[$i] = $self->{$items[$i]}\n"; + } +} + +sub FromMemory { + my($self, $addr) = @_; + DEBUG "(PM)Struct::FromMemory: doing Pack\n"; + $self->Pack(); + DEBUG "(PM)Struct::FromMemory: doing GetMemory( 0x%08x, %d )\n", $addr, $self->sizeof; + $self->{buffer} = Win32::API::ReadMemory( $addr, $self->sizeof ); + $self->Unpack(); + DEBUG "(PM)Struct::FromMemory: doing Unpack\n"; + DEBUG "(PM)Struct::FromMemory: structure is now:\n"; + $self->Dump() if DEBUG; + DEBUG "\n"; +} + +sub Dump { + my $self = shift; + my $prefix = shift; + foreach my $member (@{ $self->{typedef} }) { + ($name, $packing, $type) = @$member; + if( ref($self->{$name}) ) { + $self->{$name}->Dump($name); + } else { + printf "%-20s %-20s %-20s\n", $prefix, $name, $self->{$name}; + } + } +} + + +sub is_known { + my $name = shift; + if(exists $Known{ $name }) { + return 1; + } else { + if($name =~ s/^LP//) { + return exists $Known{ $name }; + } + return 0; + } +} + +sub TIEHASH { + return Win32::API::Struct::new(@_); +} + +sub EXISTS { + +} + +sub FETCH { + my $self = shift; + my $key = shift; + + if($key eq 'sizeof') { + return $self->sizeof; + } + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + return $self->{$key}; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub STORE { + my $self = shift; + my($key, $val) = @_; + my @members = map { $_->[0] } @{ $self->{typedef} }; + if(grep(/^\Q$key\E$/, @members)) { + $self->{$key} = $val; + } else { + warn "'$key' is not a member of Win32::API::Struct $self->{__typedef__}"; + } +} + +sub FIRSTKEY { + my $self = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + return $members[0]; +} + +sub NEXTKEY { + my $self = shift; + my $key = shift; + my @members = map { $_->[0] } @{ $self->{typedef} }; + for my $i (0..$#members-1) { + return $members[$i+1] if $members[$i] eq $key; + } + return undef; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Struct - C struct support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Struct->typedef( 'POINT', qw( + LONG x; + LONG y; + )); + + my $Point = Win32::API::Struct->new( 'POINT' ); + $Point->{x} = 1024; + $Point->{y} = 768; + + #### alternatively + + tie %Point, 'Win32::API::Struct', 'POINT'; + $Point{x} = 1024; + $Point{y} = 768; + + +=head1 ABSTRACT + +This module enables you to define C structs for use with +Win32::API. + +See L for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. The main methods are C and +C, which are documented below. + +=over 4 + +=item C + +This method defines a structure named C. The definition consists +of types and member names, just like in C. In fact, most of the +times you can cut the C definition for a structure and paste it +verbatim to your script, enclosing it in a C block. The +function takes care of removing the semicolon after the member +name. + +The synopsis example could be written like this: + + Win32::API::Struct->typedef('POINT', 'LONG', 'x', 'LONG', 'y'); + +But it could also be written like this (note the indirect object +syntax), which is pretty cool: + + typedef Win32::API::Struct POINT => qw{ + LONG x; + LONG y; + }; + +Also note that C automatically defines an 'LPNAME' type, +which holds a pointer to your structure. In the example above, +'LPPOINT' is also defined and can be used in a call to a +Win32::API (in fact, this is what you're really going to use when +doing API calls). + +=item C + +This creates a structure (a Win32::API::Struct object) of the +type C (it must have been defined with C). In Perl, +when you create a structure, all the members are undefined. But +when you use that structure in C (eg. a Win32::API call), you +can safely assume that they will be treated as zero (or NULL). + +=item C + +This returns the size, in bytes, of the structure. Acts just like +the C function of the same name. It is particularly useful for +structures that need a member to be initialized to the structure's +own size. + +=item C + +Sets or returns the structure alignment (eg. how the structure is +stored in memory). This is a very advanced option, and you normally +don't need to mess with it. +All structures in the Win32 Platform SDK should work without it. +But if you define your own structure, you may need to give it an +explicit alignment. In most cases, passing a C of 'auto' +should keep the world happy. + +=back + +=head2 THE C INTERFACE + +Instead of creating an object with the C method, you can +tie a hash, which will hold the desired structure, using the +C builtin function: + + tie %structure, Win32::API::Struct => 'NAME'; + +The differences between the tied and non-tied approaches are: + +=over 4 + +=item * +with tied structures, you can access members directly as +hash lookups, eg. + + # tied # non-tied + $Point{x} vs. $Point->{x} + +=item * +with tied structures, when you try to fetch or store a +member that is not part of the structure, it will result +in a warning, eg. + + print $Point{z}; + # this will warn: 'z' is not a member of Win32::API::Struct POINT + +=item * +when you pass a tied structure as a Win32::API parameter, +remember to backslash it, eg. + + # tied # non-tied + GetCursorPos( \%Point ) vs. GetCursorPos( $Point ) + +=back + +=head1 AUTHOR + +Aldo Calpini ( I ). + +=head1 MAINTAINER + +Cosimo Streppone ( I ). + +=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm new file mode 100644 index 00000000000..6cbeed6bfac --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Test.pm @@ -0,0 +1,120 @@ +# +# Win32::API::Test - Test helper package for Win32::API +# +# Version: 0.01 +# Date: 23 Dec 2006 +# Author: Cosimo Streppone +# +# $Id: API.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +# +package Win32::API::Test; + +sub compiler_name () { + use Config; + my $cc = $Config{ccname}; + if($cc eq 'cl' || $cc eq 'cl.exe') + { + $cc = 'cl'; + } + return($cc); +} + +sub compiler_version () { + use Config; + my $ver = $Config{ccversion} || 0; + if( $ver =~ /^(\d+\.\d+)/ ) + { + $ver = 0 + $1; + } + return($ver); +} + +# +# Run the compiler and get version from there... +# User might be running a compiler different from +# that used to build perl. +# For example, Cosimo does. For testing, of course. +# +# *** +# *** IT DOES NOT WORK NOW. +# *** FOR REASONS I DON'T KNOW, CL.EXE OUTPUTS ITS +# *** VERSION STRING IN THE FIRST TWO LINES THAT +# *** I'M NOT ABLE TO CATCH... +# *** +# +sub compiler_version_from_shell () { + my $cc = compiler_name(); + my $ver; + # MSVC + if($cc eq 'cl') + { + my @ver = `$cc`; + my $ver = join('',@ver); + print 'VER:'.$ver.':'."\n"; + if($ver =~ /Version (\d[\d\.]+)/ms ) + { + $ver = $1; + } + } + # GCC + elsif($cc eq 'cc' || $cc eq 'gcc' || $cc eq 'winegcc' ) + { + $ver = join('', `$cc --version`); + if($ver =~ /gcc.*(\d[\d+]+)/ms ) + { + $ver = $1; + } + } + # Borland C + elsif($cc eq 'bcc32' || $cc eq 'bcc') + { + $ver = join('', `$cc`); + if($ver =~ /Borland C\+\+ (\d[\d\.]+)/ms ) + { + $ver = $1; + } + } + return($ver); +} + +sub find_test_dll () { + require File::Spec; + my $dll_name = $_[0]; + my @paths = qw(.. ../t ../t/dll . ./dll ./t/dll); + while(my $path = shift @paths) + { + $dll = File::Spec->catfile($path, $dll_name); + return $dll if -s $dll; + } + return(undef); +} + +1; + +__END__ + + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Test - Test helper package for Win32::API + +=head1 SYNOPSIS + + my $test_dll = Win32::API::Test::find_test_dll('API_test.dll'); + +Check the t/*.t test scripts for more details. + +=head1 DESCRIPTION + +Simple package to hold Win32::API test suite helper functions. +No more, no less. + +=head1 AUTHOR + +Cosimo Streppone ( I ) + +=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm new file mode 100644 index 00000000000..334b0b731e1 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API/Type.pm @@ -0,0 +1,446 @@ +package Win32::API::Type; + +# See the bottom of this file for the POD documentation. Search for the +# string '=head'. + +####################################################################### +# +# Win32::API::Type - Perl Win32 API type definitions +# +# Author: Aldo Calpini +# Maintainer: Cosimo Streppone +# +# $Id: Type.pm,v 1.0 2001/10/30 13:57:31 dada Exp $ +####################################################################### + +$VERSION = '0.47'; + +use Carp; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. +@ISA = qw( Exporter DynaLoader ); + +use vars qw( %Known %PackSize %Modifier %Pointer ); + +sub DEBUG { + if ($Win32::API::DEBUG) { + printf @_ if @_ or return 1; + } else { + return 0; + } +} + +%Known = (); +%PackSize = (); +%Modifier = (); +%Pointer = (); + +# Initialize data structures at startup. +# Aldo wants to keep the approach. +# +my $section = 'nothing'; +foreach () { + next if /^\s*#/ or /^\s*$/; + chomp; + if( /\[(.+)\]/) { + $section = $1; + next; + } + if($section eq 'TYPE') { + my($name, $packing) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Known('$name') => '$packing'\n"; + $Known{$name} = $packing; + } elsif($section eq 'PACKSIZE') { + my($packing, $size) = split(/\s+/); + # DEBUG "(PM)Type::INIT: PackSize('$packing') => '$size'\n"; + $PackSize{$packing} = $size; + } elsif($section eq 'MODIFIER') { + my($modifier, $mapto) = split(/\s+/, $_, 2); + my %maps = (); + foreach my $item (split(/\s+/, $mapto)) { + my($k, $v) = split(/=/, $item); + $maps{$k} = $v; + } + # DEBUG "(PM)Type::INIT: Modifier('$modifier') => '%maps'\n"; + $Modifier{$modifier} = { %maps }; + } elsif($section eq 'POINTER') { + my($pointer, $pointto) = split(/\s+/); + # DEBUG "(PM)Type::INIT: Pointer('$pointer') => '$pointto'\n"; + $Pointer{$pointer} = $pointto; + } +} +close(DATA); + +sub new { + my $class = shift; + my($type) = @_; + my $packing = packing($type); + my $size = sizeof($type); + my $self = { + type => $type, + packing => $packing, + size => $size, + }; + return bless $self; +} + +sub typedef { + my $class = shift; + my($name, $type) = @_; + my $packing = packing($type, $name); + DEBUG "(PM)Type::typedef: packing='$packing'\n"; + my $size = sizeof($type); + $Known{$name} = $packing; + return 1; +} + + +sub is_known { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + return defined packing($type); + } +} + +sub sizeof { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return $self->{size}; + } else { + my $packing = packing($type); + if($packing =~ /(\w)\*(\d+)/) { + return $PackSize{ $1 } * $2; + } else { + return $PackSize{ $packing }; + } + } +} + +sub packing { + # DEBUG "(PM)Type::packing: called by ". join("::", (caller(1))[0,3]). "\n"; + my $self = shift; + my $is_pointer = 0; + if(ref($self) =~ /Win32::API::Type/) { + # DEBUG "(PM)Type::packing: got an object\n"; + return $self->{packing}; + } + my $type = ($self eq 'Win32::API::Type') ? shift : $self; + my $name = shift; + + # DEBUG "(PM)Type::packing: got '$type', '$name'\n"; + my($modifier, $size, $packing); + if(exists $Pointer{$type}) { + # DEBUG "(PM)Type::packing: got '$type', is really '$Pointer{$type}'\n"; + $type = $Pointer{$type}; + $is_pointer = 1; + } elsif($type =~ /(\w+)\s+(\w+)/) { + $modifier = $1; + $type = $2; + # DEBUG "(PM)packing: got modifier '$modifier', type '$type'\n"; + } + + $type =~ s/\*$//; + + if(exists $Known{$type}) { + if(defined $name and $name =~ s/\[(.*)\]$//) { + $size = $1; + $packing = $Known{$type}[0]."*".$size; + # DEBUG "(PM)Type::packing: composite packing: '$packing' '$size'\n"; + } else { + $packing = $Known{$type}; + if($is_pointer and $packing eq 'c') { + $packing = "p"; + } + # DEBUG "(PM)Type::packing: simple packing: '$packing'\n"; + } + if(defined $modifier and exists $Modifier{$modifier}->{$type}) { + # DEBUG "(PM)Type::packing: applying modifier '$modifier' -> '$Modifier{$modifier}->{$type}'\n"; + $packing = $Modifier{$modifier}->{$type}; + } + return $packing; + } else { + # DEBUG "(PM)Type::packing: NOT FOUND\n"; + return undef; + } +} + + +sub is_pointer { + my $self = shift; + my $type = shift; + $type = $self unless defined $type; + if(ref($type) =~ /Win32::API::Type/) { + return 1; + } else { + if($type =~ /\*$/) { + return 1; + } else { + return exists $Pointer{$type}; + } + } +} + +sub Pack { + my $type = $_[0]; + + if(packing($type) eq 'c' and is_pointer($type)) { + $_[1] = pack("Z*", $_[1]); + return $_[1]; + } + $_[1] = pack( packing($type), $_[1]); + return $_[1]; +} + +sub Unpack { + my $type = $_[0]; + if(packing($type) eq 'c' and is_pointer($type)) { + DEBUG "(PM)Type::Unpack: got packing 'c', is a pointer, unpacking 'Z*' '$_[1]'\n"; + $_[1] = unpack("Z*", $_[1]); + DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; + return $_[1]; + } + DEBUG "(PM)Type::Unpack: unpacking '".packing($type)."' '$_[1]'\n"; + $_[1] = unpack( packing($type), $_[1]); + DEBUG "(PM)Type::Unpack: returning '$_[1]'\n"; + return $_[1]; +} + +1; + +####################################################################### +# DOCUMENTATION +# + +=head1 NAME + +Win32::API::Type - C type support package for Win32::API + +=head1 SYNOPSIS + + use Win32::API; + + Win32::API::Type->typedef( 'my_number', 'LONG' ); + + +=head1 ABSTRACT + +This module is a support package for Win32::API that implements +C types for the import with prototype functionality. + +See L for more info about its usage. + +=head1 DESCRIPTION + +This module is automatically imported by Win32::API, so you don't +need to 'use' it explicitly. These are the methods of this package: + +=over 4 + +=item C + +This method defines a new type named C. This actually just +creates an alias for the already-defined type C, which you +can use as a parameter in a Win32::API call. + +=item C + +This returns the size, in bytes, of C. Acts just like +the C function of the same name. + +=item C + +Returns true if C is known by Win32::API::Type, false +otherwise. + +=back + +=head2 SUPPORTED TYPES + +This module should recognize all the types defined in the +Win32 Platform SDK header files. +Please see the source for this module, in the C<__DATA__> section, +for the full list. + +=head1 AUTHOR + +Aldo Calpini ( I ). + +=head1 MAINTAINER + +Cosimo Streppone ( I ). + +=cut + + +__DATA__ + +[TYPE] +ATOM s +BOOL L +BOOLEAN c +BYTE C +CHAR c +COLORREF L +DWORD L +DWORD32 L +DWORD64 Q +FLOAT f +HACCEL L +HANDLE L +HBITMAP L +HBRUSH L +HCOLORSPACE L +HCONV L +HCONVLIST L +HCURSOR L +HDC L +HDDEDATA L +HDESK L +HDROP L +HDWP L +HENHMETAFILE L +HFILE L +HFONT L +HGDIOBJ L +HGLOBAL L +HHOOK L +HICON L +HIMC L +HINSTANCE L +HKEY L +HKL L +HLOCAL L +HMENU L +HMETAFILE L +HMODULE L +HPALETTE L +HPEN L +HRGN L +HRSRC L +HSZ L +HWINSTA L +HWND L +INT i +INT32 i +INT64 q +LANGID s +LCID L +LCSCSTYPE L +LCSGAMUTMATCH L +LCTYPE L +LONG l +LONG32 l +LONG64 q +LONGLONG q +LPARAM L +LRESULT L +REGSAM L +SC_HANDLE L +SC_LOCK L +SERVICE_STATUS_HANDLE L +SHORT s +SIZE_T L +SSIZE_T L +TBYTE c +TCHAR C +UCHAR C +UINT I +UINT_PTR L +UINT32 I +UINT64 Q +ULONG L +ULONG32 L +ULONG64 Q +ULONGLONG Q +USHORT S +WCHAR S +WORD S +WPARAM L +VOID c + +int i +long l +float f +double d +char c + +#CRITICAL_SECTION 24 -- a structure +#LUID ? 8 -- a structure +#VOID 0 +#CONST 4 +#FILE_SEGMENT_ELEMENT 8 -- a structure + +[PACKSIZE] +c 1 +C 1 +d 8 +f 4 +i 4 +I 4 +l 4 +L 4 +q 8 +Q 8 +s 2 +S 2 +p 4 + +[MODIFIER] +unsigned int=I long=L short=S char=C + +[POINTER] +INT_PTR INT +LPBOOL BOOL +LPBYTE BYTE +LPCOLORREF COLORREF +LPCSTR CHAR +#LPCTSTR CHAR or WCHAR +LPCTSTR CHAR +LPCVOID any +LPCWSTR WCHAR +LPDWORD DWORD +LPHANDLE HANDLE +LPINT INT +LPLONG LONG +LPSTR CHAR +#LPTSTR CHAR or WCHAR +LPTSTR CHAR +LPVOID VOID +LPWORD WORD +LPWSTR WCHAR + +PBOOL BOOL +PBOOLEAN BOOL +PBYTE BYTE +PCHAR CHAR +PCSTR CSTR +PCWCH CWCH +PCWSTR CWSTR +PDWORD DWORD +PFLOAT FLOAT +PHANDLE HANDLE +PHKEY HKEY +PINT INT +PLCID LCID +PLONG LONG +PSHORT SHORT +PSTR CHAR +#PTBYTE TBYTE -- +#PTCHAR TCHAR -- +#PTSTR CHAR or WCHAR +PTSTR CHAR +PUCHAR UCHAR +PUINT UINT +PULONG ULONG +PUSHORT USHORT +PVOID VOID +PWCHAR WCHAR +PWORD WORD +PWSTR WCHAR diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.bs new file mode 100644 index 00000000000..e69de29bb2d diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll new file mode 100644 index 00000000000..3a7efc0adca Binary files /dev/null and b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/API.dll differ diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.bs b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.bs new file mode 100644 index 00000000000..e69de29bb2d diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll new file mode 100644 index 00000000000..147c679d576 Binary files /dev/null and b/Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Win32/API/Callback/Callback.dll differ diff --git a/Master/wingoo-demo.bat b/Master/wingoo-demo.bat index 629daae3495..a3589ba8d20 100755 --- a/Master/wingoo-demo.bat +++ b/Master/wingoo-demo.bat @@ -9,6 +9,7 @@ set tldrive=%~d0 cd %tlroot% rem we need wget in the path, so add tlpkg\bin to the path +set pathsave=%path% path %path%;%tlroot%tlpkg\bin rem use provided Perl @@ -17,11 +18,14 @@ set PERL5SAVE=%PERL5LIB% set PERL5LIB=%tlroot%tlpkg\lib\Perl5_lib-TL_inst "%tlroot%tlpkg\bin\perl" "%tlroot%wingoo-demo.pl" + pause Done rem cleanup in case of start from command-line set PERL5LIB=%PERL5SAVE% set PERL5SAVE= +path %pathsave% +set pathsave= set tldrive= set tlroot= diff --git a/Master/wingoo-demo.pl b/Master/wingoo-demo.pl index f4697e3c571..fec3ecdf48b 100644 --- a/Master/wingoo-demo.pl +++ b/Master/wingoo-demo.pl @@ -20,6 +20,7 @@ BEGIN { $::installerdir='.'; } unshift (@INC, "$::installerdir/tlpkg"); + # unshift (@INC, "$::installerdir/bin/win32") if $^O=~/^MSWin(32|64)$/i; } use TeXLive::TLWinGoo; # safe under Unix/Linux! @@ -44,6 +45,7 @@ sub print_search_paths { print "User path: ".get_user_path()."\n"; } +print ((join "\n", @INC)."\n"); # admin if (admin()) { @@ -75,7 +77,7 @@ print expand_string("pre\\%systemROOT%\\post")."\n"; # win_which_dir -print "cmd.exe found in " . win_which_dir("cmd.exe") . "\n"; +print "cmd.exe found in " . TeXLive::TLWinGoo::win_which_dir("cmd.exe") . "\n"; # adding and removing texbindir @@ -84,27 +86,37 @@ mkdir $wr_dir1 unless -e $wr_dir1; create_file( $wr_dir1."/tex.exe" ); add_texbindir_to_path($wr_dir1); print_search_paths(); -print "tex.exe found in " . win_which_dir("tex.exe") . "\n"; +print "tex.exe found in " . + TeXLive::TLWinGoo::win_which_dir("tex.exe") . "\n"; my $wr_dir2 = $wr_dir . "/tex2"; mkdir $wr_dir2 unless -e $wr_dir2; create_file( $wr_dir2."/tex.exe" ); add_texbindir_to_path($wr_dir2); print_search_paths(); -print "tex.exe found in " . win_which_dir("tex.exe") . "\n"; +print "tex.exe found in " . + TeXLive::TLWinGoo::win_which_dir("tex.exe") . "\n"; # the problem case: no admin, but TeX on system path if (!admin()) { - my $fn = expand_string("%windir%")."/tex.exe"; + my $fn = expand_string("%windir%")."/TEX.EXE"; $fn =~ s/\\/\//g; - create_file($fn); + create_file($fn); # a tex.exe on the system path! add_texbindir_to_path(expand_string($wr_dir2)); + my @wge = wg_error(); + if (@wge) { + print $wge[1]."\n"; + } print_search_paths(); - print "tex.exe found in " . win_which_dir("tex.exe") . "\n"; + print "tex.exe found in " . TeXLive::TLWinGoo::win_which_dir("tex.exe") . "\n"; unlink $fn; } # adding a filetype register_script_type(".rb","x:/ruby/bin/ruby.exe"); + +# broadcast environment changes + +broadcast_env(); -- cgit v1.2.3

: +value is a pointer (to a string, structure, etc...) + +=item C: +value is a Win32::API::Struct object (see below) + +=item C: +value is a Win32::API::Callback object (see L) + +=back + +Our function needs two parameters: a number (C) and a pointer to a +string (C): + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', ... + +=item B<4.> + +The fourth and final parameter is the type of the value returned by the +function. It can be one of the types seen above, plus another type named B +(for C), used for functions that do not return a value. +In our example the value returned by GetTempPath() is a C, so +our return type will be B: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + +Now the line is complete, and the GetTempPath() API is ready to be used +in Perl. Before calling it, you should test that $GetTempPath is +C, otherwise either the function or the library could not be +loaded; in this case, C<$!> will be set to the error message reported +by Windows. +Our definition, with error checking added, should then look like this: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', 'NP', 'N'); + if(not defined $GetTempPath) { + die "Can't import API GetTempPath: $!\n"; + } + +=back + +=head2 CALLING AN IMPORTED FUNCTION + +To effectively make a call to an imported function you must use the +Call() method on the Win32::API object you created. +Continuing with the example from the previous paragraph, +the GetTempPath() API can be called using the method: + + $GetTempPath->Call(... + +Of course, parameters have to be passed as defined in the import phase. +In particular, if the number of parameters does not match (in the example, +if GetTempPath() is called with more or less than two parameters), +Perl will C an error message and C. + +The two parameters needed here are the length of the buffer +that will hold the returned temporary path, and a pointer to the +buffer itself. +For numerical parameters, you can use either a constant expression +or a variable, while B (no +Perl references, just a plain variable name). +Also note that B, +just like in C. +For example, to pass a buffer of 80 characters to GetTempPath(), +it must be initialized before with: + + $lpBuffer = " " x 80; + +This allocates a string of 80 characters. If you don't do so, you'll +probably get C errors, and generally nothing will +work. The call should therefore include: + + $lpBuffer = " " x 80; + $GetTempPath->Call(80, $lpBuffer); + +And the result will be stored in the $lpBuffer variable. +Note that you don't need to pass a reference to the variable +(eg. you B C<\$lpBuffer>), even if its value will be set +by the function. + +A little problem here is that Perl does not trim the variable, +so $lpBuffer will still contain 80 characters in return; the exceeding +characters will be spaces, because we said C<" " x 80>. + +In this case we're lucky enough, because the value returned by +the GetTempPath() function is the length of the string, so to get +the actual temporary path we can write: + + $lpBuffer = " " x 80; + $return = $GetTempPath->Call(80, $lpBuffer); + $TempPath = substr($lpBuffer, 0, $return); + +If you don't know the length of the string, you can usually +cut it at the C<\0> (ASCII zero) character, which is the string +delimiter in C: + + $TempPath = ((split(/\0/, $lpBuffer))[0]; + # or + $lpBuffer =~ s/\0.*$//; + +=head2 USING STRUCTURES + +Starting from version 0.40, Win32::API comes with a support package +named Win32::API::Struct. The package is loaded automatically with +Win32::API, so you don't need to use it explicitly. + +With this module you can conveniently define structures and use +them as parameters to Win32::API functions. A short example follows: + + + # the 'POINT' structure is defined in C as: + # typedef struct { + # LONG x; + # LONG y; + # } POINT; + + + #### define the structure + Win32::API::Struct->typedef( POINT => qw{ + LONG x; + LONG y; + }); + + #### import an API that uses this structure + Win32::API->Import('user32', 'BOOL GetCursorPos(LPPOINT lpPoint)'); + + #### create a 'POINT' object + my $pt = Win32::API::Struct->new('POINT'); + + #### call the function passing our structure object + GetCursorPos($pt); + + #### and now, access its members + print "The cursor is at: $pt->{x}, $pt->{y}\n"; + +Note that this works only when the function wants a +B: as you can see, our structure is named +'POINT', but the API used 'LPPOINT'. 'LP' is automatically added at +the beginning of the structure name when feeding it to a Win32::API +call. + +For more information, see also L. + +If you don't want (or can't) use the Win32::API::Struct facility, +you can still use the low-level approach to use structures: + + +=over 4 + +=item 1. +you have to pack() the required elements in a variable: + + $lpPoint = pack('LL', 0, 0); # store two LONGs + +=item 2. to access the values stored in a structure, unpack() it as required: + + ($x, $y) = unpack('LL', $lpPoint); # get the actual values + +=back + +The rest is left as an exercise to the reader... + +=head1 AUTHOR + +Aldo Calpini ( I ). + +=head1 MAINTAINER + +Cosimo Streppone ( I ) + +=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig new file mode 100644 index 00000000000..9e4accd8bf6 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/API.pm.orig @@ -0,0 +1,741 @@ +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.47 +# Date: 12 Nov 2007 +# Author: Aldo Calpini +# Maintainer: Cosimo Streppone +# +# Changes for gcc/cygwin: Daniel Risacher +# ported from 0.41 based on Daniel's patch by Reini Urban +# +# $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; +use File::Basename (); + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = '0.47'; + +#### 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 = {}; + + 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"`; + chomp $newdll; + DEBUG "(PM)new: converted '$dll' to\n '$newdll'\n"; + $dll = $newdll; + } + + #### avoid loading a library more than once + if(exists($Libraries{$dll})) { + DEBUG "Win32::API::new: Library '$dll' already loaded, handle=$Libraries{$dll}\n"; + $hdll = $Libraries{$dll}; + } 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) { + $! = Win32::GetLastError(); + 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}) = 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(); + DEBUG "FAILED GetProcAddress for Proc '$proc': $!\n"; + return undef; + } + DEBUG "GetProcAddress('$proc') = '$hproc'\n"; + + #### 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}++; + + DEBUG "Object blessed!\n"; + + #### 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) { + DEBUG "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. +I've also used some work by Dave Roth for the prototyping stuff. +A big thank you also to Gurusamy Sarathy for his +unvaluable help in XS development, and to all the Perl community for +being what it is. + + +=head1 DESCRIPTION + +To use this module put the following line at the beginning of your script: + + use Win32::API; + +You can now use the C function of the Win32::API module to create a +new Win32::API object (see L) and then invoke the +C method on this object to perform a call to the imported API +(see L). + +Starting from version 0.40, you can also avoid creating a Win32::API object +and instead automatically define a Perl sub with the same name of the API +function you're importing. The details of the API definitions are the same, +just the call is different: + + my $GetCurrentProcessId = Win32::API->new( + "kernel32", "int GetCurrentProcessId()" + ); + my $PID = $GetCurrentProcessId->Call(); + + #### vs. + + Win32::API->Import("kernel32", "int GetCurrentProcessId()"); + $PID = GetCurrentProcessId(); + +Note that C returns 1 on success and 0 on failure (in which case you +can check the content of C<$^E>). + +=head2 IMPORTING A FUNCTION + +You can import a function from a 32 bit Dynamic Link Library (DLL) file +with the C function. This will create a Perl object that contains the +reference to that function, which you can later C. + +What you need to know is the prototype of the function you're going to import +(eg. the definition of the function expressed in C syntax). + +Starting from version 0.40, there are 2 different approaches for this step: +(the preferred) one uses the prototype directly, while the other (now deprecated) +one uses Win32::API's internal representation for parameters. + +=head2 IMPORTING A FUNCTION BY PROTOTYPE + +You need to pass 2 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The C prototype of the function. + +=back + +See L for a list of the known parameter types and +L for information on how to define a structure. + +=head2 IMPORTING A FUNCTION WITH A PARAMETER LIST + +You need to pass 4 parameters: + +=over 4 + +=item 1. +The name of the library from which you want to import the function. + +=item 2. +The name of the function (as exported by the library). + +=item 3. +The number and types of the arguments the function expects as input. + +=item 4. +The type of the value returned by the function. + +=back + +To better explain their meaning, let's suppose that we +want to import and call the Win32 API C. +This function is defined in C as: + + DWORD WINAPI GetTempPathA( DWORD nBufferLength, LPSTR lpBuffer ); + +This is documented in the B; you can look +for it on the Microsoft's WWW site, or in your C compiler's +documentation, if you own one. + +=over 4 + +=item B<1.> + +The first parameter is the name of the library file that +exports this function; our function resides in the F +system file. +When specifying this name as parameter, the F<.DLL> extension +is implicit, and if no path is given, the file is searched through +a couple of directories, including: + +=over 4 + +=item 1. The directory from which the application loaded. + +=item 2. The current directory. + +=item 3. The Windows system directory (eg. c:\windows\system or system32). + +=item 4. The Windows directory (eg. c:\windows). + +=item 5. The directories that are listed in the PATH environment variable. + +=back + +So, you don't have to write F; +only F is enough: + + $GetTempPath = new Win32::API('kernel32', ... + +=item B<2.> + +Now for the second parameter: the name of the function. +It must be written exactly as it is exported +by the library (case is significant here). +If you are using Windows 95 or NT 4.0, you can use the B +command on the DLL file to see the function it exports. +Remember that you can only import functions from 32 bit DLLs: +in Quick View, the file's characteristics should report +somewhere "32 bit word machine"; as a rule of thumb, +when you see that all the exported functions are in upper case, +the DLL is a 16 bit one and you can't use it. +If their capitalization looks correct, then it's probably a 32 bit +DLL. + +Also note that many Win32 APIs are exported twice, with the addition of +a final B or B to their name, for - respectively - the ASCII +and the Unicode version. +When a function name is not found, Win32::API will actually append +an B to the name and try again; if the extension is built on a +Unicode system, then it will try with the B instead. +So our function name will be: + + $GetTempPath = new Win32::API('kernel32', 'GetTempPath', ... + +In our case C is really loaded as C. + +=item B<3.> + +The third parameter, the input parameter list, specifies how many +arguments the function wants, and their types. It can be passed as +a single string, in which each character represents one parameter, +or as a list reference. The following forms are valid: + + "abcd" + [a, b, c, d] + \@LIST + +But those are not: + + (a, b, c, d) + @LIST + +The number of characters, or elements in the list, specifies the number +of parameters, and each character or element specifies the type of an +argument; allowed types are: + +=over 4 + +=item C: +value is an integer (int) + +=item C: +value is a number (long) + +=item C: +value is a floating point number (float) + +=item C: +value is a double precision number (double) + +=item C: +value is a char (char) + +=item C