Commit | Line | Data |
ed344e4f |
1 | package OS2::DLL; |
2 | |
9d419b5f |
3 | our $VERSION = '1.03'; |
28b605d8 |
4 | |
ed344e4f |
5 | use Carp; |
5c728af0 |
6 | use XSLoader; |
ed344e4f |
7 | |
ed344e4f |
8 | @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); |
9 | %dlls = (); |
10 | |
11 | # Preloaded methods go here. Autoload methods go after __END__, and are |
12 | # processed by the autosplit program. |
13 | |
622913ab |
14 | # Cannot be autoload, the autoloader is used for the REXX functions. |
ed344e4f |
15 | |
622913ab |
16 | my $load_with_dirs = sub { |
17 | my ($class, $file, @where) = (@_); |
ed344e4f |
18 | return $dlls{$file} if $dlls{$file}; |
19 | my $handle; |
20 | foreach (@where) { |
21 | $handle = DynaLoader::dl_load_file("$_/$file.dll"); |
22 | last if $handle; |
23 | } |
24 | $handle = DynaLoader::dl_load_file($file) unless $handle; |
25 | return undef unless $handle; |
622913ab |
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; |
ed344e4f |
30 | return $dlls{$file} = |
622913ab |
31 | bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p; |
32 | }; |
33 | |
34 | my $new_dll = sub { |
35 | my ($dirs, $class, $file) = (shift, shift, shift); |
36 | my $handle; |
37 | push @_, @libs if $dirs; |
38 | $handle = $load_with_dirs->($class, $file, @_) |
39 | and return $handle; |
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"; |
44 | }; |
45 | |
46 | sub new { |
47 | confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2; |
48 | $new_dll->(1, @_); |
ed344e4f |
49 | } |
50 | |
622913ab |
51 | sub module { |
52 | confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2; |
53 | $new_dll->(0, @_); |
54 | } |
55 | |
56 | sub load { |
57 | confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1; |
58 | $load_with_dirs->(@_, @libs); |
59 | } |
60 | |
1933e12c |
61 | sub libPath_find { |
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 |
9d419b5f |
67 | s,(?![/\\])$,/, for @path; |
68 | s,\\,/,g for @path; |
1933e12c |
69 | $name .= ".dll" unless $name =~ /\.[^\\\/]*$/; |
70 | $_ .= $name for @path; |
9d419b5f |
71 | return grep -f $_, @path if $flags & 0x8; |
1933e12c |
72 | -f $_ and return $_ for @path; |
73 | return; |
74 | } |
75 | |
622913ab |
76 | package OS2::DLL::dll; |
77 | use Carp; |
78 | @ISA = 'OS2::DLL'; |
79 | |
80 | sub AUTOLOAD { |
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($@); |
86 | goto &$AUTOLOAD; |
87 | } |
88 | |
89 | sub wrapper_REXX { |
90 | confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2; |
ed344e4f |
91 | my $self = shift; |
92 | my $file = $self->{File}; |
93 | my $handle = $self->{Handle}; |
94 | my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; |
95 | my $queue = $self->{Queue}; |
622913ab |
96 | my $name = shift; |
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)); |
100 | return sub { |
101 | OS2::DLL::_call($name, $addr, $queue, @_); |
102 | } if $addr; |
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"; |
ed344e4f |
106 | } |
622913ab |
107 | |
108 | sub find |
109 | { |
110 | my $self = shift; |
111 | my $file = $self->{File}; |
112 | my $p = ref $self; |
113 | foreach (@_) { |
114 | my $f = eval {$self->wrapper_REXX($_)} or return 0; |
115 | ${"${p}::"}{$_} = sub { shift; $f->(@_) }; |
ed344e4f |
116 | } |
117 | return 1; |
118 | } |
119 | |
1933e12c |
120 | sub handle { shift->{Handle} } |
121 | sub fullname { OS2::DLLname(0x202, shift->handle) } |
122 | #sub modname { OS2::DLLname(0x201, shift->handle) } |
123 | |
124 | sub has_f32 { |
125 | my $handle = shift->handle; |
126 | my $name = shift; |
127 | DynaLoader::dl_find_symbol($handle, $name); |
128 | } |
129 | |
5c728af0 |
130 | XSLoader::load 'OS2::DLL'; |
ed344e4f |
131 | |
132 | 1; |
133 | __END__ |
134 | |
135 | =head1 NAME |
136 | |
137 | OS2::DLL - access to DLLs with REXX calling convention. |
138 | |
139 | =head2 NOTE |
140 | |
141 | When you use this module, the REXX variable pool is not available. |
142 | |
143 | See documentation of L<OS2::REXX> module if you need the variable pool. |
144 | |
145 | =head1 SYNOPSIS |
146 | |
147 | use OS2::DLL; |
622913ab |
148 | $emx_dll = OS2::DLL->module('emx'); |
ed344e4f |
149 | $emx_version = $emx_dll->emx_revision(); |
622913ab |
150 | $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision |
151 | $emx_version = $func_emx_version->(); |
ed344e4f |
152 | |
153 | =head1 DESCRIPTION |
154 | |
622913ab |
155 | =head2 Create a DLL handle |
ed344e4f |
156 | |
622913ab |
157 | $dll = OS2::DLL->module( NAME [, WHERE] ); |
ed344e4f |
158 | |
622913ab |
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. |
ed344e4f |
162 | |
622913ab |
163 | The DLL is not unloaded when the return value is destroyed. |
ed344e4f |
164 | |
622913ab |
165 | =head2 Create a DLL handle (looking in some strange locations) |
ed344e4f |
166 | |
622913ab |
167 | $dll = OS2::DLL->new( NAME [, WHERE] ); |
a748068b |
168 | |
622913ab |
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 |
171 | compatibility). |
a748068b |
172 | |
622913ab |
173 | =head2 Loads DLL by name |
a748068b |
174 | |
622913ab |
175 | $dll = load OS2::DLL NAME [, WHERE]; |
176 | |
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 |
180 | compatibility). |
ed344e4f |
181 | |
182 | =head2 Check for functions (optional): |
183 | |
184 | BOOL = $dll->find(NAME [, NAME [, ...]]); |
185 | |
622913ab |
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 |
189 | method. |
190 | |
191 | =head2 Create a Perl wrapper (optional): |
192 | |
193 | $func = $dll->wrapper_REXX(NAME); |
194 | |
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 |
199 | be confusing). |
200 | |
201 | =head2 Call external function with REXX calling convention: |
202 | |
203 | $ret_string = $dll->function_name(arguments); |
204 | |
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 |
208 | through the wrapper. |
209 | |
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 |
212 | function. |
213 | |
1933e12c |
214 | =head1 Inspecting the module |
215 | |
216 | =over |
217 | |
218 | =item $module->handle |
219 | |
220 | =item $module->fullname |
221 | |
222 | Return the (integer) handle and full path name of a loaded DLL. |
223 | |
224 | TODO: the module name (whatever is specified in the C<LIBRARY> statement |
225 | of F<.def> file when linking) via OS2::Proc. |
226 | |
227 | =item $module->has_f32($name) |
228 | |
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. |
233 | |
234 | =item libPath_find($name [, $flags]) |
235 | |
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.> |
240 | |
241 | $name has F<.dll> appended unless it already has an extension. |
242 | |
243 | =back |
244 | |
622913ab |
245 | =head1 Low-level API |
246 | |
247 | =over |
248 | |
249 | =item Call a _System linkage function via a pointer |
250 | |
251 | If a function takes up to 20 ULONGs and returns ULONG: |
252 | |
253 | $res = call20( $pointer, $arg0, $arg1, ...); |
254 | |
255 | =item Same for packed arguments: |
256 | |
257 | $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...); |
258 | |
259 | =item Same for C<regparm(3)> function: |
260 | |
261 | $res = call20_rp3( $pointer, $arg0, $arg1, ...); |
262 | |
263 | =item Same for packed arguments and C<regparm(3)> function |
264 | |
265 | $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...); |
266 | |
267 | =item Same for a function which returns non-0 and sets system-error on error |
268 | |
269 | call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error |
270 | |
271 | [Good for C<Dos*> API - and rare C<Win*> calls.] |
272 | |
273 | =item Same for a function which returns 0 and sets WinLastError() on error |
274 | |
275 | $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...); |
276 | # would die("$msg: $^E") if error |
277 | |
278 | [Good for most of C<Win*> API.] |
279 | |
280 | =item Same for a function which returns 0 and sets WinLastError() on error but |
281 | 0 is also a valid return |
282 | |
283 | $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...); |
284 | # would die("$msg: $^E") if error |
285 | |
286 | [Good for some of C<Win*> API.] |
287 | |
288 | =item As previous, but without die() |
ed344e4f |
289 | |
622913ab |
290 | $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...); |
291 | if ($res == 0 and $^E) { # Do error processing here |
292 | } |
ed344e4f |
293 | |
622913ab |
294 | [Good for some of C<Win*> API.] |
ed344e4f |
295 | |
622913ab |
296 | =back |
ed344e4f |
297 | |
298 | =head1 ENVIRONMENT |
299 | |
300 | If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs |
301 | in C<PERL5REXX>, C<PERLREXX>, C<PATH>. |
302 | |
303 | =head1 AUTHOR |
304 | |
622913ab |
305 | Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX> |
ed344e4f |
306 | written by Andreas Kaiser ak@ananke.s.bawue.de. |
307 | |
308 | =cut |