diff --git a/Changes b/Changes new file mode 100644 index 0000000..d649774 --- /dev/null +++ b/Changes @@ -0,0 +1,59 @@ +Revision history for Perl extension C::DynaLib (formerly +ExtUtils::DynaLib, very formerly CLib). + +0.01 Thu Jun 12 01:17:41 1997 + - original version; created by h2xs 1.18 + +0.02 Sat Jun 14 19:22:36 1997 + First release, only "cdecl" convention supported. + +0.03 Sun Jun 15 22:56:26 1997 + Fixed problem with Perl prototypes. + +0.04 Tue Jun 17 04:15:57 1997 + Generalized the default calling convention; constructor +accepts filename; declare_sub accepts function pointer; added ``hack30'' +calling convention + +0.10 Wed Jun 18 13:31:07 EDT 1997 + Got `hack30' to return ints correctly on sparc/solaris. +Made compatible with perl 5.003. + +0.11 Thu Jun 19 23:43:29 1997 + Added sparc convention. + +0.12 Sun Jun 22 10:34:21 1997 + Minor stuff. Renamed to ExtUtils::DynaLib. + +0.13-0.14 Nicified for CPAN. + +0.20 Mon Jul 7 23:42:00 1997 + Support for callbacks. Major and minor bugfixes. + +0.21 Sat Jul 12 02:01:12 1997 + die works with callbacks (except in certain complex cases). +Added a few bits & pieces. +Sun's cc is now supported (thanks to lvirden@cas.org). + +0.22 Wed Jul 30 01:12 1997 + Renamed methods to avoid possible future keyword conflict: +declare_sub became DeclareSub, poke became Poke, etc. Added +ExtUtils::DynaLib::Struct package. Got it to work on Windows 95 with +Borland C++ (but probably not repeatably ;-) ) + +0.30 Mon Aug 11 00:58:55 1997 + Added testcall configuration utility to find system +dependencies for cdecl convention. Rewrote some docs. + +0.31 Thu Aug 28 23:42 1997 + Digital Unix on the Alpha is supported, at least for gcc, +thanks to help from Achim Bohnet . Added PTR_TYPE. + +0.50 Sat Sep 27 01:35:55 1997 + Much nicification and many added arg/return types. Rewrote +a lot of the guts. + +0.51 Fri Oct 3 23:55:27 1997 + Renamed as C::DynaLib. Fixed Makefile.PL bug that resulted +in NUL chars in DynaLib.c. Errors in loading libs, finding symbols, +and allocating callbacks are no longer fatal. diff --git a/DynaLib.pm b/DynaLib.pm new file mode 100644 index 0000000..b502435 --- /dev/null +++ b/DynaLib.pm @@ -0,0 +1,669 @@ +# As the saying goes: +# +# "Better to do it in Perl than C. +# Better to do it in C than Assembler. +# Better to do it in Assembler than V****l B***c." +# +package C::DynaLib; + +require 5.002; + +use strict; +no strict 'refs'; +use Carp; +use vars qw($VERSION @ISA $AUTOLOAD @EXPORT @EXPORT_OK $DefConv); +use subs qw(AUTOLOAD new LibRef DeclareSub DYNALIB_DEFAULT_CONV PTR_TYPE); + +@EXPORT = qw(PTR_TYPE); +@EXPORT_OK = qw(Poke DeclareSub); + +require DynaLoader; +require Exporter; + +@ISA = qw(DynaLoader Exporter); +$VERSION = '0.51'; +bootstrap C::DynaLib $VERSION, \$C::DynaLib::Callback::Config; + + +sub AUTOLOAD { + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my $val = constant($constname); + $! and croak "Undefined subroutine &$AUTOLOAD called"; + eval "sub $AUTOLOAD { '$val' }"; + goto &$AUTOLOAD; +} + +$DefConv = DYNALIB_DEFAULT_CONV; + +# Cache of loaded lib refs. Maybe best left to DynaLoader? +my %loaded_libs = (); + +sub new { + my $class = shift; + scalar(@_) == 1 + or croak 'Usage: $lib = new C::DynaLib "-lc" (for example)'; + my ($libname) = @_; + return $loaded_libs{$libname} if exists($loaded_libs{$libname}); + my $so = $libname; + -e $so or $so = DynaLoader::dl_findfile($libname) || $libname; + my $lib = DynaLoader::dl_load_file($so) + or return undef; + return $loaded_libs{$libname} = bless \$lib, $class; +} + +sub LibRef { + ${$_[0]}; +} + +sub DeclareSub { + local ($@); # We eval $obj->isa and $obj->can for 5.003 compatibility. + my $self = shift; + + # Calling as a method is equivalent to supplying the "libref" + # named arg. + my $is_method; + $is_method = ref($self) && eval { $self->isa("C::DynaLib") }; + $@ and $is_method = (ref($self) eq 'C::DynaLib'); + my $first = ($is_method ? shift : $self); + + my ($libref, $name, $ptr, $convention, $ret_type, @arg_type); + if (ref($first) eq 'HASH') { + # Using named parameters. + ! @_ && (($ptr = $first->{ptr}) || defined($name = $first->{name})) + or croak 'Usage: $lib->DeclareSub({ "name" => $func_name [, "return" => $ret_type] [, "args" => \@arg_types] [, "decl" => $decl] })'; + $convention = $first->{decl} || $DefConv; + $ret_type = $first->{'return'} || ''; + @arg_type = @{ $first->{args} || [] }; + $libref = $first->{'libref'}; + } else { + # Using positional parameters. + ($is_method ? $name : $ptr) = $first + or croak 'Usage: $lib->DeclareSub( $func_name [, $return_type [, \@arg_types]] )'; + $convention = $DefConv; + $ret_type = shift || ''; + @arg_type = @_; + } + unless ($ptr) { + $libref ||= $is_method && $self->LibRef() + or croak 'C::DynaLib::DeclareSub: non-method form requires a "ptr" or "libref"'; + $ptr = eval { DynaLoader::dl_find_symbol($libref, $name) }; + if ($@ || ! $ptr) { + warn "Can't find symbol \"$name\": ", $@ || DynaLoader::dl_error() + if $^W; + return undef; + } + } + + my $glue_sub_name = $convention . '_call_packed'; + + my $glue_sub = ($is_method && eval { $self->can($glue_sub_name) }) + || (defined(&{"$glue_sub_name"}) && \&{"$glue_sub_name"}); + if (! $glue_sub) { + warn "Unsupported calling convention: \"$convention\"" + if $^W; + return undef; + } + + return sub { + &{$glue_sub}($ptr, $ret_type, map { pack($_, shift) } @arg_type); + }; +} + +package C::DynaLib::Callback; + +use strict; +use Carp; +use vars qw($Config $CONFIG_TEMPLATE $empty); +use subs qw(new Ptr DESTROY); + +$CONFIG_TEMPLATE = + C::DynaLib::PTR_TYPE . "pp" . C::DynaLib::PTR_TYPE; +$empty = ""; + +sub new { + my $class = shift; + my $self = []; + my ($index, $coderef); + my ($codeptr, $ret_type, $arg_type, @arg_type, $func); + for ($index = 0; $index <= $#{$Config}; $index++) { + ($codeptr, $ret_type, $arg_type, $func) + = unpack($CONFIG_TEMPLATE, $Config->[$index]); + last unless $codeptr; + } + if ($index > $#{$Config}) { + warn "Limit of ", scalar(@$Config), " callbacks exceeded" + if ($^W); + return undef; + } + ($coderef, $ret_type, @arg_type) = @_; + unshift @$self, $coderef; + if (ref($coderef) eq 'CODE') { + "$coderef" =~ /\(0x([\da-f]+)\)/; + $codeptr = hex($1); + } else { + \$self->[0] =~ /\(0x([\da-f]+)\)/; + $codeptr = hex($1); + } + $arg_type = join('', @arg_type); + unshift @$self, $codeptr, $ret_type, $arg_type, $func, $index; + $Config->[$index] = pack($CONFIG_TEMPLATE, @$self); + return bless $self, $class; +} + +sub Ptr { + $_[0]->[3]; +} + +sub DESTROY { + my $self = shift; + my ($codeptr, $ret_type, $arg_type, $func, $index) + = @$self; + $Config->[$index] = pack($CONFIG_TEMPLATE, 0, $empty, $empty, $func); +} + +package C::DynaLib; +1; +__END__ + +=head1 NAME + +C::DynaLib - Perl extension for calling dynamically loaded C +functions + +=head1 SYNOPSIS + + use C::DynaLib; + use sigtrap; # recommended + + $lib = new C::DynaLib( $linker_arg ); + + $func = $lib->DeclareSub( $symbol_name + [, $return_type [, @arg_types] ] ); + # or + $func = $lib->DeclareSub( { "name" => $symbol_name, + ["return" => $return_type,] + ["args" => \@arg_types,] + ["decl" => $decl,] + } ); + $result = $func->( @args ); + + use C::DynaLib qw(DeclareSub); + $func = DeclareSub( $function_pointer, + [, $return_type [, @arg_types] ] ); + # or + $func = DeclareSub( { "ptr" => $function_pointer, + ["return" => $return_type,] + ["args" => \@arg_types,] + ["decl" => $decl,] + ["libref" => $libref,] + } ); + $result = $func->( @args ); + + $callback = new C::DynaLib::Callback( \&my_sub, + $return_type, @arg_types ); + $callback_pointer = $callback->Ptr(); + +=head1 PLUG FOR PERL XS + +If you have a C compiler that Perl supports, you will get better +results by writing XSubs than by using this module. I guarantee it. +It may take you longer to do what you want, but your code will be much +more solid and portable. See L. + +This module brings "pointers" to Perl. Perl's non-use of pointers is +one of its great strengths. If you don't know what I mean, then maybe +you ought to practice up a bit on C or C++ before using this module. +If anything, pointers are more dangerous in Perl than in C, due to +Perl's dynamic nature. + +The XSub interface and Perl objects provide a means of calling C and +C++ code while preserving Perl's abstraction from pointers. Once +again, I urge you to check out L! It's really cool!!! + +=head1 DESCRIPTION + +This module allows Perl programs to call C functions in dynamic +libraries. It is useful for testing library functions, writing simple +programs without the bother of XS, and generating C function pointers +that call Perl code. + +Your Perl must be of the dynamic variety and have a working +F to use the dynamic loading capabilities of this module. +Be sure you answered "y" when F (from the Perl source kit) +asked, "Do you wish to use dynamic loading?". + +The mechanics of passing arguments to and returning values from C +functions vary greatly among machines, operating systems, and +compilers. Therefore, F checks the Perl configuration and +may even compile and run a test program before the module is built. + +This module is divided into two packages, C and +C. Each makes use of Perl objects (see +L) and provides its own constructor. + +A C object corresponds to a dynamic library whose +functions are available to Perl. A C object +corresponds to a Perl sub which may be accessed from C. + +=head2 C public constructor + +The argument to C may be the file name of a dynamic library. +Alternatively, a linker command-line argument (e.g., C<"-lc">) may be +specified. See L for details on how such arguments are +mapped to file names. + +On failure, C returns C. Error information I be +obtainable by calling C. + +=head2 Declaring a library routine + +Before you can call a function in a dynamic library, you must specify +its name, the return type, and the number and types of arguments it +expects. This is handled by C. + +C can be used as either an object method or an +ordinary sub. You can pass its arguments either in a list (what we +call I) or in a hash (I). + +The simplest way to use C is as a method with positional +parameters. This form is illustrated in the first example above and +both examples below. When used in this way, the first argument is a +library function name, the second is the function return type, and the +rest are function argument types. + +B. You must not forget to specify the return +type as the second argument to C. If the function returns +C, you should use C<""> as the second argument. + +C data types are specified using the codes used by Perl's C and +C operators. See L for their description. As a +convenience (and to hide system dependencies), C is defined +as a code suitable for pointer types (typically C<"i">). + +The possible arguments to C are shown below. Each is +listed under the name that is used when passing the arguments in a +hash. + +=over 4 + +=item C + +The name of a function exported by C<$lib>. This argument is ignored +in the non-method forms of C. + +=item C + +The address of the C function. This argument is required in the +non-method forms of C. Either it or the C must be +specified in the method forms. + +=item C + +The return type of the function, encoded for use with the C +operator. Not all of the C codes are supported, but the +unsupported ones mostly don't make sense as C return types. + +Many C functions return pointers to various things. If you have a +function that returns C> and all you're interested in is the +string (i.e., the C sequence pointed to, up to the first nul), +then you may use C<"p"> as the return type. The C<"P"> code (followed +by a number of bytes) is also permissible. + +For the case where a returned pointer value must be remembered (for +example, I), use C. The returned scalar will be +the pointer itself, not the thing pointed to. + +=item C + +A list of the types of arguments expected by the function, specified +using the notation of Perl's C operator. For example, C<"i"> +means an integer, C<"d"> means a double, and C<"p"> means a +nul-terminated string pointer. If you need to handle pointers to +things other than Perl scalars, use type C. + +Note: you probably don't want to use C<"c"> or C<"s"> here, since C +normally converts the corresponding types (C and C) to +C when passing them to a function. The C::DynaLib package +may or may not perform such conversions. Use C<"i"> instead. +Likewise, use C<"I"> in place of C<"C"> or C<"S">, and C<"d"> in place +of C<"f">. Stick with C<"i">, C<"I">, C<"d">, C<"p">, C<"P">, and +C if you want to be safe. + +=item C + +Allows you to specify a function's calling convention. This is +possible only with a named-parameter form of C. See below +for information about the supported calling conventions. + +=item C + +A library reference obtained from either C +or the C method. You must use a named-parameter +form of C in order to specify this argument. + +=back + +=head2 Calling a declared function + +The returned value of C is a code reference. Calling +through it results in a call to the C function. See L on +how to use code references. + +=head2 Using callback routines + +Some C functions expect a pointer to another C function as an +argument. The library code that receives the pointer may use it to +call an application function at a later time. Such functions are +called I. + +This module allows you to use a Perl sub as a C callback, subject to +certain restrictions. There is a hard-coded maximum number of +callbacks that can be active at any given time. The default (4) may +be changed by specifying C on the F +command line. + +A callback's argument and return types are specified using C +codes, as described above for library functions. Currently, the +return value must be interpretable as type C or C, so the +only valid codes are C<"i">, C<"I">, and C<"">. There are also +restrictions on the permissible argument types, especially for the +first argument position. These limitations are considered bugs to be +fixed someday. + +To enable a Perl sub to be used as a callback, you must construct an +object of class C. The syntax is + + $cb_ref = new C::DynaLib::Callback( \&some_sub, + $ret_type, @arg_types ); + +where C<$ret_type> and C<@arg_types> are the C-style types of +the function return value and arguments, respectively. C<\&some_sub> +must be a code reference (see L). + +C<$cb_ref-EPtr()> then returns a function pointer. C code that +calls it will end up calling C<&some_sub>. + +=head1 EXAMPLES + +This code loads and calls the math library function I. It +assumes that you have a dynamic version of the math library which will +be found by C. If this doesn't work, +replace C<"-lm"> with the name of your dynamic math library. + + use C::DynaLib; + $libm = new C::DynaLib("-lm"); + $sinh = $libm->DeclareSub("sinh", "d", "d"); + print "The hyperbolic sine of 3 is ", &{$sinh}(3), "\n"; + # The hyperbolic sine of 3 is 10.0178749274099 + +The following example uses the C library's I to compare the +first I characters of two strings: + + use C::DynaLib; + $libc = new C::DynaLib("-lc"); + $strncmp = $libc->DeclareSub("strncmp", "i", "p", "p", "I"); + $string1 = "foobar"; + $string2 = "foolish"; + $result = &{$strncmp}($string1, $string2, 3); # $result is 0 + $result = &{$strncmp}($string1, $string2, 4); # $result is -1 + +The files F and F contain examples using +callbacks. + +=head1 CALLING CONVENTIONS + +This section is intended for anyone who's interested in debugging or +extending this module. You probably don't need to read it just to +I the module. + +=head2 The problem + +The hardest thing about writing this module is to accommodate the +different calling conventions used by different compilers, operating +systems, and CPU types. + +"What's a calling convention?" you may be wondering. It is how +compiler-generated functions receive their arguments from and make +their return values known to the code that calls them, at the level of +machine instructions and registers. Each machine has a set of rules +for this. Compilers and operating systems may use variations even on +the same machine type. In some cases, it is necessary to support more +than one calling convention on the same system. + +"But that's all handled by the compiler!" you might object. True +enough, if the calling code knows the signature of the called function +at compile time. For example, consider this C code: + + int foo(double bar, const char *baz); + ... + int res; + res = foo(sqrt(2.0), "hi"); + +A compiler will generate specific instruction sequences to load the +return value from I and a pointer to the string C<"hi"> into +whatever registers or memory locations I expects to receive +them in, based on its calling convention and the types C and +C>. Another specific instruction sequence stores the return +value in the variable C. + +But when you compile the C code in this module, it must be general +enough to handle all sorts of function argument and return types. + +"Why not use varargs/stdarg?" Most C compilers support a special set +of macros that allow a function to receive a variable number of +arguments of variable type. When the function receiving the arguments +is compiled, it does not know with what argument types it will be +called. + +But the code that I such a function I know at compile +time how many and what type of arguments it is passing to the varargs +function. There is no "reverse stdarg" standard for passing types to +be determined at run time. You can't simply pass a C to a +function unless that function is defined to receive a C. +This module uses varargs/stdarg where appropriate, but the only +appropriate place is in the callback support. + +=head2 The solution (well, half-solution) + +Having failed to find a magic bullet to spare us from the whims of +system designers and compiler writers, we are forced to examine the +calling conventions in common use and try to put together some "glue" +code that stands a chance of being portable. + +In writing glue code (that which allows code written in one language +to call code in another), an important issue is reliability. If we +don't get the convention just right, chances are we will get a core +dump (protection fault or illegal instruction). To write really solid +Perl-to-C glue, we would have to use assembly language and have +detailed knowledge of each calling convention. Compiler source code +can be helpful in this regard, and if your compiler can output +assembly code, that helps, too. + +However, this is Perl, Perl is meant to be ported, and assembly +language is generally not portable. This module typically uses C +constructs that happen to work most of the time, as opposed to +assembly code that follows the conventions faithfully. I expect the +use of assembly language to increase, however. + +By avoiding the use of assembly, we lose some reliability and +flexibility. By loss of reliability, I mean we can expect crashes, +especially on untested platforms. Lost flexibility means having +restrictions on what parameter types and return types are allowed. + +The code for all conventions other than C (described below) +relies on the C I function. Unfortunately, I +itself is not standard, so its use introduces new portability +concerns. For C, the most general convention, F +creates and runs a test program to try to ferret out any compiler +peculiarities regarding I. If the test program fails, the +default choice becomes C. + +=head2 Supported conventions + +C currently supports the parameter-passing conventions +listed below. The module can be compiled with support for one or more +of them by specifying (for example) C on F's +command-line. If none are given, F will try to choose +based on your Perl configuration and/or the results of running a test +program. + +At run time, a calling convention may be specified using a +named-parameter form of C (described above), or a default +may be used. The first C supplied to F will be +the default convention. + +Note that the convention must match that of the function in the +dynamic library, otherwise crashes are likely to occur. + +=over 4 + +=item C + +All arguments are placed on the stack in reverse order from how the +function is invoked. This seems to be the default for Intel-based +machines and possibly others. + +=item C + +The first 6 machine words of arguments are cast to an array of six +Cs. The remaining args (and possibly piece of an arg) are placed +on the stack. Then the C function is called as if it expected six +integer arguments. On a Sparc, the six "pseudo-arguments" are passed +in special registers. + +=item C + +This is similar to the C convention, but the pseudo-arguments +have type C instead of C, and all arguments are extended to +8 bytes before being placed in the array. On the Alpha, a special +sequence of inline assembly instructions is used to ensure that any +function parameters of type C are passed correctly. + +=item C + +This is not really a calling convention, it's just some C code that +will successfully call a function most of the time on a variety of +systems. All arguments are copied into an array of 6 long integers +(or 30 if 6 is not enough). The function is called as if it expected +6 (or 30) long arguments. + +You will run into problems if the C function either (1) takes more +arguments than can fit in the array, (2) takes some non-long arguments +on a system that passes them differently from longs (but C +currently has the same flaw), or (3) cares if it is passed extra +arguments (Win32 API functions crash because of this). + +Because of these problems, the use of C is recommended only as +a quick fix until your system's calling convention is supported. + +=back + +=head1 BUGS + +Several unresolved issues surround this module. + +=head2 Portability + +The "glue" code that allows Perl values to be passed as arguments to C +functions is architecture-dependent. This is because the author knows +of no standard means of determining a system's parameter-passing +conventions or passing arguments to a C function whose signature is +not known at compile time. + +Although some effort is made in F to find out how +parameters are passed in C, this applies only to the integer type +(Perl's C, to be precise; see L). Functions that +recieve or return type C, for example, may not work on systems +that use floating-point registers for this purpose. + +=head2 Robustness + +Usually, Perl programs run under the control of the Perl interpreter. +Perl is extremely stable and can almost guarantee an environment free +of the problems of C, such as bad pointers causing memory access +violations. Some modules use a Perl feature called "XSubs" to call C +code directly from a Perl program. In such cases, a crash may occur +if the C or XS code is faulty. However, once the XS module has been +sufficiently debugged, one can be reasonably sure that it will work +right. + +C code called through this module lacks such protection. Since the +association between Perl and C is made at run time, errors due to +incompatible library interfaces or incorrect assumptions have a much +greater chance of causing a crash than with either straight Perl or XS +code. + +=head2 Security + +This module does not require special privileges to run, and I have no +reason to think it contains any security bugs. However, when it is +installed, Perl programs gain great power to invoke C code which could +potentially have such bugs. I'm not really sure whether this is a +major issue or not. + +=head2 Deallocation of Resources + +To maximize portability, this module uses the F interface +to dynamic library linking. F's main purpose is to +support XS modules, which are loaded once by a program and not (to my +knowledge) unloaded. It would be nice to be able to free the +libraries loaded by this module when they are no longer needed. This +is impossible, since F currently provides no means to do +so. + +=head2 Literal and temporary strings + +Before Perl 5.00402, it was impossible to pass a string literal as a +pointer-to-nul-terminated-string argument of a C function. For +example, the following statement (incorrectly) produced the error +C: + + &$strncmp("foo", "bar", 3); + +To work around this problem, one must assign the value to a variable +and pass the variable in its place, as in + + &$strncmp($dummy1 = "foo", $dummy2 = "bar", 3); + +=head2 Callbacks + +Callbacks can mess up the message produced by C in the presence +of nested Cs. The Callback code uses global static data. + +=head2 Miscellaneous Bugs + +There is not enough error checking. Errors are often reported as +being in F when they're really in the caller's code. +There are too many restrictions on what C data types may be used. +Using argument types of unusual size may have nasty results. The +techniques used to pass values to and from C functions are all rather +hackish and nonstandard. Assembly code would be more complete. + +=head1 TODO + +Fix the bugs (see above). Fiddle with autoloading so we don't have to +call DeclareSub all the time. Mangle C++ symbol names. Get Perl to +understand C header files (macros and function declarations) with +enough confidence to make them useful here. + +=head1 LICENSE + +Copyright (c) 1997 by John Tobey. This package is distributed under +the same license as Perl itself. There is no expressed or implied +warranty, since it is free software. See the file README in the top +level Perl source directory for details. The Perl source may be found +at + + http://www.perl.com/CPAN/src/ + +=head1 AUTHOR + +John Tobey, jtobey@channel1.com + +=head1 SEE ALSO + +L, L (for C), L, +L, L, L. + +=cut diff --git a/DynaLib.xs b/DynaLib.xs new file mode 100644 index 0000000..d6bded9 --- /dev/null +++ b/DynaLib.xs @@ -0,0 +1,381 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef PATCHLEVEL +# include "patchlevel.h" +#endif +#ifndef SUBVERSION +# define SUBVERSION 0 +#endif +#ifdef __cplusplus +} +#endif + +/* When exactly was UV born? */ +#if PATCHLEVEL < 3 || (PATCHLEVEL == 3 && SUBVERSION < 10) +# define sv_setuv(sv,uv) sv_setnv(sv,(double)(unsigned long)(uv)) +# ifndef UV +# define UV IV +# endif +# ifndef U32 +# define U32 I32 +# define U16 I16 +# endif +# ifndef POPu +# define POPu POPi +# endif +#endif + +/* First i such that ST(i) is a func arg */ +#define DYNALIB_ARGSTART 2 + +static char * +constant(name) +char *name; +{ + errno = 0; + switch (*name) { + case 'D' : + if (strEQ(name, "DYNALIB_DEFAULT_CONV")) { + return DYNALIB_DEFAULT_CONV; + } + break; + case 'P' : + if (strEQ(name, "PTR_TYPE")) { + if (sizeof (void *) == sizeof (int)) + /* XXX Might be nice to make pointers unsigned, but the UV + code in this module is too new. */ + /* XXX on the other hand, maybe pointers are signed? */ + return "i"; +#ifdef HAS_QUAD + if (sizeof (void *) == sizeof (Quad_t)) + return "q"; +#endif + if (sizeof (void *) == sizeof (I32)) + return "l"; + if (sizeof (void *) == sizeof (I16)) + return "s"; + croak("Can't find an integer type that's the same size as pointers."); + } + break; + } + errno = EINVAL; + return 0; +} + +#ifdef DYNALIB_USE_cdecl +#include "cdecl.c" +#endif +#ifdef DYNALIB_USE_sparc +#include "sparc.c" +#endif +#ifdef DYNALIB_USE_alpha +#include "alpha.c" +#endif +#ifdef DYNALIB_USE_hack30 +#include "hack30.c" +#endif + +#ifndef DYNALIB_NUM_CALLBACKS +#define DYNALIB_NUM_CALLBACKS 0 +#endif + +typedef long (*cb_callback) _((void * a, ...)); +typedef struct { + SV *coderef; + char *ret_type; + char *arg_type; + cb_callback func; +} cb_entry; + +static long cb_call_sub _((int index, void * first, va_list ap)); + +#include "cbfunc.c" + +static AV *cb_av_config; + +static AV * +cb_init(arr_ref) +SV *arr_ref; +{ + SV *elts[DYNALIB_NUM_CALLBACKS]; + int i; + cb_entry entry; + + entry.coderef = NULL; + entry.arg_type = ""; + entry.ret_type = ""; + for (i = 0; i < DYNALIB_NUM_CALLBACKS; i++) { + entry.func = cb_arr[i]; + elts[i] = newSVpv((char *) &entry, sizeof entry); + } + cb_av_config = av_make(DYNALIB_NUM_CALLBACKS, elts); + return cb_av_config; +} + +#if DYNALIB_NUM_CALLBACKS +/* + * With apologies to pp.c + */ +static long +cb_call_sub(index, first, ap) +int index; +void * first; +va_list ap; +{ + dSP; + I32 nret; + int i; + long result; + STRLEN old_err_len, new_err_len; + char *arg_type; + cb_entry *config; + SV *sv; +#ifdef HAS_QUAD + Quad_t aquad; + unsigned Quad_t auquad; +#endif + static char *first_msg = "Can't use '%c' as first argument type in callback"; + + config = (cb_entry *) SvPV(*av_fetch(cb_av_config, index, 0), na); + ENTER; + SAVETMPS; + PUSHMARK(sp); + arg_type = config->arg_type; + if (*arg_type != '\0') { + switch (*arg_type) { + case 'i' : + XPUSHs(sv_2mortal(newSViv((IV) (int) first))); + break; + case 'l' : + XPUSHs(sv_2mortal(newSViv((IV) (I32) first))); + break; + case 's' : + /* the cast to (long) is just to avoid compiler warnings */ + XPUSHs(sv_2mortal(newSViv((IV) (I16) (long) first))); + break; + case 'c' : + XPUSHs(sv_2mortal(newSViv((IV) (char) (long) first))); + break; + case 'I' : + sv = newSV(0); + sv_setuv(sv, (UV) first); + XPUSHs(sv_2mortal(sv)); + break; + case 'L' : + sv = newSV(0); + sv_setuv(sv, (U32) first); + XPUSHs(sv_2mortal(sv)); + break; + case 'S' : + XPUSHs(sv_2mortal(newSViv((IV) (U16) (long) first))); + break; + case 'C' : + XPUSHs(sv_2mortal(newSViv((IV) (unsigned char) (long) first))); + break; +#ifdef HAS_QUAD + case 'q' : + if (sizeof (Quad_t) <= sizeof first) + XPUSHs(sv_2mortal(newSViv((IV) (Quad_t) first))); + else + croak(first_msg, *arg_type); + break; + case 'Q' : + if (sizeof (unsigned Quad_t) <= sizeof first) { + sv = newSV(0); + sv_setuv(sv, (UV) (unsigned Quad_t) first); + XPUSHs(sv_2mortal(sv)); + } + else + croak(first_msg, *arg_type); + break; +#endif + case 'P' : + ++ arg_type; + XPUSHs(sv_2mortal(newSVpv((char *) first, + (int) strtol(arg_type, &arg_type, 10)))); + -- arg_type; + break; + case 'p' : + XPUSHs(sv_2mortal(newSVpv((char *) first, 0))); + break; + default : + croak(first_msg, *arg_type); + } + ++ arg_type; + while (*arg_type != '\0') { + switch (*arg_type) { + case 'i' : + XPUSHs(sv_2mortal(newSViv((IV) va_arg(ap, int)))); + break; + case 'l' : + XPUSHs(sv_2mortal(newSViv((IV) va_arg(ap, I32)))); + break; + case 's' : + XPUSHs(sv_2mortal(newSViv((IV) va_arg(ap, I16)))); + break; + case 'c' : + XPUSHs(sv_2mortal(newSViv((IV) va_arg(ap, char)))); + break; + case 'I' : + sv = newSV(0); + sv_setuv(sv, va_arg(ap, UV)); + XPUSHs(sv_2mortal(sv)); + break; + case 'L' : + sv = newSV(0); + sv_setuv(sv, va_arg(ap, U32)); + XPUSHs(sv_2mortal(sv)); + break; + case 'S' : + XPUSHs(sv_2mortal(newSViv((IV) va_arg(ap, U16)))); + break; + case 'C' : + XPUSHs(sv_2mortal(newSViv((IV) va_arg(ap, unsigned char)))); + break; +#ifdef HAS_QUAD + case 'q' : + aquad = va_arg(ap, Quad_t); + sv = newSV(0); + if (aquad >= IV_MIN && aquad <= IV_MAX) + sv_setiv(sv, (IV)aquad); + else + sv_setnv(sv, (double)aquad); + XPUSHs(sv_2mortal(sv)); + break; + case 'Q' : + auquad = va_arg(ap, unsigned Quad_t); + sv = newSV(0); + if (aquad <= UV_MAX) + sv_setuv(sv, (UV)auquad); + else + sv_setnv(sv, (double)auquad); + XPUSHs(sv_2mortal(sv)); + break; +#endif + case 'f' : + XPUSHs(sv_2mortal(newSVnv((double) va_arg(ap, float)))); + break; + case 'd' : + XPUSHs(sv_2mortal(newSVnv(va_arg(ap, double)))); + break; + case 'P' : + ++ arg_type; + XPUSHs(sv_2mortal(newSVpv(va_arg(ap, char *), + (int) strtol(arg_type, &arg_type, 10)))); + -- arg_type; + break; + case 'p' : + XPUSHs(sv_2mortal(newSVpv(va_arg(ap, char *), 0))); + break; + default : + croak("Can't use '%c' as argument type in callback", *arg_type); + } + ++ arg_type; + } + } + PUTBACK; + + if (in_eval) { + /* + * XXX The whole issue of G_KEEPERR and `eval's is very confusing to me. + * For example, we should be able to tell whether or not we are in + * cleanup code that follows a die. We can't tell just by looking at $@, + * since it may be left over from a previous eval. + * + * If we're not in cleanup, we should clear $@/errgv before we call the + * sub. The way this code works now, any error string left over from a + * completed eval is wrongly included in our croak message. + * + * It can also produce weirdness when used with Carp::confess. + */ + SvPV(GvSV(errgv), old_err_len); + nret = perl_call_sv(config->coderef, G_SCALAR | G_EVAL | G_KEEPERR); + SPAGAIN; + SvPV(GvSV(errgv), new_err_len); + if (new_err_len > old_err_len) { + char *msg = SvPV(GvSV(errgv),na); + static char prefix[] = "\t(in cleanup) "; /* from pp_ctl.c */ + + if (old_err_len == 0 && strnEQ(msg, prefix, (sizeof prefix) - 1)) { + msg += (sizeof prefix) - 1; + croak("In callback: %s", msg); + } + else { + croak("%s", msg); + } + } + } + else { + nret = perl_call_sv(config->coderef, G_SCALAR); + SPAGAIN; + } + if (nret != 1) { + /* don't know if this can ever happen... */ + croak("Call to callback failed\n"); + } + switch (*(config->ret_type)) { + case '\0' : + case 'i' : + result = (long) (int) POPi; + break; + case 'I' : + result = (long) (unsigned int) POPu; + break; +#if defined(HAS_QUAD) && LONGSIZE >= 8 + case 'q' : + result = (long) (Quad_t) POPi; + break; +#endif + /* + * Returning a pointer is impossible to do safely, it seems. + * case 'p' : + * result = (long) POPp; + * break; + */ + default : + croak("Can't use '%s' as return type in callback", config->ret_type); + } + PUTBACK; + FREETMPS; + LEAVE; + return result; +} +#endif /* DYNALIB_NUM_CALLBACKS != 0 */ + + +MODULE = C::DynaLib PACKAGE = C::DynaLib + +char * +constant(name) + char * name + +INCLUDE: conv.xsi + +void +Poke(dest, data) + # Well, you could do the same thing by loading memcpy(). + void * dest + SV * data + CODE: + { + STRLEN len; + char *source; + if (SvPOK(data)) { + source = SvPV(data, len); + Copy(source, dest, len, char); + } + } + + +BOOT: + /* Setup the callback config array. */ +#if PATCHLEVEL >= 4 || (PATCHLEVEL == 3 && SUBVERSION > 12) + sv_setsv(SvRV(ST(2)), newRV_noinc((SV*) cb_init(ST(2)))); +#else + sv_setsv(SvRV(ST(2)), newRV((SV*) cb_init(ST(2)))); +#endif diff --git a/DynaLib/Makefile.PL b/DynaLib/Makefile.PL new file mode 100644 index 0000000..5deda57 --- /dev/null +++ b/DynaLib/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'C::DynaLib::Struct', + 'VERSION_FROM' => '../DynaLib.pm', # finds $VERSION +); diff --git a/DynaLib/Struct.pm b/DynaLib/Struct.pm new file mode 100644 index 0000000..8627b17 --- /dev/null +++ b/DynaLib/Struct.pm @@ -0,0 +1,198 @@ +package C::DynaLib::Struct; +require 5.002; + +=head1 NAME + +C::DynaLib::Struct - Tool for handling the C `struct' data type + +=head1 SYNOPSIS + + use C::DynaLib::Struct; + + Define C::DynaLib::Struct( + $struct_tag, + $template0, \@field_names0, + [$template1, \@field_names1,] + ... ); + + $rstruct = tie( $struct, $struct_tag [, @initializer_list] ); + $value = $rstruct->my_field(); + $rstruct->my_field( $new_value ); + + $pointer_to_struct = pack( 'p', $struct ); + $struct = $new_struct; # assigns all fields at once + + # after passing pointer-to-struct to a C function: + $rstruct->Unpack(); + $returned_value = $rstruct->my_field(); + +=head1 DESCRIPTION + +When mixing Perl and C, the conversion of data types can be rather +tedious and error-prone. This module provides an abstraction from +Perl's C and C operators for using structures whose +member data types and positions do not change. + +Here are some examples of C code that deals with a C. On the +right are some possible Perl equivalents. + + C Perl + - ---- + typedef struct { use C::DynaLib::Struct; + int m_int; Define C::DynaLib::Struct( + double m_double; 'Foo', + char * m_string; 'i' => ['m_int'], + } Foo; 'd' => ['m_double'], + 'p' => ['m_string'] ); + # or, equivalently, + Define C::DynaLib::Struct('Foo', + 'idp', [qw(m_int m_double m_string)]); + + Foo foo; + Foo *pfoo = &foo; $rfoo = tie ($foo, 'Foo'); + + i = pfoo->m_int; $i = $rfoo->m_int; + + d = foo.m_double; $d = (tied $foo)->m_double; + + pfoo->m_string = "hi"; $rfoo->m_string("hi"); + + Foo bar; tie ($bar, 'Foo'); + bar = foo; $bar = $foo; + + void do_foo(Foo *arg); use C::DynaLib; + $lib = new C::DynaLib("-lfoo"); + $do_foo = $lib->DeclareSub("do_foo","","P"); + # or you could write an XSUB. + + do_foo(&foo); &$do_foo($foo); + + returned_i = foo.m_int; $rfoo->Unpack(); + $returned_i = $rfoo->m_int; + +=head1 BUGS + +Data member access is through autoloaded methods, so actual existing +methods are not allowed as structure member names. Currently, the +illegal names are AUTOLOAD, TIESCALAR, FETCH, STORE, and Unpack. + +The names of Structs themselves must be allowable package names. +Using an existing package name will cause problems. + +Cs mean different things to different C compilers on different +machines. Use caution when assigning C codes to C data types. + +=head1 SEE ALSO + +perlfunc(1) (for C), perlref(1), perltie(1). + +=cut + + +use strict qw (vars subs); + +package C::DynaLib::Struct::Imp; + +use Carp; +use vars qw (@ISA $AUTOLOAD); + +# Keep subs to a minimum, since they pollute the struct member namespace. +use subs qw (AUTOLOAD TIESCALAR FETCH STORE Unpack); + +# +# Class variable: $template +# holds the template used to pack and unpack struct members +# Class variable: %fieldno +# maps field (member) names to their indexes in @{$self->[1]} +# +# Either or both of the following two may be defined at a given time. +# One can be obtained from the other by means of pack/unpack. +# +# Instance variable: $self->[0] +# holds the packed struct value +# Instance variable: @{$self->[1]} +# list of unpacked struct member values +# + +sub TIESCALAR { + my ($class, @member) = @_; + defined (${"${class}::template"}) + or croak "Class \"$class\" has not been defined as a Struct"; + bless [ undef, \@member ], $class; +} + +sub AUTOLOAD { + my $self = shift; + my $class = ref ($self); + (my $member = $AUTOLOAD) =~ s/.*:://; + my $template = ${"${class}::template"}; + defined ($template) + or croak "Class \"$class\" has not been defined as a Struct"; + my $index = ${"${class}::fieldno"}{$member}; + unless (defined ($index)) { + carp "Struct \"$class\" has no member \"$member\"" + unless $member eq 'DESTROY'; + return undef; + } + $self->[1] ||= [ unpack ($template, $self->[0]) ]; + if (@_ == 0) { + return $self->[1]->[$index]; + } elsif (@_ == 1) { + undef $self->[0]; + return $self->[1]->[$index] = $_[0]; + } else { + croak "Usage: \$structref->$member( [\$new_value] )"; + } +} + +sub FETCH { + return $_[0]->[0] if defined ($_[0]->[0]); + return $_[0]->[0] = pack (${ref ($_[0]) . "::template"}, @{$_[0]->[1]}); +} + +sub STORE { + undef $_[0]->[1]; + $_[0]->[0] = $_[1]; +} + +sub Unpack { + $_[0]->[1] = [ unpack (${ref ($_[0]) . "::template"}, $_[0]->[0]) ] + if defined ($_[0]->[0]); + return @{$_[0]->[1]} if wantarray; +} + +package C::DynaLib::Struct; + +use Carp; +use subs qw (Define); + +sub Define { + my ($class, $new_class) = splice(@_, 0, 2); + if (defined (${"${new_class}::template"})) { + carp "Redefinition of Struct $new_class"; + } + *{"${new_class}::TIESCALAR"} = \&C::DynaLib::Struct::Imp::TIESCALAR; + *{"${new_class}::AUTOLOAD"} = \&C::DynaLib::Struct::Imp::AUTOLOAD; + @{"${new_class}::ISA"} = qw (C::DynaLib::Struct::Imp); + my ($template, %fieldno) = (""); + my ($index, $template_fragment, $fields) = (0); + while (1) { + ($template_fragment, $fields) = splice(@_, 0, 2); + last unless defined ($template_fragment); + ref ($fields) eq 'ARRAY' + or die 'Usage: Define C::DynaLib::Struct( $struct_name, $template, \@field_names )'; + $template .= $template_fragment; + my $i; + for $i (0 .. $#$fields) { + defined (&{"C::DynaLib::Struct::Imp::$fields->[$i]"}) + and croak "Illegal Struct member name: \"$fields->[$i]\""; + $fieldno{$fields->[$i]} = $index; + ++ $index; + } + } + *{"${new_class}::fieldno"} = \%fieldno; + *{"${new_class}::template"} = \$template; +} + +1; +__END__ diff --git a/DynaLib/test.pl b/DynaLib/test.pl new file mode 100644 index 0000000..2e76516 --- /dev/null +++ b/DynaLib/test.pl @@ -0,0 +1,54 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..3\n"; } +END {print "not ok 1\n" unless $loaded;} +use C::DynaLib::Struct; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +$num = 2; +sub assert { + my ($assertion, $got, $expected) = @_; + if ($assertion && $got eq $expected) { + print "ok $num\n"; + } elsif ($got ne $expected) { + print "not ok $num; expected \"$expected\", got \"$got\"\n"; + } else { + print "not ok $num\n"; + } + ++ $num; +} + +# +# struct FooBar { +# int foo; +# double bar; +# char *baz; +# }; +# +Define C::DynaLib::Struct('FooBar', "i", ['foo'], + "dp", [ qw(bar baz) ]); + +$pfoobar = tie ($foobar, 'FooBar', 1, 2); +$pfoobar->baz("Hello"); +$pfoobar->foo(3); +@expected = (3, 2, "Hello"); +@got = unpack("idp", $foobar); +assert(1, "[@got]", "[@expected]"); + +@expected = (-65, 5e9, "string"); +$foobar = pack("idp", @expected); +@got = ($pfoobar->foo, (tied $foobar)->bar, $pfoobar->baz); +assert(1, "[@got]", "[@expected]"); diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..ddb4687 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,18 @@ +Changes +DynaLib.pm +DynaLib.xs +MANIFEST +Makefile.PL +README +README.win32 +alpha.c +alpha-cc.c +alpha-cc.s +cdecl.c +hack30.c +sparc.c +test.pl +testcall.c +DynaLib/Makefile.PL +DynaLib/Struct.pm +DynaLib/test.pl diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..8d12f1f --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,489 @@ +use ExtUtils::MakeMaker; + +use strict; +require 5.002; +use Config; + +use vars qw($archname @convention $convention + $num_callbacks %cflags $object + $conv_xs $cbfunc_c $cdecl_h $postamble + $is_gcc $is_dynamic); + +$conv_xs = "conv.xsi"; +$cbfunc_c = "cbfunc.c"; +$cdecl_h = "cdecl.h"; +$object = '$(BASEEXT)$(OBJ_EXT)'; + +$is_gcc = $Config{cc} =~ /gcc/i && $Config{gccversion} >= 2; +$is_dynamic = ($Config{usedl} eq 'define'); +use subs qw(write_conv write_cbfunc write_cdecl_h); + +$postamble = " +clean:: + \$(RM_F) $conv_xs $cbfunc_c + +$conv_xs: $0 \$(CONFIGDEP) + +$cbfunc_c: $0 \$(CONFIGDEP) + +DynaLib.c: $conv_xs +"; + + +$is_dynamic or warn <[1]}, last if $archname =~ /$_->[0]/ } +} + +WriteMakefile( + 'NAME' => 'C::DynaLib', + 'VERSION_FROM' => 'DynaLib.pm', + 'DEFINE' => '', + 'OBJECT' => $object, + + # Don't let MakeMaker set up a dependency loop. + # cdecl.h depends on testcall.o, not the other way around! + 'H' => [], + 'C' => ['DynaLib.c'], + 'INC' => '-I.', +); + + +sub pretest { + my $self = shift; + my @candidate; + my $cleanup = sub { + unlink ("testtest.c", "testtest.txt", "testtest$self->{EXE_EXT}", + "testtest$self->{OBJ_EXT}"); + }; + my $cant = sub { + &$cleanup; + print ("I don't know how run the test program,\n", + "so I'll try to find a default configuration.\n") + if $Verbose; + return undef; + }; + my $try = sub { + open HELLO, "testtest.txt" or return undef; + my $hello = ; + close HELLO; + if ($hello =~ /hello, world/) { + &$cleanup; + return 1; + } + return 0; + }; + + &$cleanup; + unless (open PROG, ">testtest.c") { + print ("Can't write testtest.c\n"); + return &$cant; + } + print PROG <<'PROG'; +#include +#include +#undef fprintf +#undef fopen +#undef fclose +#include +int main(argc, argv, env) + int argc; + char **argv; + char **env; +{ + FILE *fp = fopen("testtest.txt", "w"); + if (fp == NULL) { + return 1; + } + fprintf(fp, "hello, world!\n"); + fclose(fp); + return 0; +} +PROG + close PROG; + + @candidate = (); + push @candidate, "$Config{cc} $Config{ccflags} -DNARF -I$self->{PERL_INC} testtest.c -o testtest$self->{EXE_EXT} >/dev/null 2>&1" + unless $Verbose; + push @candidate, "$Config{cc} $Config{ccflags} -DNARF -I$self->{PERL_INC} testtest.c -otesttest$self->{EXE_EXT} >/dev/null 2>&1" + unless $Verbose; + push @candidate, "$Config{cc} $Config{ccflags} -DNARF -I$self->{PERL_INC} testtest.c -o testtest$self->{EXE_EXT}"; + push @candidate, "$Config{cc} $Config{ccflags} -DNARF -I$self->{PERL_INC} testtest.c -otesttest$self->{EXE_EXT}"; + $self->{how_to_compile} = "$Config{cc} $Config{ccflags} -DNARF -I$self->{PERL_INC} testtest.c -o testtest$self->{EXE_EXT}"; + + while ($self->{how_to_compile} = shift (@candidate)) { + unlink "testtest$self->{EXE_EXT}"; + print "$self->{how_to_compile}\n" if $Verbose; + system ($self->{how_to_compile}); + last if $? == 0 && -x "testtest$self->{EXE_EXT}"; + } + return &$cant unless $self->{how_to_compile}; + + @candidate = (); + push @candidate, "testtest$self->{EXE_EXT} >/dev/null 2>&1" + unless $Verbose; + push @candidate, "./testtest$self->{EXE_EXT} >/dev/null 2>&1" + unless $Verbose; + push @candidate, "testtest$self->{EXE_EXT}"; + push @candidate, "./testtest$self->{EXE_EXT}"; + push @candidate, "run testtest$self->{EXE_EXT}"; + + unlink ("testtest.txt"); + while ($self->{how_to_run} = shift (@candidate)) { + print "$self->{how_to_run}\n" if $Verbose; + system ($self->{how_to_run}); + $? == 0 && &$try and return 1; + } + return &$cant; +} + +sub guess_cdecl_h { + my $self = shift; + open CONFIG, ">$cdecl_h" or die "can't write $cdecl_h"; + + my $define_if_not = sub { + my ($macro, $def) = @_; + return "#ifndef $macro\n#define $macro $def\n#endif\n\n"; + }; + print CONFIG <\n" + if $self->{CC} =~ /\bcc$/; + print CONFIG "#include \n" + if $archname =~ /win32/i; + print CONFIG (&$define_if_not("CDECL_ONE_BY_ONE", + (($archname =~ /win32/i && $self->{CC} !~ /\bbcc/i) + || $is_gcc) ? 1 : 0)); + print CONFIG (&$define_if_not("CDECL_ADJUST", + ($self->{CC} =~ /\bbcc/i ? -12 : 0))); + print CONFIG (&$define_if_not("CDECL_REVERSE", 0)); + + close CONFIG; +} + +sub make_postamble { + my $self = shift; + + $postamble .= "\nDynaLib\$(OBJ_EXT): DynaLib.c $cbfunc_c" + . " @{[ map { \"$_.c\" } @convention ]}\n"; + + ! @convention || grep { $_ eq "cdecl" } @convention + or return $postamble; + + print "Writing $cdecl_h\n"; + if (write_cdecl_h($self)) { + @convention = ('cdecl') + unless @convention; + } elsif (@convention) { + print "Can't figure out this system. I'll have to guess.\n" + if $Verbose; + guess_cdecl_h($self); + } else { + print < "; + no strict; + while () { + eval; + print "$@\n" if $@; + print "\n> "; + } + print "\n"; + } + + return $postamble; +} + +sub write_cdecl_h { + my $self = shift; + + print "Testing how to compile and run a program...\n" + if $Verbose; + pretest($self) or return undef; + + print "Testing how to pass args to a function...\n" + if $Verbose; + $self->{how_to_compile} =~ s/testtest/testcall/g; + $self->{how_to_run} =~ s/testtest/testcall/g; + my $defines; + for $defines ("-DINCLUDE_ALLOCA", "", "-DINCLUDE_MALLOC") { + my $cmd = $self->{how_to_compile}; + $cmd =~ s/-DNARF/$defines/g; + unlink ("testcall$self->{EXE_EXT}", $cdecl_h); + print "$cmd\n" if $Verbose; + system ($cmd); + if ($? == 0 && -x "testcall$self->{EXE_EXT}") { + $cmd = $self->{how_to_run}; + print "$cmd\n" if $Verbose; + system ($cmd); + if ($? == 0 && -e $cdecl_h) { + print "Succeeded.\n" if $Verbose; + return 1; + } + } + } + return undef; +} + +sub write_conv { + + # Write conv.xsi, to be included in DynaLib.xs + + open XS, ">$conv_xs" + or die "Can't write file \"$conv_xs\": $!\n"; + print "Writing $conv_xs\n"; + + print XS <= IV_MIN && aquad <= IV_MAX) + sv_setiv(sv, (IV)aquad); + else + sv_setnv(sv, (double)aquad); + break; + case 'Q' : + aquad = ${convention}_CALL(symref, unsigned Quad_t); + if (aquad <= UV_MAX) + sv_setuv(sv, (UV)auquad); + else + sv_setnv(sv, (double)auquad); + break; +#endif + case 'f' : + sv_setnv(sv, (double) ${convention}_CALL(symref, float)); + break; + case 'd' : + sv_setnv(sv, ${convention}_CALL(symref, double)); + break; + case 'p' : + sv_setpv(sv, ${convention}_CALL(symref, char *)); + break; + case 'P' : + sv_setpvn(sv, ${convention}_CALL(symref, char *), + atoi(&ret_type[1])); + break; + default : + croak("unsupported function return type: '%c'", *ret_type); + } + ST(0) = sv; + XSRETURN(1); + } +XS +} +close XS; +} + +sub write_cbfunc { + my ($i); + + # Write cbfunc.c, to be included in DynaLib.xs + + open FUNCS, ">$cbfunc_c" + or die "Can't write file \"$cbfunc_c\": $!\n"; + print "Writing $cbfunc_c\n"; + + print FUNCS <DeclareSub("sinh", "d", "d"); + print "The hyperbolic sine of 3 is ", &$sinh(3), "\n"; + + + *********************************************************** + *** THIS CODE CONTAINS SYSTEM DEPENDENCIES. *** + *** IT WILL NOT WORK ON ALL COMPILERS, MACHINES, OR *** + *** OPERATING SYSTEMS. USE AT YOUR OWN RISK. *** + *********************************************************** + + +The module has been tested successfully on iX86, Sparc, and Alpha +machines. However, there are probably compilers for even these chips +which will require some porting. If you tell me, I might fix it. + +Included are the following packages: + + C::DynaLib - interface to dynamic libraries + C::DynaLib::Callback - convert a perl sub into a usable + C function pointer + C::DynaLib::Struct - yet another tool for handling C + compound data structures + +To build this module, run the usual + + perl Makefile.PL + make test + +Various things can go wrong. First, your perl should be of the dynamic +variety. Be sure you answered "y" when Configure asked, "Do you wish +to use dynamic loading?". Otherwise, you will still (I think) be able +to create callback pointers and convert a function pointer into a Perl +sub, but you won't be able to do dynamic loading. + +The biggest issue in porting this module is your system's function +call interface. If Makefile.PL prints that it is using `hack30', it +is a sign that your system is not yet supported. Another sign of +trouble is when `make test' prints `not ok' or `Illegal memory +operation'. Further documentation in pod format is in DynaLib.pm. + +The callback feature has sometimes caused grief in building the +module. If Makefile.PL writes a makefile but you can't get it to +build, try `perl Makefile.PL CALLBACKS=0' followed by `make test', +and tell me of your success or failure. + + +COPYRIGHT + +The files named in MANIFEST, accompanying this file, are Copyright (c) +1997 by John Tobey. All rights reserved. They may be modified, +distributed and used under the same conditions as Perl itself. Of +course, there is no express or implied warranty. See the file README +in the top-level Perl source directory for more information. + +Enjoy! +-John +jtobey@channel1.com diff --git a/README.win32 b/README.win32 new file mode 100755 index 0000000..4c59b67 --- /dev/null +++ b/README.win32 @@ -0,0 +1,210 @@ +=pod + +This file is a Perl program that tests the C::DynaLib package +on Windows 95. It might work on iX86 NT, but I wouldn't place bets +beyond that. To run it after installation, type `perl '. +If you want to run it before installing the module, your best bet is +to rename test.pl to something like test.bak.pl, rename this file +test.pl, and do `make test' (or nmake, or dmake, whatever make you +use). If successful, it will create a window with a message in the +center. + +The program is modeled after the kind of "hello world" examples found +in introductory books on Windows programming in C. However, Perl +lacks an important feature of C, namely the preprocessor (unless +someone has written a Cpp module that I don't know about?) Therefore, +all function declarations and constants from are +hard-coded. + +This is not a happy state of affairs for would-be Perl Windows +programmers. Someday maybe there will be a fancy AutoLoading module +that reads C header files and lets us use preprocessor macros. For +now though, if you want to make direct API calls without writing +specialized XS code, this is the best way I know how. + +Another difficulty is the use of resources. Windows resources are +binary data associated with an application; for example, menus, +bitmaps, and dialog box templates. Typically, resources are linked +into the program's .exe file. Of course, Perl programs are text and +don't use the binary format which can contain resources. Although it +is possible to construct at run time the objects which would otherwise +be stored as resources, this is rather wasteful and complicated. + +One alternative is to put the resources in a DLL or EXE which the Perl +program would then load via LoadLibrary(). A more radical solution +would be to generate a cross-breed file which has the EXE format and +is at the same time parsable by perl. A similar principle is used by +the pl2bat utility in the Win32 Perl distribution. However, the +"Portable Executable" format used by Win32 is quite a bit nastier on +text editors than are .bat files. Wordpad, for instance, won't open +them at all, and Notepad leaves them hopelessly corrupt when you save. + +Be that as it may, I have developed a pl2exe program that does what +its name suggests. It takes a perl script and adds some stuff at the +beginning to make it have the PE format (well, close enough to fool +Windows). When executed, the program invokes perl on itself the way a +pl2bat script does (and avoids the 9-argument limit on Windows 95, +btw). The thing lacking in pl2exe that would make it really useful is +a way to link in resources without disrupting the delicate PE/script +balance. Maybe someday. + +One final note about this file. This is a demo/test program. It is +not necessarily good coding style. + +=cut + +use 5.00402; + +use C::DynaLib; +use C::DynaLib::Struct; +use strict; + +my $user32 = new C::DynaLib("USER32"); +my $gdi32 = new C::DynaLib("GDI32"); + +#typedef struct _WNDCLASS { // wc +# +# UINT style; +# WNDPROC lpfnWndProc; +# int cbClsExtra; +# int cbWndExtra; +# HANDLE hInstance; +# HICON hIcon; +# HCURSOR hCursor; +# HBRUSH hbrBackground; +# LPCTSTR lpszMenuName; +# LPCTSTR lpszClassName; +#} WNDCLASS; +Define C::DynaLib::Struct('WNDCLASS', + I => ['style'], + I => ['lpfnWndProc'], + i => ['cbClsExtra'], + i => ['cbWndExtra'], + I => ['hInstance'], + I => ['hIcon'], + I => ['hCursor'], + I => ['hbrBackground'], + p => ['lpszMenuName'], + p => ['lpszClassName'], +); + +# The results of much sifting through C header files: + +my $PostQuitMessage = $user32->DeclareSub("PostQuitMessage", + "i", # return type + "i"); # argument type(s) +my $GetClientRect = $user32->DeclareSub("GetClientRect", + "i", + "i", "P"); +my $BeginPaint = $user32->DeclareSub("BeginPaint", + "i", + "i", "P"); +my $DrawText = $user32->DeclareSub("DrawTextA", + "i", + "I", "p", "I", "P", "I"); +my $EndPaint = $user32->DeclareSub("EndPaint", + "i", + "i", "P"); +my $DefWindowProc = $user32->DeclareSub("DefWindowProcA", + "i", + "i", "i", "i", "i"); +my $LoadIcon = $user32->DeclareSub("LoadIconA", + "i", + "i", "i"); +my $LoadCursor = $user32->DeclareSub("LoadCursorA", + "i", + "i", "i"); +my $GetStockObject = $gdi32->DeclareSub("GetStockObject", + "i", + "i"); +my $RegisterClass = $user32->DeclareSub("RegisterClassA", + "i", + "P"); +my $CreateWindowEx = $user32->DeclareSub("CreateWindowExA", + "i", + "i", "p", "p", "i", "i", "i", "i", "i", "i", "i", "i", "i"); +my $ShowWindow = $user32->DeclareSub("ShowWindow", + "i", + "i", "i"); +my $UpdateWindow = $user32->DeclareSub("UpdateWindow", + "i", + "i"); +my $GetMessage = $user32->DeclareSub("GetMessageA", + "i", + "P", "i", "i", "i"); +my $TranslateMessage = $user32->DeclareSub("TranslateMessage", + "i", + "P"); +my $DispatchMessage = $user32->DeclareSub("DispatchMessageA", + "i", + "P"); + +# +# Main window's callback. +# +sub window_proc { + my ($hwnd, $uMsg, $wParam, $lParam) = @_; + + # Wanna log your window messages? + #print "hwnd=$hwnd, uMsg=$uMsg, wParam=$wParam, lParam=$lParam\n"; + + if ($uMsg == 0x0201 # WM_LBUTTONDOWN + || $uMsg == 0x0002 # WM_DESTROY + ) { + &$PostQuitMessage(0); + return 0; + } elsif ($uMsg == 0x000F) { # WM_PAINT + my $text = "Hello from Perl!"; + # This should be big enough for a PAINTSTRUCT, I hope: + my $ps = "\0" x 1024; + my $rect = "\0" x 64; + my $hdc; + &$GetClientRect($hwnd, $rect); + $hdc = &$BeginPaint($hwnd, $ps); + &$DrawText($hdc, $text, length($text), $rect, + 0x00000025); # DT_SINGLELINE | DT_CENTER | DT_VCENTER + &$EndPaint($hwnd, $ps); + return 0; + } + return &$DefWindowProc($hwnd, $uMsg, $wParam, $lParam); +} + +my $wnd_proc = new C::DynaLib::Callback( + \&window_proc, "i", "i", "i", "i", "i"); + +# +# Register the window class. +# +my $wc; +my $rwc = tie $wc, 'WNDCLASS'; +$rwc->style(0x0003); # CS_HREDRAW | CS_VREDRAW +$rwc->lpfnWndProc($wnd_proc->Ptr()); +$rwc->hInstance(0x00400000); +$rwc->hIcon(&$LoadIcon(0, 32512)); +$rwc->hCursor(&$LoadCursor(0, 32512)); +$rwc->hbrBackground(&$GetStockObject(0)); # WHITE_BRUSH +$rwc->lpszClassName("w32test"); +&$RegisterClass($wc) or die "can't register window class"; + +# +# Create the window. +# +my $title_text = "Perl Does Win32"; +my $hwnd = &$CreateWindowEx(0, $rwc->lpszClassName, + $title_text, + 0x00CF0000, # WS_OVERLAPPEDWINDOW + 0x80000000, # CW_USEDEFAULT + 0x80000000, 0x80000000, 0x80000000, + 0, 0, $rwc->hInstance, + 0) or die "can't create window"; +&$ShowWindow($hwnd, 10); # SW_SHOWDEFAULT +&$UpdateWindow($hwnd); + +# +# Message loop. +# +my $msg = "\0" x 64; +while (&$GetMessage($msg, 0, 0, 0)) { + &$TranslateMessage($msg); + &$DispatchMessage($msg); +} diff --git a/alpha-cc.c b/alpha-cc.c new file mode 100644 index 0000000..132de88 --- /dev/null +++ b/alpha-cc.c @@ -0,0 +1,23 @@ +#include + +long +dynalib_alpha_excuse_for_asm(long a0, long a1, long a2, + long a3, long a4, long a5, + int (*func)(), long n_extra, long *p_extra) +{ + long *lptr; + if (n_extra > 0) { + lptr = (long *) alloca(n_extra * sizeof (long)); + while (n_extra > 0) { + *lptr++ = *p_extra++; + n_extra --; + } + } + asm("ldt $f16, %0" : : "m"(a0)); + asm("ldt $f17, %0" : : "m"(a1)); + asm("ldt $f18, %0" : : "m"(a2)); + asm("ldt $f19, %0" : : "m"(a3)); + asm("ldt $f20, %0" : : "m"(a4)); + asm("ldt $f21, %0" : : "m"(a5)); + return (*((long (*)()) func))(a0, a1, a2, a3, a4, a5); +} diff --git a/alpha-cc.s b/alpha-cc.s new file mode 100644 index 0000000..64fe264 --- /dev/null +++ b/alpha-cc.s @@ -0,0 +1,76 @@ + .verstamp 3 11 + .set noreorder + .set volatile + .set noat + .file 1 "alpha-cc.c" +gcc2_compiled.: +__gnu_compiled_c: +.text + .align 3 + .globl dynalib_alpha_excuse_for_asm + .ent dynalib_alpha_excuse_for_asm +dynalib_alpha_excuse_for_asm: + ldgp $29,0($27) +dynalib_alpha_excuse_for_asm..ng: + lda $30,-64($30) + .frame $15,64,$26,0 + stq $26,0($30) + stq $15,8($30) + .mask 0x4008000,-64 + bis $30,$30,$15 + .prologue 1 + stq $17,24($15) + stq $18,32($15) + stq $19,40($15) + stq $20,48($15) + stq $21,56($15) + ldq $3,72($15) + stq $16,16($15) + ldq $5,80($15) + ble $3,$34 + s8addq $3,0,$1 + lda $2,-4096($30) + subq $30,$1,$4 + cmpult $4,$2,$1 + beq $1,$36 +$35: + stq $31,0($2) + lda $2,-8192($2) + cmpule $2,$4,$1 + beq $1,$35 + stq $31,0($4) +$36: + bis $4,$4,$30 + bis $30,$30,$2 + ble $3,$34 + .align 5 +$39: + ldt $f1,0($5) + subq $3,1,$3 + addq $5,8,$5 + cmple $3,0,$1 + stt $f1,0($2) + addq $2,8,$2 + beq $1,$39 +$34: + ldq $16,16($15) + ldq $17,24($15) + ldq $18,32($15) + ldq $19,40($15) + ldq $20,48($15) + ldq $21,56($15) + ldt $f16, 16($15) + ldq $27,64($15) + ldt $f17, 24($15) + ldt $f18, 32($15) + ldt $f19, 40($15) + ldt $f20, 48($15) + ldt $f21, 56($15) + jsr $26,($27),0 + ldgp $29,0($26) + bis $15,$15,$30 + ldq $26,0($30) + ldq $15,8($30) + addq $30,64,$30 + ret $31,($26),1 + .end dynalib_alpha_excuse_for_asm diff --git a/alpha.c b/alpha.c new file mode 100644 index 0000000..eb2cb35 --- /dev/null +++ b/alpha.c @@ -0,0 +1,89 @@ +#include + +#ifdef __GNUC__ +/* We'll use inline assembly */ +#else +extern long dynalib_alpha_excuse_for_asm(long a0, long a1, long a2, + long a3, long a4, long a5, + int (*func)(), long n_extra, long *p_extra); +#endif + +/* + * Convert Perl sub args to C args and pass them to (*func)(). + */ +static long +alpha_pray(ax, items, func) +I32 ax; /* used by the ST() macro */ +I32 items; +int (*func)(); +{ + STRLEN arg_len; + char *arg_scalar; + long pseu[6]; + long *lptr, *stack_start; + int i; + + for (i = DYNALIB_ARGSTART; i < items; i++) { + /* Fetch next (packed) Perl arg */ + arg_scalar = SvPV(ST(i), arg_len); + /* Convert to 8-byte for placement in register or on stack */ + if (i < 6 + DYNALIB_ARGSTART) { + lptr = &pseu[i - DYNALIB_ARGSTART]; + } + else if (i == 6 + DYNALIB_ARGSTART) { + lptr = stack_start + = (long *) alloca((items - (6 + DYNALIB_ARGSTART)) * sizeof (long)); + } + else { + lptr ++; + } + switch (arg_len) { + case 1: + *lptr = (long) (*arg_scalar); + break; +#if LONGSIZE > SHORTSIZE + case SHORTSIZE: + *lptr = (long) (*(short *) arg_scalar); + break; +#endif +#if (INTSIZE > SHORTSIZE) && (INTSIZE < LONGSIZE) + case INTSIZE: + *lptr = (long) (*(int *) arg_scalar); + break; +#endif + case LONGSIZE: + *lptr = *(long *) arg_scalar; + break; + default: + croak("Argument %d has unsupported length %d bytes.", + i + 1 - DYNALIB_ARGSTART, (int) arg_scalar); + } + } +#ifdef __GNUC__ + /* If any of the first six args are type double, the calling + convention is to place them in floating point registers. We don't + know if they're doubles or not (well, we /could/ find out, but it + would be a waste of time) so we play it safe by filling the fp regs + with what they would contain if the args were doubles. + + I don't know how to do inline assembly with other compilers. + */ + asm("ldt $f16, %0" : : "m"(pseu[0])); + asm("ldt $f17, %0" : : "m"(pseu[1])); + asm("ldt $f18, %0" : : "m"(pseu[2])); + asm("ldt $f19, %0" : : "m"(pseu[3])); + asm("ldt $f20, %0" : : "m"(pseu[4])); + asm("ldt $f21, %0" : : "m"(pseu[5])); + /* Cross your fingers. */ + return (*((long (*)()) func))(pseu[0], pseu[1], pseu[2], + pseu[3], pseu[4], pseu[5]); +#else + return dynalib_alpha_excuse_for_asm(pseu[0], pseu[1], pseu[2], + pseu[3], pseu[4], pseu[5], + func, items - (6 + DYNALIB_ARGSTART), + stack_start); +#endif +} + +#define alpha_CALL(func, type) \ + ((*((type (*)(I32, I32, void *)) alpha_pray))(ax,items,func)) diff --git a/cdecl.c b/cdecl.c new file mode 100644 index 0000000..ace799d --- /dev/null +++ b/cdecl.c @@ -0,0 +1,51 @@ +/* cdecl.h is generated when you run `perl Makefile.PL DECL=cdecl' */ +#include "cdecl.h" + +/* + * Convert Perl sub args to C args and pass them to (*func)(). + */ +static int +cdecl_pray(ax, items, func) +I32 ax; /* used by the ST() macro */ +I32 items; +void *func; +{ + STRLEN arg_len; + char *arg_scalar, *arg_on_stack; + register int i; +#if CDECL_ONE_BY_ONE + +#if CDECL_REVERSE + for (i = DYNALIB_ARGSTART; i < items; i++) { +#else /* ! CDECL_REVERSE */ + for (i = items - 1; i >= DYNALIB_ARGSTART; i--) { +#endif /* ! CDECL_REVERSE */ + arg_scalar = SvPV(ST(i), arg_len); + arg_on_stack = alloca(arg_len); + Copy(arg_scalar, arg_on_stack, arg_len, char); + } +#else /* ! CDECL_ONE_BY_ONE */ + STRLEN total_arg_len = 0; + + for (i = items; i-- > DYNALIB_ARGSTART; ) { + (void) SvPV(ST(i), arg_len); + total_arg_len += arg_len; + } + arg_on_stack = (char *) alloca(total_arg_len) + CDECL_ADJUST; +#if CDECL_REVERSE + for (i = items - 1; i >= DYNALIB_ARGSTART; i--) { +#else /* ! CDECL_REVERSE */ + for (i = DYNALIB_ARGSTART; i < items; i++) { +#endif /* ! CDECL_REVERSE */ + arg_scalar = SvPV(ST(i), arg_len); + Copy(arg_scalar, arg_on_stack, arg_len, char); + arg_on_stack += arg_len; + } +#endif /* ! CDECL_ONE_BY_ONE */ + + /* Cross your fingers. */ + return (*((int (*)()) func))(); +} + +#define cdecl_CALL(func, type) \ + ((*((type (*)(I32, I32, void *)) cdecl_pray))(ax,items,func)) diff --git a/hack30.c b/hack30.c new file mode 100644 index 0000000..fab6037 --- /dev/null +++ b/hack30.c @@ -0,0 +1,63 @@ +/* + * This function tries to convert Perl arguments to C arguments and + * call the C function pointed to by func. + * + * It is used when `hack30' is specified explicitly or by default as + * a calling convention for the C::DynaLib module. The approach + * is very simpleminded: the perl sub's args are concatenated and cast + * to an array of 30 long integers, and the C function is called as if it + * expected 30 longs. (For efficiency, if the Perl args make up only + * six longs or less, the C function is instead called as if it expected + * six longs.) + * + * This method runs into problems if the C function + * + * - takes more arguments than can fit in the array, + * + * - takes some non-long arguments on a system that passes them + * differently from longs, or + * + * - cares how many arguments it was passed. This appears to crash + * certain Win32 functions including RegisterClassA(). + * + * Because of these problems, the hack30 calling convention is selected + * only as a last resort by Makefile.PL. A better solution would be to + * write a similar function specific to your system and add it to the + * module as a new calling convention. + */ +static int +hack30_pray(ax, items, func) +I32 ax; /* used by the ST() macro */ +I32 items; +void *func; +{ + STRLEN arg_len; + void *arg_scalar; + int i = 1; + int nbytes = 0; + long pseu[30]; + int check_len; + + for (i = DYNALIB_ARGSTART; i < items; i++) { + arg_scalar = SvPV(ST(i), arg_len); + check_len = nbytes + arg_len; + if (check_len > sizeof pseu) { + croak("Too many arguments. The hack30 calling convention accepts up to 30 long-int-size arguments."); + } + Copy(arg_scalar, &((char *) (&pseu[0]))[nbytes], arg_len, char); + nbytes = check_len; + } + if (nbytes <= 6 * sizeof (long)) { + return (*((int (*)()) func)) + (pseu[0], pseu[1], pseu[2], pseu[3], pseu[4], pseu[5]); + } + return (*((int (*)()) func)) + (pseu[0], pseu[1], pseu[2], pseu[3], pseu[4], pseu[5], + pseu[6], pseu[7], pseu[8], pseu[9], pseu[10], pseu[11], + pseu[12], pseu[13], pseu[14], pseu[15], pseu[16], pseu[17], + pseu[18], pseu[19], pseu[20], pseu[21], pseu[22], pseu[23], + pseu[24], pseu[25], pseu[26], pseu[27], pseu[28], pseu[29]); +} + +#define hack30_CALL(func, type) \ + ((*((type (*)()) hack30_pray))(ax,items,func)) diff --git a/sparc.c b/sparc.c new file mode 100644 index 0000000..b727efe --- /dev/null +++ b/sparc.c @@ -0,0 +1,62 @@ +/* alloca.h is needed with Sun's cc */ +#include + +/* + * Convert Perl sub args to C args and pass them to (*func)(). + */ +static int +sparc_pray(ax, items, func) +I32 ax; /* used by the ST() macro */ +I32 items; +int (*func)(); +{ + STRLEN arg_len, chunk_len; + char *arg_scalar, *arg_on_stack; + int nbytes = 0; + int pseu[6]; /* Array of first six "pseudo-arguments" */ + int check_len; + register int i, j; + int stack_needed = 0; + + for (i = DYNALIB_ARGSTART; i < items; ) { + arg_scalar = SvPV(ST(i), arg_len); + i++; + check_len = nbytes + arg_len; + if (check_len > sizeof pseu) { + stack_needed = check_len - sizeof pseu; + arg_len -= stack_needed; + } + Copy(arg_scalar, &((char *) (&pseu[0]))[nbytes], arg_len, char); + nbytes = check_len; + if (check_len >= sizeof pseu) { + for (j = i; j < items; j++) { + SvPV(ST(j), arg_len); + stack_needed += arg_len; + } + if (stack_needed > 0) { + arg_on_stack = alloca(stack_needed); + /* Wish I knew why we have to subtract off 4. */ + arg_on_stack -= sizeof (int); + if (check_len > sizeof pseu) { + /* An argument straddles the 6-word line; part goes on stack. */ + SvPV(ST(i), arg_len); + chunk_len = check_len - sizeof pseu; + Copy(&arg_scalar[arg_len - chunk_len], arg_on_stack, chunk_len, char); + arg_on_stack += chunk_len; + } + while (i < items) { + arg_scalar = SvPV(ST(i), arg_len); + i++; + Copy(arg_scalar, arg_on_stack, arg_len, char); + arg_on_stack += arg_len; + } + } + } + } + /* Cross your fingers. */ + return (*((int (*)()) func))(pseu[0], pseu[1], pseu[2], + pseu[3], pseu[4], pseu[5]); +} + +#define sparc_CALL(func, type) \ + ((*((type (*)(I32, I32, void *)) sparc_pray))(ax,items,func)) diff --git a/test.pl b/test.pl new file mode 100644 index 0000000..c0be7a2 --- /dev/null +++ b/test.pl @@ -0,0 +1,245 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $^W = 1; $| = 1; print "1..10\n"; } +END {print "not ok 1\n" unless $loaded;} +use C::DynaLib (); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +use Carp; +eval { + $SIG{SEGV} = sub { use Carp; confess "Illegal memory operation" }; + $SIG{ILL} = $SIG{SEGV}; +}; +use vars qw ($tmp1 $tmp2); + +# Don't let old Exporters ruin our fun. +sub DeclareSub { &C::DynaLib::DeclareSub } +sub PTR_TYPE { &C::DynaLib::PTR_TYPE } + +$test_num = 2; +sub assert { + my ($assertion, $got, $expected) = (@_, '', ''); + if ($assertion && $got eq $expected) { + print "ok $test_num\n"; + } elsif ($got ne $expected) { + print "not ok $test_num; expected \"$expected\", got \"$got\"\n"; + } else { + print "not ok $test_num\n"; + } + ++ $test_num; +} + +use Config; +$libc_arg = $Config{libc} || "-lc"; +$libc = new C::DynaLib($libc_arg); + +if (! $libc) { + if ($^O =~ /cygwin32/ || $^O eq "MSWin32") { + $libc = new C::DynaLib("MSVCRT40.DLL") + || new C::DynaLib("\\WINDOWS\\SYSTEM\\MSVCRT40.DLL"); + } elsif ($^O eq 'linux') { + $libc = new C::DynaLib("libc.so.6"); + } +} +if (! $libc) { + assert(0); + die "Can't load -lc: ", DynaLoader::dl_error(), "\nGiving up.\n"; +} + +$libm_arg = DynaLoader::dl_findfile("-lm"); +if (! $libm_arg) { + $libm = $libc; +} elsif ($libm_arg !~ /libm\.a$/) { + $libm = new C::DynaLib("-lm"); +} +$libm and $pow = $libm->DeclareSub ({ "name" => "pow", + "return" => "double", + "args" => ["d", "d"], + }); + +if (! $pow) { + warn "$0: Can't find dynamic -lm! Skipping the math lib tests.\n"; + assert(1); +} else { + $sqrt2 = &$pow(2, 0.5); + assert(1, $sqrt2, 2**0.5); +} + +$strlen = $libc->DeclareSub ({ "name" => "strlen", + "return" => "i", + "args" => ["p"], + }); + +# Can't do this in perl <= 5.00401 because it results in a +# pack("p", constant)... +# +# $len = &$strlen("oof rab zab"); + +$len = &$strlen($tmp = "oof rab zab"); +assert(1, $len, 11); + +sub my_sprintf { + my ($fmt, @args) = @_; + my (@arg_types) = ("P", "p"); + my ($width) = (length($fmt) + 1); + + # note this is a *simplified* (non-crash-proof) printf parser! + while ($fmt =~ m/(?:%[-#0 +']*\d*(?:\.\d*)?h?(.).*?)[^%]*/g) { + my $spec = $1; + next if $spec eq "%"; + if (index("dic", $spec) > -1) { + push @arg_types, "i"; + $width += 20; + } elsif (index("ouxXp", $spec) > -1) { + push @arg_types, "I"; + $width += 20; + } elsif (index("eEfgG", $spec) > -1) { + push @arg_types, "d"; + $width += 30; + } elsif ("s" eq $spec) { + push @arg_types, "p"; + $width += length($args[$#arg_types]); + } else { + die "Unknown printf specifier: $spec\n"; + } + } + my $buffer = "\0" x $width; + &{$libc->DeclareSub("sprintf", "", @arg_types)} + ($buffer, $fmt, @args); + $buffer =~ s/\0.*//; + return $buffer; + } + +{} if 0; # poor old Emacs :( + +$fmt = "%x %10sfoo %d %10.7g %f %d %d %d"; +@args = (253, "bar", -789, 2.32578, 3.14, 5, 6, 7); + +$expected = sprintf($fmt, @args); +$got = my_sprintf($fmt, @args); + +assert(1, $got, $expected); + +$ptr_len = length(pack("p", $tmp = "foo")); + +# Try passing a pointer to DeclareSub. +$fopen_ptr = DynaLoader::dl_find_symbol($libc->LibRef(), "fopen") + or die DynaLoader::dl_error(); +$fopen = DeclareSub ({ "ptr" => $fopen_ptr, + "return" => PTR_TYPE, + "args" => ["p", "p"] }); + +open TEST, ">tmp.tmp" + or die "Can't write file tmp.tmp: $!\n"; +print TEST "a string"; +close TEST; + +# Can't do &$fopen("tmp.tmp", "r") in perls before 5.00402. +$fp = &$fopen($tmp1 = "tmp.tmp", $tmp2 = "r"); +if (! $fp) { + assert(0); +} else { + # Hope "I" will work for type size_t! + $fread = $libc->DeclareSub("fread", "i", + "P", "I", "I", PTR_TYPE); + $buffer = "\0" x 4; + $result = &$fread($buffer, 1, length($buffer), $fp); + assert($result == 4, $buffer, "a st"); +} +unlink "tmp.tmp"; + +if (@$C::DynaLib::Callback::Config) { + sub compare_lengths { + # Not a model of efficiency, only a test of functionality!! + my ($ppa, $ppb) = @_; + my $pa = unpack("P$ptr_len", pack(PTR_TYPE, $ppa)); + my $pb = unpack("P$ptr_len", pack(PTR_TYPE, $ppb)); + my $A = unpack("p", $pa); + my $B = unpack("p", $pb); + length($A) <=> length($B); + } + @list = qw(A bunch of elements with unique lengths); + $array = pack("p*", @list); + + # + # This appears to work with either \&compare_lengths or + # "::compare_lengths", but not "compare_lengths". + # + $callback = new C::DynaLib::Callback(\&compare_lengths, "i", + PTR_TYPE, + PTR_TYPE); + + $qsort = $libc->DeclareSub("qsort", "", + "P", "I", "I", PTR_TYPE); + &$qsort($array, scalar(@list), length($array) / @list, $callback->Ptr()); + + @expected = sort { length($a) <=> length($b) } @list; + @got = unpack("p*", $array); + assert(1, "[@got]", "[@expected]"); + + # Hey! We've got callbacks. We've got a way to call them. + # Who needs libraries? + undef $callback; + $callback = new C::DynaLib::Callback(sub { + $_[0] + 10*$_[1] + 100*$_[2]; + }, "i", "i", "p", "i"); + $sub = DeclareSub($callback->Ptr(), "i", "i", "p", "i"); + + $got = &$sub(1, $tmp = 7, 3.14); + $expected = 371; + assert(1, $got, $expected); + + undef $callback; + $callback = new C::DynaLib::Callback(sub { shift }, "I", "i"); + $sub = DeclareSub($callback->Ptr(), "I", "i"); + $got = &$sub(-1); + + # Can't do this because it's broken in too many Perl versions: + # $expected = unpack("I", pack("i", -1)); + $expected = 0; + for ($i = 1; $i > 0; $i <<= 1) { + $expected += $i; + } + $expected -= $i; + assert(1, $got, $expected); + + $int_size = length(pack("i",0)); + undef $callback; + $callback = new C::DynaLib::Callback(sub { + $global = shift; + $global .= pack("i", shift); + return unpack(PTR_TYPE, pack("P", $global)); + }, + PTR_TYPE, "P".(2 * $int_size), "i"); + $sub = DeclareSub($callback->Ptr(), "P".(3 * $int_size), + PTR_TYPE, "i"); + $array = pack("ii", 1729, 31415); + $pointer = unpack(PTR_TYPE, pack("P", $array)); + $struct = &$sub($pointer, 253); + @got = unpack("iii", $struct); + assert(1, "[@got]", "[1729 31415 253]"); + +} else { + warn("Skipping callback tests on this platform\n"); + assert(1); + assert(1); + assert(1); + assert(1); +} + +$buf = "willo"; +C::DynaLib::Poke(unpack(PTR_TYPE, + pack("p", $buf)), "he"); +assert(1, $buf, "hello"); + +# Can't unload libraries (portably, yet) because DynaLoader does not +# support this. diff --git a/testcall.c b/testcall.c new file mode 100644 index 0000000..d3e9ec9 --- /dev/null +++ b/testcall.c @@ -0,0 +1,187 @@ +/* + * This program tries to generate an appropriate header file for + * inclusion with cdecl.c. + */ + +#include +#include +#undef fprintf +#undef fopen +#undef fclose + +#include + +#ifdef INCLUDE_ALLOCA +#include +#endif +#ifdef INCLUDE_MALLOC +#include +#endif + +#ifndef SIGSEGV +#include +#endif + +I32 a[] = { 225437, 616282, 3853003, 899434198, 86381619, + 16556758, 94159, 4893126, 77778212 }; + +int grows_downward; +int one_by_one = 1; +int reverse = 0; +int do_reverse = 0; +int args_size[2]; +int adjust[] = {0, 0}; +int do_adjust = 0; + +int *which; + +void handler(int sig) { + exit(1); +} + +int test(b0, b1, b2, b3, b4, b5, b6, b7, b8) + I32 b0, b1, b2, b3, b4, b5, b6, b7, b8; +{ + int i; + + if (b0 == a[0] + && b1 == a[1] + && b2 == a[2] + && b3 == a[3] + && b4 == a[4] + && b5 == a[5] + && b6 == a[6] + && b7 == a[7] + && b8 == a[8] + ) + { + return 1; + } + for (i = 0; i < 9; i++) { + if (a[i] == b4) { + if ((i == 0 || a[i-1] == b3) && (i == 8 || a[i+1] == b5)) { + *which = (i - 4) * sizeof (I32); + break; + } + else if ((i == 0 || a[i-1] == b5) && (i == 8 || a[i+1] == b3)) { + reverse = 1; + *which = (i - 4) * sizeof (I32); + break; + } + } + } + return 0; +} + +int do_one_arg(x) + char *x; +{ + char *arg; + int i; + + args_size[0] = sizeof x; + which = &adjust[0]; + if (one_by_one) { + for (i = 8; i >= 0; i--) { + arg = (char *) alloca(sizeof (I32)); + Copy(&a[do_reverse ? 8-i : i], arg, sizeof (I32), char); + } + } + else { + arg = (char *) alloca(sizeof a) + do_adjust; + for (i = 0; i < 9; i++) { + Copy(&a[do_reverse ? 8-i : i], arg, sizeof (I32), char); + arg += sizeof (I32); + } + } + return ((int (*)()) test)(); +} + +int do_three_args(x, y, z) + int x; + char *y; + double z; +{ + char *arg; + int i; + + args_size[1] = sizeof x + sizeof y + sizeof z; + which = &adjust[1]; + if (one_by_one) { + for (i = 8; i >= 0; i--) { + arg = (char *) alloca(sizeof (I32)); + Copy(&a[do_reverse ? 8-i : i], arg, sizeof (I32), char); + } + } + else { + arg = (char *) alloca(sizeof a) + do_adjust; + for (i = 0; i < 9; i++) { + Copy(&a[do_reverse ? 8-i : i], arg, sizeof (I32), char); + arg += sizeof (I32); + } + } + return ((int (*)()) test)(); +} + +int main(argc, argv, env) + int argc; + char **argv; + char **env; +{ + FILE *fp; + int one_arg, three_args; + int *p1, *p2; + +#ifdef SIGSEGV + signal(SIGSEGV, handler); +#endif +#ifdef SIGILL + signal(SIGILL, handler); +#endif + p1 = (int *) alloca(sizeof *p1); + p2 = (int *) alloca(sizeof *p2); + grows_downward = (p1 - p2 > 0 ? 1 : 0); + one_by_one = (p1 - p2 == (grows_downward ? 1 : -1)); + + one_arg = do_one_arg(NULL); + if (reverse) { + do_reverse = reverse ^ (one_by_one ? grows_downward : 0); + one_arg = do_one_arg(NULL); + } + three_args = do_three_args(0, NULL, 0.0); + if (! one_arg || ! three_args) { + if (adjust[0] != 0 && adjust[0] == adjust[1]) { + do_adjust = adjust[0]; + one_arg = do_one_arg(NULL); + three_args = do_three_args(0, NULL, 0.0); + } + } + if (one_arg && three_args) { + fp = fopen("cdecl.h", "w"); + if (fp == NULL) { + return 1; + } + fprintf(fp, "/*\n" + " * cdecl.h -- configuration parameters for the cdecl calling convention\n" + " *\n" + " * Generated automatically by %s.\n", argv[0]); +#ifndef __FILE__ +#define __FILE__ "testcall.c" +#endif + fprintf(fp, " * Do not edit this file. Edit %s and/or Makefile.PL instead.\n", + __FILE__); + fprintf(fp, " */\n\n"); +#ifdef INCLUDE_ALLOCA + fprintf(fp, "#include \n"); +#endif +#ifdef INCLUDE_MALLOC + fprintf(fp, "#include \n"); +#endif + fprintf(fp, "#define CDECL_ONE_BY_ONE %d\n", one_by_one); + fprintf(fp, "#define CDECL_ADJUST %d\n", do_adjust); + fprintf(fp, "#define CDECL_REVERSE %d\n", do_reverse); + fclose(fp); + return 0; + } + return 1; +}