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