Commit | Line | Data |
ed344e4f |
1 | package OS2::DLL; |
2 | |
2af1ab88 |
3 | our $VERSION = '1.01'; |
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 | |
61 | package OS2::DLL::dll; |
62 | use Carp; |
63 | @ISA = 'OS2::DLL'; |
64 | |
65 | sub AUTOLOAD { |
66 | $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/ |
67 | or confess("Undefined subroutine &$AUTOLOAD called"); |
68 | return undef if $1 eq "DESTROY"; |
69 | die "AUTOLOAD loop" if $1 eq "AUTOLOAD"; |
70 | $_[0]->find($1) or confess($@); |
71 | goto &$AUTOLOAD; |
72 | } |
73 | |
74 | sub wrapper_REXX { |
75 | confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2; |
ed344e4f |
76 | my $self = shift; |
77 | my $file = $self->{File}; |
78 | my $handle = $self->{Handle}; |
79 | my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; |
80 | my $queue = $self->{Queue}; |
622913ab |
81 | my $name = shift; |
82 | $prefix = '' if $name =~ /^#\d+/; # loading by ordinal |
83 | my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name) |
84 | || DynaLoader::dl_find_symbol($handle, $prefix.$name)); |
85 | return sub { |
86 | OS2::DLL::_call($name, $addr, $queue, @_); |
87 | } if $addr; |
88 | my $err = DynaLoader::dl_error(); |
89 | $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//; |
90 | croak "Can't find symbol `$name' in DLL `$file': $err"; |
ed344e4f |
91 | } |
622913ab |
92 | |
93 | sub find |
94 | { |
95 | my $self = shift; |
96 | my $file = $self->{File}; |
97 | my $p = ref $self; |
98 | foreach (@_) { |
99 | my $f = eval {$self->wrapper_REXX($_)} or return 0; |
100 | ${"${p}::"}{$_} = sub { shift; $f->(@_) }; |
ed344e4f |
101 | } |
102 | return 1; |
103 | } |
104 | |
5c728af0 |
105 | XSLoader::load 'OS2::DLL'; |
ed344e4f |
106 | |
107 | 1; |
108 | __END__ |
109 | |
110 | =head1 NAME |
111 | |
112 | OS2::DLL - access to DLLs with REXX calling convention. |
113 | |
114 | =head2 NOTE |
115 | |
116 | When you use this module, the REXX variable pool is not available. |
117 | |
118 | See documentation of L<OS2::REXX> module if you need the variable pool. |
119 | |
120 | =head1 SYNOPSIS |
121 | |
122 | use OS2::DLL; |
622913ab |
123 | $emx_dll = OS2::DLL->module('emx'); |
ed344e4f |
124 | $emx_version = $emx_dll->emx_revision(); |
622913ab |
125 | $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision |
126 | $emx_version = $func_emx_version->(); |
ed344e4f |
127 | |
128 | =head1 DESCRIPTION |
129 | |
622913ab |
130 | =head2 Create a DLL handle |
ed344e4f |
131 | |
622913ab |
132 | $dll = OS2::DLL->module( NAME [, WHERE] ); |
ed344e4f |
133 | |
622913ab |
134 | Loads an OS/2 module NAME, looking in directories WHERE (adding the |
135 | extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way |
136 | (via LIBPATH and other settings). Croaks with a verbose report on failure. |
ed344e4f |
137 | |
622913ab |
138 | The DLL is not unloaded when the return value is destroyed. |
ed344e4f |
139 | |
622913ab |
140 | =head2 Create a DLL handle (looking in some strange locations) |
ed344e4f |
141 | |
622913ab |
142 | $dll = OS2::DLL->new( NAME [, WHERE] ); |
a748068b |
143 | |
622913ab |
144 | Same as L<C<module>|Create a DLL handle>, but in addition to WHERE, looks |
145 | in environment paths PERL5REXX, PERLREXX, PATH (provided for backward |
146 | compatibility). |
a748068b |
147 | |
622913ab |
148 | =head2 Loads DLL by name |
a748068b |
149 | |
622913ab |
150 | $dll = load OS2::DLL NAME [, WHERE]; |
151 | |
152 | Same as L<C<new>|Create a DLL handle (looking in some strange locations)>, |
153 | but returns DLL object reference, or undef on failure (in this case one can |
154 | get the reason via C<DynaLoader::dl_error()>) (provided for backward |
155 | compatibility). |
ed344e4f |
156 | |
157 | =head2 Check for functions (optional): |
158 | |
159 | BOOL = $dll->find(NAME [, NAME [, ...]]); |
160 | |
622913ab |
161 | Returns true if all functions are available. As a side effect, creates |
162 | a REXX wrapper with the specified name in the package constructed by the name |
163 | of the DLL so that the next call to C<$dll->NAME()> will pick up the cached |
164 | method. |
165 | |
166 | =head2 Create a Perl wrapper (optional): |
167 | |
168 | $func = $dll->wrapper_REXX(NAME); |
169 | |
170 | Returns a reference to a Perl function wrapper for the entry point NAME |
171 | in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case |
172 | the ordinal is loaded. Croaks with a meaningful error message if NAME does |
173 | not exists (although the message for the case when the name is an ordinal may |
174 | be confusing). |
175 | |
176 | =head2 Call external function with REXX calling convention: |
177 | |
178 | $ret_string = $dll->function_name(arguments); |
179 | |
180 | Returns the return string if the REXX return code is 0, else undef. |
181 | Dies with error message if the function is not available. On the first call |
182 | resolves the name in the DLL and caches the Perl wrapper; future calls go |
183 | through the wrapper. |
184 | |
185 | Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime |
186 | environment (variable pool, queue etc.) is not available to the called |
187 | function. |
188 | |
189 | =head1 Low-level API |
190 | |
191 | =over |
192 | |
193 | =item Call a _System linkage function via a pointer |
194 | |
195 | If a function takes up to 20 ULONGs and returns ULONG: |
196 | |
197 | $res = call20( $pointer, $arg0, $arg1, ...); |
198 | |
199 | =item Same for packed arguments: |
200 | |
201 | $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...); |
202 | |
203 | =item Same for C<regparm(3)> function: |
204 | |
205 | $res = call20_rp3( $pointer, $arg0, $arg1, ...); |
206 | |
207 | =item Same for packed arguments and C<regparm(3)> function |
208 | |
209 | $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...); |
210 | |
211 | =item Same for a function which returns non-0 and sets system-error on error |
212 | |
213 | call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error |
214 | |
215 | [Good for C<Dos*> API - and rare C<Win*> calls.] |
216 | |
217 | =item Same for a function which returns 0 and sets WinLastError() on error |
218 | |
219 | $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...); |
220 | # would die("$msg: $^E") if error |
221 | |
222 | [Good for most of C<Win*> API.] |
223 | |
224 | =item Same for a function which returns 0 and sets WinLastError() on error but |
225 | 0 is also a valid return |
226 | |
227 | $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...); |
228 | # would die("$msg: $^E") if error |
229 | |
230 | [Good for some of C<Win*> API.] |
231 | |
232 | =item As previous, but without die() |
ed344e4f |
233 | |
622913ab |
234 | $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...); |
235 | if ($res == 0 and $^E) { # Do error processing here |
236 | } |
ed344e4f |
237 | |
622913ab |
238 | [Good for some of C<Win*> API.] |
ed344e4f |
239 | |
622913ab |
240 | =back |
ed344e4f |
241 | |
242 | =head1 ENVIRONMENT |
243 | |
244 | If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs |
245 | in C<PERL5REXX>, C<PERLREXX>, C<PATH>. |
246 | |
247 | =head1 AUTHOR |
248 | |
622913ab |
249 | Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX> |
ed344e4f |
250 | written by Andreas Kaiser ak@ananke.s.bawue.de. |
251 | |
252 | =cut |