os2/OS2/REXX/REXX.pm

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