Commit | Line | Data |
760ac839 |
1 | package OS2::REXX; |
2 | |
3 | use Carp; |
4 | require Exporter; |
5 | require DynaLoader; |
6 | @ISA = qw(Exporter DynaLoader); |
7 | # Items to export into callers namespace by default |
8 | # (move infrequently used names to @EXPORT_OK below) |
9 | @EXPORT = qw(REXX_call REXX_eval REXX_eval_with); |
10 | # Other items we are prepared to export if requested |
11 | @EXPORT_OK = qw(drop); |
12 | |
13 | sub AUTOLOAD { |
14 | $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/ |
15 | or confess("Undefined subroutine &$AUTOLOAD called"); |
16 | return undef if $1 eq "DESTROY"; |
17 | $_[0]->find($1) |
18 | or confess("Can't find entry '$1' to DLL '$_[0]->{File}'"); |
19 | goto &$AUTOLOAD; |
20 | } |
21 | |
22 | @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); |
23 | %dlls = (); |
24 | |
25 | bootstrap OS2::REXX; |
26 | |
27 | # Preloaded methods go here. Autoload methods go after __END__, and are |
28 | # processed by the autosplit program. |
29 | |
30 | # Cannot autoload, the autoloader is used for the REXX functions. |
31 | |
32 | sub load |
33 | { |
34 | confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1; |
35 | my ($class, $file, @where) = (@_, @libs); |
36 | return $dlls{$file} if $dlls{$file}; |
37 | my $handle; |
38 | foreach (@where) { |
39 | $handle = DynaLoader::dl_load_file("$_/$file.dll"); |
40 | last if $handle; |
41 | } |
fb73857a |
42 | $handle = DynaLoader::dl_load_file($file) unless $handle; |
760ac839 |
43 | return undef unless $handle; |
44 | eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');" |
45 | . "sub AUTOLOAD {" |
46 | . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;" |
47 | . " goto &OS2::REXX::AUTOLOAD;" |
48 | . "} 1;" or die "eval package $@"; |
49 | return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file"; |
50 | } |
51 | |
52 | sub find |
53 | { |
54 | my $self = shift; |
55 | my $file = $self->{File}; |
56 | my $handle = $self->{Handle}; |
57 | my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; |
58 | my $queue = $self->{Queue}; |
59 | foreach (@_) { |
60 | my $name = "OS2::REXX::${file}::$_"; |
61 | next if defined(&$name); |
62 | my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) |
63 | || DynaLoader::dl_find_symbol($handle, $prefix.$_) |
64 | or return 0; |
65 | eval "package OS2::REXX::$file; sub $_". |
66 | "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }". |
67 | "1;" |
68 | or die "eval sub"; |
69 | } |
70 | return 1; |
71 | } |
72 | |
73 | sub prefix |
74 | { |
75 | my $self = shift; |
76 | $self->{Prefix} = shift; |
77 | } |
78 | |
79 | sub queue |
80 | { |
81 | my $self = shift; |
82 | $self->{Queue} = shift; |
83 | } |
84 | |
85 | sub drop |
86 | { # Supposedly should drop anything with |
87 | # the given prefix. Unfortunately a |
88 | # loop is needed after fixpack17. |
89 | &OS2::REXX::_drop(@_); |
90 | } |
91 | |
92 | sub dropall |
93 | { # Supposedly should drop anything with |
94 | # the given prefix. Unfortunately a |
95 | # loop is needed after fixpack17. |
96 | &OS2::REXX::_drop(@_); # Try to drop them all. |
97 | my $name; |
98 | for (@_) { |
99 | if (/\.$/) { |
100 | OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator |
101 | while (($name) = OS2::REXX::_next($_)) { |
102 | OS2::REXX::_drop($_ . $name); |
103 | } |
104 | } |
105 | } |
106 | } |
107 | |
108 | sub TIESCALAR |
109 | { |
110 | my ($obj, $name) = @_; |
f02a87df |
111 | $name =~ s/^([\w!?]+)/\U$1\E/; |
760ac839 |
112 | return bless \$name, OS2::REXX::_SCALAR; |
113 | } |
114 | |
115 | sub TIEARRAY |
116 | { |
117 | my ($obj, $name) = @_; |
f02a87df |
118 | $name =~ s/^([\w!?]+)/\U$1\E/; |
760ac839 |
119 | return bless [$name, 0], OS2::REXX::_ARRAY; |
120 | } |
121 | |
122 | sub TIEHASH |
123 | { |
124 | my ($obj, $name) = @_; |
f02a87df |
125 | $name =~ s/^([\w!?]+)/\U$1\E/; |
760ac839 |
126 | return bless {Stem => $name}, OS2::REXX::_HASH; |
127 | } |
128 | |
129 | ############################################################################# |
130 | package OS2::REXX::_SCALAR; |
131 | |
132 | sub FETCH |
133 | { |
134 | return OS2::REXX::_fetch(${$_[0]}); |
135 | } |
136 | |
137 | sub STORE |
138 | { |
139 | return OS2::REXX::_set(${$_[0]}, $_[1]); |
140 | } |
141 | |
142 | sub DESTROY |
143 | { |
144 | return OS2::REXX::_drop(${$_[0]}); |
145 | } |
146 | |
147 | ############################################################################# |
148 | package OS2::REXX::_ARRAY; |
149 | |
150 | sub FETCH |
151 | { |
152 | $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; |
153 | return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); |
154 | } |
155 | |
156 | sub STORE |
157 | { |
158 | $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; |
159 | return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); |
160 | } |
161 | |
162 | ############################################################################# |
163 | package OS2::REXX::_HASH; |
164 | |
165 | require Tie::Hash; |
166 | @ISA = ('Tie::Hash'); |
167 | |
168 | sub FIRSTKEY |
169 | { |
170 | my ($self) = @_; |
171 | my $stem = $self->{Stem}; |
172 | |
173 | delete $self->{List} if exists $self->{List}; |
174 | |
175 | my @list = (); |
176 | my ($name, $value); |
177 | OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator |
178 | while (($name) = OS2::REXX::_next($stem)) { |
179 | push @list, $name; |
180 | } |
181 | my $key = pop @list; |
182 | |
183 | $self->{List} = \@list; |
184 | return $key; |
185 | } |
186 | |
187 | sub NEXTKEY |
188 | { |
189 | return pop @{$_[0]->{List}}; |
190 | } |
191 | |
192 | sub EXISTS |
193 | { |
194 | return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); |
195 | } |
196 | |
197 | sub FETCH |
198 | { |
199 | return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); |
200 | } |
201 | |
202 | sub STORE |
203 | { |
204 | return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); |
205 | } |
206 | |
207 | sub DELETE |
208 | { |
209 | OS2::REXX::_drop($_[0]->{Stem}.$_[1]); |
210 | } |
211 | |
212 | ############################################################################# |
213 | package OS2::REXX; |
214 | |
215 | 1; |
216 | __END__ |
217 | |
218 | =head1 NAME |
219 | |
220 | OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. |
221 | |
222 | =head2 NOTE |
223 | |
224 | By default, the REXX variable pool is not available, neither |
225 | to Perl, nor to external REXX functions. To enable it, you need to put |
226 | your code inside C<REXX_call> function. REXX functions which do not use |
227 | variables may be usable even without C<REXX_call> though. |
228 | |
229 | =head1 SYNOPSIS |
230 | |
231 | use OS2::REXX; |
232 | $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!"; |
233 | @pid = $ydb->RxProcId(); |
234 | REXX_call { |
235 | tie $s, OS2::REXX, "TEST"; |
236 | $s = 1; |
237 | }; |
238 | |
239 | =head1 DESCRIPTION |
240 | |
241 | =head2 Load REXX DLL |
242 | |
243 | $dll = load OS2::REXX NAME [, WHERE]; |
244 | |
245 | NAME is DLL name, without path and extension. |
246 | |
247 | Directories are searched WHERE first (list of dirs), then environment |
fb73857a |
248 | paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search |
249 | is performed in default DLL path (without adding paths and extensions). |
760ac839 |
250 | |
251 | The DLL is not unloaded when the variable dies. |
252 | |
253 | Returns DLL object reference, or undef on failure. |
254 | |
255 | =head2 Define function prefix: |
256 | |
257 | $dll->prefix(NAME); |
258 | |
259 | Define the prefix of external functions, prepended to the function |
260 | names used within your program, when looking for the entries in the |
261 | DLL. |
262 | |
263 | =head2 Example |
264 | |
265 | $dll = load OS2::REXX "RexxBase"; |
266 | $dll->prefix("RexxBase_"); |
267 | $dll->Init(); |
268 | |
269 | is the same as |
270 | |
271 | $dll = load OS2::REXX "RexxBase"; |
272 | $dll->RexxBase_Init(); |
273 | |
274 | =head2 Define queue: |
275 | |
276 | $dll->queue(NAME); |
277 | |
278 | Define the name of the REXX queue passed to all external |
279 | functions of this module. Defaults to "SESSION". |
280 | |
281 | Check for functions (optional): |
282 | |
283 | BOOL = $dll->find(NAME [, NAME [, ...]]); |
284 | |
285 | Returns true if all functions are available. |
286 | |
287 | =head2 Call external REXX function: |
288 | |
289 | $dll->function(arguments); |
290 | |
291 | Returns the return string if the return code is 0, else undef. |
292 | Dies with error message if the function is not available. |
293 | |
294 | =head1 Accessing REXX-runtime |
295 | |
296 | While calling functions with REXX signature does not require the presence |
297 | of the system REXX DLL, there are some actions which require REXX-runtime |
298 | present. Among them is the access to REXX variables by name. |
299 | |
300 | One enables REXX runtime by bracketing your code by |
301 | |
302 | REXX_call BLOCK; |
303 | |
304 | (trailing semicolon required!) or |
305 | |
306 | REXX_call \&subroutine_name; |
307 | |
308 | Inside such a call one has access to REXX variables (see below), and to |
309 | |
310 | REXX_eval EXPR; |
311 | REXX_eval_with EXPR, |
312 | subroutine_name_in_REXX => \&Perl_subroutine |
313 | |
314 | =head2 Bind scalar variable to REXX variable: |
315 | |
316 | tie $var, OS2::REXX, "NAME"; |
317 | |
318 | =head2 Bind array variable to REXX stem variable: |
319 | |
320 | tie @var, OS2::REXX, "NAME."; |
321 | |
322 | Only scalar operations work so far. No array assignments, no array |
323 | operations, ... FORGET IT. |
324 | |
325 | =head2 Bind hash array variable to REXX stem variable: |
326 | |
327 | tie %var, OS2::REXX, "NAME."; |
328 | |
329 | To access all visible REXX variables via hash array, bind to ""; |
330 | |
331 | No array assignments. No array operations, other than hash array |
332 | operations. Just like the *dbm based implementations. |
333 | |
334 | For the usual REXX stem variables, append a "." to the name, |
335 | as shown above. If the hash key is part of the stem name, for |
336 | example if you bind to "", you cannot use lower case in the stem |
337 | part of the key and it is subject to character set restrictions. |
338 | |
339 | =head2 Erase individual REXX variables (bound or not): |
340 | |
341 | OS2::REXX::drop("NAME" [, "NAME" [, ...]]); |
342 | |
343 | =head2 Erase REXX variables with given stem (bound or not): |
344 | |
345 | OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); |
346 | |
347 | =head1 NOTES |
348 | |
349 | Note that while function and variable names are case insensitive in the |
350 | REXX language, function names exported by a DLL and the REXX variables |
351 | (as seen by Perl through the chosen API) are all case sensitive! |
352 | |
353 | Most REXX DLLs export function names all upper case, but there are a |
354 | few which export mixed case names (such as RxExtras). When trying to |
355 | find the entry point, both exact case and all upper case are searched. |
356 | If the DLL exports "RxNap", you have to specify the exact case, if it |
357 | exports "RXOPEN", you can use any case. |
358 | |
359 | To avoid interfering with subroutine names defined by Perl (DESTROY) |
360 | or used within the REXX module (prefix, find), it is best to use mixed |
361 | case and to avoid lowercase only or uppercase only names when calling |
362 | REXX functions. Be consistent. The same function written in different |
363 | ways results in different Perl stubs. |
364 | |
365 | There is no REXX interpolation on variable names, so the REXX variable |
366 | name TEST.ONE is not affected by some other REXX variable ONE. And it |
367 | is not the same variable as TEST.one! |
368 | |
369 | You cannot call REXX functions which are not exported by the DLL. |
370 | While most DLLs export all their functions, some, like RxFTP, export |
371 | only "...LoadFuncs", which registers the functions within REXX only. |
372 | |
373 | You cannot call 16-bit DLLs. The few interesting ones I found |
374 | (FTP,NETB,APPC) do not export their functions. |
375 | |
376 | I do not know whether the REXX API is reentrant with respect to |
377 | exceptions (signals) when the REXX top-level exception handler is |
378 | overridden. So unless you know better than I do, do not access REXX |
379 | variables (probably tied to Perl variables) or call REXX functions |
380 | which access REXX queues or REXX variables in signal handlers. |
381 | |
382 | See C<t/rx*.t> for examples. |
383 | |
384 | =head1 AUTHOR |
385 | |
386 | Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich |
387 | ilya@math.ohio-state.edu. |
388 | |
389 | =cut |