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.00';
  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 NOTES
 337
 338 Note that while function and variable names are case insensitive in the
 339 REXX language, function names exported by a DLL and the REXX variables
 340 (as seen by Perl through the chosen API) are all case sensitive!
 341
 342 Most REXX DLLs export function names all upper case, but there are a
 343 few which export mixed case names (such as RxExtras). When trying to
 344 find the entry point, both exact case and all upper case are searched.
 345 If the DLL exports "RxNap", you have to specify the exact case, if it
 346 exports "RXOPEN", you can use any case.
 347
 348 To avoid interfering with subroutine names defined by Perl (DESTROY)
 349 or used within the REXX module (prefix, find), it is best to use mixed
 350 case and to avoid lowercase only or uppercase only names when calling
 351 REXX functions. Be consistent. The same function written in different
 352 ways results in different Perl stubs.
 353
 354 There is no REXX interpolation on variable names, so the REXX variable
 355 name TEST.ONE is not affected by some other REXX variable ONE. And it
 356 is not the same variable as TEST.one!
 357
 358 You cannot call REXX functions which are not exported by the DLL.
 359 While most DLLs export all their functions, some, like RxFTP, export
 360 only "...LoadFuncs", which registers the functions within REXX only.
 361
 362 You cannot call 16-bit DLLs. The few interesting ones I found
 363 (FTP,NETB,APPC) do not export their functions.
 364
 365 I do not know whether the REXX API is reentrant with respect to
 366 exceptions (signals) when the REXX top-level exception handler is
 367 overridden. So unless you know better than I do, do not access REXX
 368 variables (probably tied to Perl variables) or call REXX functions
 369 which access REXX queues or REXX variables in signal handlers.
 370
 371 See C<t/rx*.t> and the next section for examples.
 372
 373 =head1 EXAMPLE
 374
 375   use OS2::REXX;
 376
 377   sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" }
 378
 379   $vrexx = OS2::REXX->load('VREXX');
 380   REXX_call {                   # VOpenWindow takes a stem
 381     local $SIG{TERM} = sub {die}; # enable Ender::DESTROY
 382     local $SIG{INT} = sub {die};        # enable Ender::DESTROY
 383
 384     $code = $vrexx->VInit;
 385     print "Init code = `$code'\n";
 386     die "error initializing VREXX" if $code eq 'ERROR';
 387
 388     my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit
 389
 390     print "VREXX Version ", $vrexx->VGetVersion, "\n";
 391
 392     tie %pos, 'OS2::REXX', 'POS.' or die;
 393     %pos = ( LEFT   => 0, RIGHT  => 7, TOP    => 5, BOTTOM => 0 );
 394
 395     $id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS');
 396     $vrexx->VForeColor($id, 'BLACK');
 397     $vrexx->VSetFont($id, 'TIME', '30');
 398     $tlim = time + 60;
 399     while ( ($r = $tlim - time) >= 0 ) {
 400       $vrexx->VClearWindow($id);
 401       $vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60));
 402       sleep 1;
 403     }
 404     print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id);
 405   };
 406
 407
 408
 409 =head1 ENVIRONMENT
 410
 411 If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime
 412 environment.
 413
 414 =head1 AUTHOR
 415
 416 Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
 417 ilya@math.ohio-state.edu.
 418
 419 =head1 SEE ALSO
 420
 421 L<OS2::DLL>.
 422
 423 =cut