8 @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
11 # Preloaded methods go here. Autoload methods go after __END__, and are
12 # processed by the autosplit program.
14 # Cannot be autoload, the autoloader is used for the REXX functions.
16 my $load_with_dirs = sub {
17 my ($class, $file, @where) = (@_);
18 return $dlls{$file} if $dlls{$file};
21 $handle = DynaLoader::dl_load_file("$_/$file.dll");
24 $handle = DynaLoader::dl_load_file($file) unless $handle;
25 return undef unless $handle;
26 my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll';
27 my $p = "OS2::DLL::dll::$file";
28 @{"$p\::ISA"} = @packs;
29 *{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD;
31 bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p;
35 my ($dirs, $class, $file) = (shift, shift, shift);
37 push @_, @libs if $dirs;
38 $handle = $load_with_dirs->($class, $file, @_)
40 my $path = @_ ? " from '@_'" : '';
41 my $err = DynaLoader::dl_error();
42 $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
43 croak "Can't load '$file'$path: $err";
47 confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
52 confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2;
57 confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
58 $load_with_dirs->(@_, @libs);
62 my ($name, $flags, @path) = (shift, shift);
63 $flags = 0x7 unless defined $flags;
64 push @path, split /;/, OS2::extLibpath if $flags & 0x1; # BEGIN
65 push @path, split /;/, OS2::libPath if $flags & 0x2;
66 push @path, split /;/, OS2::extLibpath(1) if $flags & 0x4; # END
67 s,(?![/\\])$,/, for @path;
69 $name .= ".dll" unless $name =~ /\.[^\\\/]*$/;
70 $_ .= $name for @path;
71 return grep -f $_, @path if $flags & 0x8;
72 -f $_ and return $_ for @path;
76 package OS2::DLL::dll;
81 $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/
82 or confess("Undefined subroutine &$AUTOLOAD called");
83 return undef if $1 eq "DESTROY";
84 die "AUTOLOAD loop" if $1 eq "AUTOLOAD";
85 $_[0]->find($1) or confess($@);
90 confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2;
92 my $file = $self->{File};
93 my $handle = $self->{Handle};
94 my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
95 my $queue = $self->{Queue};
97 $prefix = '' if $name =~ /^#\d+/; # loading by ordinal
98 my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
99 || DynaLoader::dl_find_symbol($handle, $prefix.$name));
101 OS2::DLL::_call($name, $addr, $queue, @_);
103 my $err = DynaLoader::dl_error();
104 $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
105 croak "Can't find symbol `$name' in DLL `$file': $err";
111 my $file = $self->{File};
114 my $f = eval {$self->wrapper_REXX($_)} or return 0;
115 ${"${p}::"}{$_} = sub { shift; $f->(@_) };
120 sub handle { shift->{Handle} }
121 sub fullname { OS2::DLLname(0x202, shift->handle) }
122 #sub modname { OS2::DLLname(0x201, shift->handle) }
125 my $handle = shift->handle;
127 DynaLoader::dl_find_symbol($handle, $name);
130 XSLoader::load 'OS2::DLL';
137 OS2::DLL - access to DLLs with REXX calling convention.
141 When you use this module, the REXX variable pool is not available.
143 See documentation of L<OS2::REXX> module if you need the variable pool.
148 $emx_dll = OS2::DLL->module('emx');
149 $emx_version = $emx_dll->emx_revision();
150 $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
151 $emx_version = $func_emx_version->();
155 =head2 Create a DLL handle
157 $dll = OS2::DLL->module( NAME [, WHERE] );
159 Loads an OS/2 module NAME, looking in directories WHERE (adding the
160 extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way
161 (via LIBPATH and other settings). Croaks with a verbose report on failure.
163 The DLL is not unloaded when the return value is destroyed.
165 =head2 Create a DLL handle (looking in some strange locations)
167 $dll = OS2::DLL->new( NAME [, WHERE] );
169 Same as L<C<module>|Create a DLL handle>, but in addition to WHERE, looks
170 in environment paths PERL5REXX, PERLREXX, PATH (provided for backward
173 =head2 Loads DLL by name
175 $dll = load OS2::DLL NAME [, WHERE];
177 Same as L<C<new>|Create a DLL handle (looking in some strange locations)>,
178 but returns DLL object reference, or undef on failure (in this case one can
179 get the reason via C<DynaLoader::dl_error()>) (provided for backward
182 =head2 Check for functions (optional):
184 BOOL = $dll->find(NAME [, NAME [, ...]]);
186 Returns true if all functions are available. As a side effect, creates
187 a REXX wrapper with the specified name in the package constructed by the name
188 of the DLL so that the next call to C<$dll->NAME()> will pick up the cached
191 =head2 Create a Perl wrapper (optional):
193 $func = $dll->wrapper_REXX(NAME);
195 Returns a reference to a Perl function wrapper for the entry point NAME
196 in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case
197 the ordinal is loaded. Croaks with a meaningful error message if NAME does
198 not exists (although the message for the case when the name is an ordinal may
201 =head2 Call external function with REXX calling convention:
203 $ret_string = $dll->function_name(arguments);
205 Returns the return string if the REXX return code is 0, else undef.
206 Dies with error message if the function is not available. On the first call
207 resolves the name in the DLL and caches the Perl wrapper; future calls go
210 Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime
211 environment (variable pool, queue etc.) is not available to the called
214 =head1 Inspecting the module
218 =item $module->handle
220 =item $module->fullname
222 Return the (integer) handle and full path name of a loaded DLL.
224 TODO: the module name (whatever is specified in the C<LIBRARY> statement
225 of F<.def> file when linking) via OS2::Proc.
227 =item $module->has_f32($name)
229 Returns the address of a 32-bit entry point with name $name, or 0 if none
230 found. (Keep in mind that some entry points may be 16-bit, and some may have
231 capitalized names comparing to callable-from-C counterparts.) Name of the
232 form C<#197> will find entry point with ordinal 197.
234 =item libPath_find($name [, $flags])
236 Looks for the DLL $name on C<BEGINLIBPATH>, C<LIBPATH>, C<ENDLIBPATH> if
237 bits 0x1, 0x2, 0x4 of $flags are set correspondingly. If called with no
238 arguments, looks on all 3 locations. Returns the full name of the found
239 file. B<DLL is not loaded.>
241 $name has F<.dll> appended unless it already has an extension.
249 =item Call a _System linkage function via a pointer
251 If a function takes up to 20 ULONGs and returns ULONG:
253 $res = call20( $pointer, $arg0, $arg1, ...);
255 =item Same for packed arguments:
257 $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...);
259 =item Same for C<regparm(3)> function:
261 $res = call20_rp3( $pointer, $arg0, $arg1, ...);
263 =item Same for packed arguments and C<regparm(3)> function
265 $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...);
267 =item Same for a function which returns non-0 and sets system-error on error
269 call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error
271 [Good for C<Dos*> API - and rare C<Win*> calls.]
273 =item Same for a function which returns 0 and sets WinLastError() on error
275 $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...);
276 # would die("$msg: $^E") if error
278 [Good for most of C<Win*> API.]
280 =item Same for a function which returns 0 and sets WinLastError() on error but
281 0 is also a valid return
283 $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...);
284 # would die("$msg: $^E") if error
286 [Good for some of C<Win*> API.]
288 =item As previous, but without die()
290 $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
291 if ($res == 0 and $^E) { # Do error processing here
294 [Good for some of C<Win*> API.]
300 If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs
301 in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
305 Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
306 written by Andreas Kaiser ak@ananke.s.bawue.de.