Commit | Line | Data |
760ac839 |
1 | package OS2::REXX; |
2 | |
3 | use Carp; |
4 | require Exporter; |
5 | require DynaLoader; |
ed344e4f |
6 | require OS2::DLL; |
7 | |
760ac839 |
8 | @ISA = qw(Exporter DynaLoader); |
9 | # Items to export into callers namespace by default |
10 | # (move infrequently used names to @EXPORT_OK below) |
11 | @EXPORT = qw(REXX_call REXX_eval REXX_eval_with); |
12 | # Other items we are prepared to export if requested |
5ba48348 |
13 | @EXPORT_OK = qw(drop register); |
14 | |
9e2a34c1 |
15 | $VERSION = '1.01'; |
760ac839 |
16 | |
ed344e4f |
17 | # We cannot just put OS2::DLL in @ISA, since some scripts would use |
18 | # function interface, not method interface... |
760ac839 |
19 | |
ed344e4f |
20 | *_call = \&OS2::DLL::_call; |
21 | *load = \&OS2::DLL::load; |
22 | *find = \&OS2::DLL::find; |
760ac839 |
23 | |
24 | bootstrap OS2::REXX; |
25 | |
26 | # Preloaded methods go here. Autoload methods go after __END__, and are |
27 | # processed by the autosplit program. |
28 | |
5ba48348 |
29 | sub register {_register($_) for @_} |
30 | |
760ac839 |
31 | sub prefix |
32 | { |
33 | my $self = shift; |
34 | $self->{Prefix} = shift; |
35 | } |
36 | |
37 | sub queue |
38 | { |
39 | my $self = shift; |
40 | $self->{Queue} = shift; |
41 | } |
42 | |
43 | sub drop |
44 | { # Supposedly should drop anything with |
45 | # the given prefix. Unfortunately a |
46 | # loop is needed after fixpack17. |
47 | &OS2::REXX::_drop(@_); |
48 | } |
49 | |
50 | sub dropall |
51 | { # Supposedly should drop anything with |
52 | # the given prefix. Unfortunately a |
53 | # loop is needed after fixpack17. |
54 | &OS2::REXX::_drop(@_); # Try to drop them all. |
55 | my $name; |
56 | for (@_) { |
57 | if (/\.$/) { |
58 | OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator |
59 | while (($name) = OS2::REXX::_next($_)) { |
60 | OS2::REXX::_drop($_ . $name); |
61 | } |
62 | } |
63 | } |
64 | } |
65 | |
66 | sub TIESCALAR |
67 | { |
68 | my ($obj, $name) = @_; |
f02a87df |
69 | $name =~ s/^([\w!?]+)/\U$1\E/; |
760ac839 |
70 | return bless \$name, OS2::REXX::_SCALAR; |
71 | } |
72 | |
73 | sub TIEARRAY |
74 | { |
75 | my ($obj, $name) = @_; |
f02a87df |
76 | $name =~ s/^([\w!?]+)/\U$1\E/; |
760ac839 |
77 | return bless [$name, 0], OS2::REXX::_ARRAY; |
78 | } |
79 | |
80 | sub TIEHASH |
81 | { |
82 | my ($obj, $name) = @_; |
f02a87df |
83 | $name =~ s/^([\w!?]+)/\U$1\E/; |
760ac839 |
84 | return bless {Stem => $name}, OS2::REXX::_HASH; |
85 | } |
86 | |
87 | ############################################################################# |
88 | package OS2::REXX::_SCALAR; |
89 | |
90 | sub FETCH |
91 | { |
92 | return OS2::REXX::_fetch(${$_[0]}); |
93 | } |
94 | |
95 | sub STORE |
96 | { |
97 | return OS2::REXX::_set(${$_[0]}, $_[1]); |
98 | } |
99 | |
100 | sub DESTROY |
101 | { |
102 | return OS2::REXX::_drop(${$_[0]}); |
103 | } |
104 | |
105 | ############################################################################# |
106 | package OS2::REXX::_ARRAY; |
107 | |
108 | sub FETCH |
109 | { |
110 | $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; |
111 | return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); |
112 | } |
113 | |
114 | sub STORE |
115 | { |
116 | $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; |
117 | return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); |
118 | } |
119 | |
120 | ############################################################################# |
121 | package OS2::REXX::_HASH; |
122 | |
123 | require Tie::Hash; |
124 | @ISA = ('Tie::Hash'); |
125 | |
126 | sub FIRSTKEY |
127 | { |
128 | my ($self) = @_; |
129 | my $stem = $self->{Stem}; |
130 | |
131 | delete $self->{List} if exists $self->{List}; |
132 | |
133 | my @list = (); |
134 | my ($name, $value); |
135 | OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator |
136 | while (($name) = OS2::REXX::_next($stem)) { |
137 | push @list, $name; |
138 | } |
139 | my $key = pop @list; |
140 | |
141 | $self->{List} = \@list; |
142 | return $key; |
143 | } |
144 | |
145 | sub NEXTKEY |
146 | { |
147 | return pop @{$_[0]->{List}}; |
148 | } |
149 | |
150 | sub EXISTS |
151 | { |
152 | return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); |
153 | } |
154 | |
155 | sub FETCH |
156 | { |
157 | return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); |
158 | } |
159 | |
160 | sub STORE |
161 | { |
162 | return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); |
163 | } |
164 | |
165 | sub DELETE |
166 | { |
167 | OS2::REXX::_drop($_[0]->{Stem}.$_[1]); |
168 | } |
169 | |
170 | ############################################################################# |
171 | package OS2::REXX; |
172 | |
173 | 1; |
174 | __END__ |
175 | |
176 | =head1 NAME |
177 | |
178 | OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. |
179 | |
180 | =head2 NOTE |
181 | |
182 | By default, the REXX variable pool is not available, neither |
183 | to Perl, nor to external REXX functions. To enable it, you need to put |
184 | your code inside C<REXX_call> function. REXX functions which do not use |
185 | variables may be usable even without C<REXX_call> though. |
186 | |
187 | =head1 SYNOPSIS |
188 | |
189 | use OS2::REXX; |
190 | $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!"; |
191 | @pid = $ydb->RxProcId(); |
192 | REXX_call { |
193 | tie $s, OS2::REXX, "TEST"; |
194 | $s = 1; |
195 | }; |
196 | |
197 | =head1 DESCRIPTION |
198 | |
199 | =head2 Load REXX DLL |
200 | |
201 | $dll = load OS2::REXX NAME [, WHERE]; |
202 | |
203 | NAME is DLL name, without path and extension. |
204 | |
205 | Directories are searched WHERE first (list of dirs), then environment |
fb73857a |
206 | paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search |
207 | is performed in default DLL path (without adding paths and extensions). |
760ac839 |
208 | |
209 | The DLL is not unloaded when the variable dies. |
210 | |
211 | Returns DLL object reference, or undef on failure. |
212 | |
213 | =head2 Define function prefix: |
214 | |
215 | $dll->prefix(NAME); |
216 | |
217 | Define the prefix of external functions, prepended to the function |
218 | names used within your program, when looking for the entries in the |
219 | DLL. |
220 | |
221 | =head2 Example |
222 | |
223 | $dll = load OS2::REXX "RexxBase"; |
224 | $dll->prefix("RexxBase_"); |
225 | $dll->Init(); |
226 | |
227 | is the same as |
228 | |
229 | $dll = load OS2::REXX "RexxBase"; |
230 | $dll->RexxBase_Init(); |
231 | |
232 | =head2 Define queue: |
233 | |
234 | $dll->queue(NAME); |
235 | |
236 | Define the name of the REXX queue passed to all external |
237 | functions of this module. Defaults to "SESSION". |
238 | |
239 | Check for functions (optional): |
240 | |
241 | BOOL = $dll->find(NAME [, NAME [, ...]]); |
242 | |
243 | Returns true if all functions are available. |
244 | |
245 | =head2 Call external REXX function: |
246 | |
247 | $dll->function(arguments); |
248 | |
249 | Returns the return string if the return code is 0, else undef. |
250 | Dies with error message if the function is not available. |
251 | |
252 | =head1 Accessing REXX-runtime |
253 | |
254 | While calling functions with REXX signature does not require the presence |
255 | of the system REXX DLL, there are some actions which require REXX-runtime |
256 | present. Among them is the access to REXX variables by name. |
257 | |
258 | One enables REXX runtime by bracketing your code by |
259 | |
260 | REXX_call BLOCK; |
261 | |
262 | (trailing semicolon required!) or |
263 | |
264 | REXX_call \&subroutine_name; |
265 | |
5ba48348 |
266 | Inside such a call one has access to REXX variables (see below). |
267 | |
268 | An alternative way to execute code inside a REXX compartment is |
760ac839 |
269 | |
270 | REXX_eval EXPR; |
271 | REXX_eval_with EXPR, |
272 | subroutine_name_in_REXX => \&Perl_subroutine |
273 | |
5ba48348 |
274 | Here C<EXPR> is a REXX code to run; to execute Perl code one needs to put |
275 | it inside Perl_subroutine(), and call this subroutine from REXX, as in |
276 | |
277 | REXX_eval_with <<EOE, foo => sub { 123 * shift }; |
278 | say foo(2) |
279 | EOE |
280 | |
281 | If one needs more Perl subroutines available, one can "import" them into |
282 | REXX from inside Perl_subroutine(); since REXX is not case-sensitive, |
283 | the names should be uppercased. |
284 | |
285 | use OS2::REXX 'register'; |
286 | |
287 | sub BAR { 123 + shift} |
288 | sub BAZ { 789 } |
289 | sub importer { register qw(BAR BAZ) } |
290 | |
291 | REXX_eval_with <<'EOE', importer => \&importer; |
292 | call importer |
293 | say bar(34) |
294 | say baz() |
295 | EOE |
296 | |
760ac839 |
297 | =head2 Bind scalar variable to REXX variable: |
298 | |
299 | tie $var, OS2::REXX, "NAME"; |
300 | |
301 | =head2 Bind array variable to REXX stem variable: |
302 | |
303 | tie @var, OS2::REXX, "NAME."; |
304 | |
305 | Only scalar operations work so far. No array assignments, no array |
306 | operations, ... FORGET IT. |
307 | |
308 | =head2 Bind hash array variable to REXX stem variable: |
309 | |
310 | tie %var, OS2::REXX, "NAME."; |
311 | |
312 | To access all visible REXX variables via hash array, bind to ""; |
313 | |
314 | No array assignments. No array operations, other than hash array |
315 | operations. Just like the *dbm based implementations. |
316 | |
317 | For the usual REXX stem variables, append a "." to the name, |
318 | as shown above. If the hash key is part of the stem name, for |
319 | example if you bind to "", you cannot use lower case in the stem |
320 | part of the key and it is subject to character set restrictions. |
321 | |
322 | =head2 Erase individual REXX variables (bound or not): |
323 | |
324 | OS2::REXX::drop("NAME" [, "NAME" [, ...]]); |
325 | |
326 | =head2 Erase REXX variables with given stem (bound or not): |
327 | |
328 | OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); |
329 | |
5ba48348 |
330 | =head2 Make Perl functions available in REXX: |
331 | |
332 | OS2::REXX::register("NAME" [, "NAME" [, ...]]); |
333 | |
334 | Since REXX is not case-sensitive, the names should be uppercase. |
335 | |
9e2a34c1 |
336 | =head1 Subcommand handlers |
337 | |
338 | By default, the executed REXX code runs without any default subcommand |
339 | handler present. A subcommand handler named C<PERLEVAL> is defined, but |
340 | not made a default. Use C<ADDRESS PERLEVAL> REXX command to make it a default |
341 | handler; alternatively, use C<ADDRESS Handler WhatToDo> to direct a command |
342 | to the handler you like. |
343 | |
344 | Experiments show that the handler C<CMD> is also available; probably it is |
345 | provided by the REXX runtime. |
346 | |
347 | =head1 Interfacing from REXX to Perl |
348 | |
349 | This module provides an interface from Perl to REXX, and from REXX-inside-Perl |
350 | back to Perl. There is an alternative scenario which allows usage of Perl |
351 | from inside REXX. |
352 | |
353 | A DLL F<PerlRexx> provides an API to Perl as REXX functions |
354 | |
355 | PERL |
356 | PERLTERM |
357 | PERLINIT |
358 | PERLEXIT |
359 | PERLEVAL |
360 | PERLLASTERROR |
361 | PERLEXPORTALL |
362 | PERLDROPALL |
363 | PERLDROPALLEXIT |
364 | |
365 | A subcommand handler C<PERLEVALSUBCOMMAND> can also be registered. Calling |
366 | the function PERLEXPORTALL() exports all these functions, as well as |
367 | exports this subcommand handler under the name C<EVALPERL>. PERLDROPALL() |
368 | inverts this action (and unloads PERLEXPORTALL() as well). In particular |
369 | |
370 | rc = RxFuncAdd("PerlExportAll", 'PerlRexx', "PERLEXPORTALL") |
371 | rc = PerlExportAll() |
372 | res = PERLEVAL(perlarg) |
373 | ADDRESS EVALPERL perlarg1 |
374 | rc = PerlDropAllExit() |
375 | |
376 | loads all the functions above, evals the Perl code in the REXX variable |
377 | C<perlarg>, putting the result into the REXX variable C<res>, |
378 | then evals the Perl code in the REXX variable C<perlarg1>, and, finally, |
379 | drops the loaded functions and the subcommand handler, deinitializes |
380 | the Perl interpreter, and exits the Perl's C runtime library. |
381 | |
382 | PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of |
383 | the REXX program. (This is considered as a bug.) Their purpose is to flush |
384 | all the output buffers of the Perl's C runtime library. |
385 | |
386 | C<PERLLASTERROR> gives the reason for the failure of the last PERLEVAL(). |
387 | It is useful inside C<signal on syntax> handler. PERLINIT() and PERLTERM() |
388 | initialize and deinitialize the Perl interpreter. |
389 | |
390 | C<PERLEVAL(string)> initializes the Perl interpreter (if needed), and |
391 | evaluates C<string> as Perl code. The result is returned to REXX stringified, |
392 | undefined result is considered as failure. |
393 | |
394 | C<PERL(string)> does the same as C<PERLEVAL(string)> wrapped by calls to |
395 | PERLINIT() and PERLEXIT(). |
396 | |
760ac839 |
397 | =head1 NOTES |
398 | |
399 | Note that while function and variable names are case insensitive in the |
400 | REXX language, function names exported by a DLL and the REXX variables |
401 | (as seen by Perl through the chosen API) are all case sensitive! |
402 | |
403 | Most REXX DLLs export function names all upper case, but there are a |
404 | few which export mixed case names (such as RxExtras). When trying to |
405 | find the entry point, both exact case and all upper case are searched. |
406 | If the DLL exports "RxNap", you have to specify the exact case, if it |
407 | exports "RXOPEN", you can use any case. |
408 | |
409 | To avoid interfering with subroutine names defined by Perl (DESTROY) |
410 | or used within the REXX module (prefix, find), it is best to use mixed |
411 | case and to avoid lowercase only or uppercase only names when calling |
412 | REXX functions. Be consistent. The same function written in different |
413 | ways results in different Perl stubs. |
414 | |
415 | There is no REXX interpolation on variable names, so the REXX variable |
416 | name TEST.ONE is not affected by some other REXX variable ONE. And it |
417 | is not the same variable as TEST.one! |
418 | |
419 | You cannot call REXX functions which are not exported by the DLL. |
420 | While most DLLs export all their functions, some, like RxFTP, export |
421 | only "...LoadFuncs", which registers the functions within REXX only. |
422 | |
423 | You cannot call 16-bit DLLs. The few interesting ones I found |
424 | (FTP,NETB,APPC) do not export their functions. |
425 | |
426 | I do not know whether the REXX API is reentrant with respect to |
427 | exceptions (signals) when the REXX top-level exception handler is |
428 | overridden. So unless you know better than I do, do not access REXX |
429 | variables (probably tied to Perl variables) or call REXX functions |
430 | which access REXX queues or REXX variables in signal handlers. |
431 | |
5ba48348 |
432 | See C<t/rx*.t> and the next section for examples. |
433 | |
434 | =head1 EXAMPLE |
435 | |
436 | use OS2::REXX; |
437 | |
438 | sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" } |
439 | |
440 | $vrexx = OS2::REXX->load('VREXX'); |
441 | REXX_call { # VOpenWindow takes a stem |
442 | local $SIG{TERM} = sub {die}; # enable Ender::DESTROY |
443 | local $SIG{INT} = sub {die}; # enable Ender::DESTROY |
444 | |
445 | $code = $vrexx->VInit; |
446 | print "Init code = `$code'\n"; |
447 | die "error initializing VREXX" if $code eq 'ERROR'; |
448 | |
449 | my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit |
450 | |
451 | print "VREXX Version ", $vrexx->VGetVersion, "\n"; |
452 | |
453 | tie %pos, 'OS2::REXX', 'POS.' or die; |
454 | %pos = ( LEFT => 0, RIGHT => 7, TOP => 5, BOTTOM => 0 ); |
455 | |
456 | $id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS'); |
457 | $vrexx->VForeColor($id, 'BLACK'); |
458 | $vrexx->VSetFont($id, 'TIME', '30'); |
459 | $tlim = time + 60; |
460 | while ( ($r = $tlim - time) >= 0 ) { |
461 | $vrexx->VClearWindow($id); |
462 | $vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60)); |
463 | sleep 1; |
464 | } |
465 | print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id); |
466 | }; |
467 | |
468 | |
760ac839 |
469 | |
66e933ab |
470 | =head1 ENVIRONMENT |
471 | |
472 | If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime |
473 | environment. |
474 | |
760ac839 |
475 | =head1 AUTHOR |
476 | |
477 | Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich |
478 | ilya@math.ohio-state.edu. |
479 | |
ed344e4f |
480 | =head1 SEE ALSO |
481 | |
482 | L<OS2::DLL>. |
483 | |
760ac839 |
484 | =cut |