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