os2/OS2/REXX/REXX.pm

   1 package OS2::REXX;
   2
   3 use Carp;
   4 require Exporter;
   5 require DynaLoader;
   6 require OS2::DLL;
   7
   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 register);
  14
  15 $VERSION = '1.01';
  16
  17 # We cannot just put OS2::DLL in @ISA, since some scripts would use
  18 # function interface, not method interface...
  19
  20 *_call = \&OS2::DLL::_call;
  21 *load = \&OS2::DLL::load;
  22 *find = \&OS2::DLL::find;
  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
  29 sub register {_register($_) for @_}
  30
  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) = @_;
  69         $name =~ s/^([\w!?]+)/\U$1\E/;
  70         return bless \$name, OS2::REXX::_SCALAR;
  71 }
  72
  73 sub TIEARRAY
  74 {
  75         my ($obj, $name) = @_;
  76         $name =~ s/^([\w!?]+)/\U$1\E/;
  77         return bless [$name, 0], OS2::REXX::_ARRAY;
  78 }
  79
  80 sub TIEHASH
  81 {
  82         my ($obj, $name) = @_;
  83         $name =~ s/^([\w!?]+)/\U$1\E/;
  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
 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).
 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
 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
 269
 270         REXX_eval EXPR;
 271         REXX_eval_with EXPR,
 272                 subroutine_name_in_REXX => \&Perl_subroutine
 273
 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
 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
 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
 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
 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
 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
 469
 470 =head1 ENVIRONMENT
 471
 472 If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime
 473 environment.
 474
 475 =head1 AUTHOR
 476
 477 Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
 478 ilya@math.ohio-state.edu.
 479
 480 =head1 SEE ALSO
 481
 482 L<OS2::DLL>.
 483
 484 =cut