1package OS2::REXX; 2 3require Exporter; 4use XSLoader; 5require 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.05'; 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 23XSLoader::load 'OS2::REXX'; 24 25# Preloaded methods go here. Autoload methods go after __END__, and are 26# processed by the autosplit program. 27 28sub register {_register($_) for @_} 29 30sub prefix 31{ 32 my $self = shift; 33 $self->{Prefix} = shift; 34} 35 36sub queue 37{ 38 my $self = shift; 39 $self->{Queue} = shift; 40} 41 42sub 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 49sub 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 65sub TIESCALAR 66{ 67 my ($obj, $name) = @_; 68 $name =~ s/^([\w!?]+)/\U$1\E/; 69 return bless \$name, OS2::REXX::_SCALAR; 70} 71 72sub TIEARRAY 73{ 74 my ($obj, $name) = @_; 75 $name =~ s/^([\w!?]+)/\U$1\E/; 76 return bless [$name, 0], OS2::REXX::_ARRAY; 77} 78 79sub TIEHASH 80{ 81 my ($obj, $name) = @_; 82 $name =~ s/^([\w!?]+)/\U$1\E/; 83 return bless {Stem => $name}, OS2::REXX::_HASH; 84} 85 86############################################################################# 87package OS2::REXX::_SCALAR; 88 89sub FETCH 90{ 91 return OS2::REXX::_fetch(${$_[0]}); 92} 93 94sub STORE 95{ 96 return OS2::REXX::_set(${$_[0]}, $_[1]); 97} 98 99sub DESTROY 100{ 101 return OS2::REXX::_drop(${$_[0]}); 102} 103 104############################################################################# 105package OS2::REXX::_ARRAY; 106 107sub FETCH 108{ 109 $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; 110 return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); 111} 112 113sub STORE 114{ 115 $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; 116 return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); 117} 118 119############################################################################# 120package OS2::REXX::_HASH; 121 122require Tie::Hash; 123@ISA = ('Tie::Hash'); 124 125sub 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 144sub NEXTKEY 145{ 146 return pop @{$_[0]->{List}}; 147} 148 149sub EXISTS 150{ 151 return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); 152} 153 154sub FETCH 155{ 156 return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); 157} 158 159sub STORE 160{ 161 return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); 162} 163 164sub DELETE 165{ 166 OS2::REXX::_drop($_[0]->{Stem}.$_[1]); 167} 168 169############################################################################# 170package OS2::REXX; 171 1721; 173__END__ 174 175=head1 NAME 176 177OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. 178 179=head2 NOTE 180 181By default, the REXX variable pool is not available, neither 182to Perl, nor to external REXX functions. To enable it, you need to put 183your code inside C<REXX_call> function. REXX functions which do not use 184variables 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 202NAME is DLL name, without path and extension. 203 204Directories are searched WHERE first (list of dirs), then environment 205paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search 206is performed in default DLL path (without adding paths and extensions). 207 208The DLL is not unloaded when the variable dies. 209 210Returns DLL object reference, or undef on failure. 211 212=head2 Define function prefix: 213 214 $dll->prefix(NAME); 215 216Define the prefix of external functions, prepended to the function 217names used within your program, when looking for the entries in the 218DLL. 219 220=head2 Example 221 222 $dll = load OS2::REXX "RexxBase"; 223 $dll->prefix("RexxBase_"); 224 $dll->Init(); 225 226is 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 235Define the name of the REXX queue passed to all external 236functions of this module. Defaults to "SESSION". 237 238Check for functions (optional): 239 240 BOOL = $dll->find(NAME [, NAME [, ...]]); 241 242Returns true if all functions are available. 243 244=head2 Call external REXX function: 245 246 $dll->function(arguments); 247 248Returns the return string if the return code is 0, else undef. 249Dies with error message if the function is not available. 250 251=head1 Accessing REXX-runtime 252 253While calling functions with REXX signature does not require the presence 254of the system REXX DLL, there are some actions which require REXX-runtime 255present. Among them is the access to REXX variables by name. 256 257One 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 265Inside such a call one has access to REXX variables (see below). 266 267An 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 273Here C<EXPR> is a REXX code to run; to execute Perl code one needs to put 274it 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 280If one needs more Perl subroutines available, one can "import" them into 281REXX from inside Perl_subroutine(); since REXX is not case-sensitive, 282the 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 304Only scalar operations work so far. No array assignments, no array 305operations, ... FORGET IT. 306 307=head2 Bind hash array variable to REXX stem variable: 308 309 tie %var, OS2::REXX, "NAME."; 310 311To access all visible REXX variables via hash array, bind to ""; 312 313No array assignments. No array operations, other than hash array 314operations. Just like the *dbm based implementations. 315 316For the usual REXX stem variables, append a "." to the name, 317as shown above. If the hash key is part of the stem name, for 318example if you bind to "", you cannot use lower case in the stem 319part 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 333Since REXX is not case-sensitive, the names should be uppercase. 334 335=head1 Subcommand handlers 336 337By default, the executed REXX code runs without any default subcommand 338handler present. A subcommand handler named C<PERLEVAL> is defined, but 339not made a default. Use C<ADDRESS PERLEVAL> REXX command to make it a default 340handler; alternatively, use C<ADDRESS Handler WhatToDo> to direct a command 341to the handler you like. 342 343Experiments show that the handler C<CMD> is also available; probably it is 344provided by the REXX runtime. 345 346=head1 Interfacing from REXX to Perl 347 348This module provides an interface from Perl to REXX, and from REXX-inside-Perl 349back to Perl. There is an alternative scenario which allows usage of Perl 350from inside REXX. 351 352A 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 364A subcommand handler C<PERLEVALSUBCOMMAND> can also be registered. Calling 365the function PERLEXPORTALL() exports all these functions, as well as 366exports this subcommand handler under the name C<EVALPERL>. PERLDROPALL() 367inverts 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 375loads all the functions above, evals the Perl code in the REXX variable 376C<perlarg>, putting the result into the REXX variable C<res>, 377then evals the Perl code in the REXX variable C<perlarg1>, and, finally, 378drops the loaded functions and the subcommand handler, deinitializes 379the Perl interpreter, and exits the Perl's C runtime library. 380 381PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of 382the REXX program. (This is considered as a bug.) Their purpose is to flush 383all the output buffers of the Perl's C runtime library. 384 385C<PERLLASTERROR> gives the reason for the failure of the last PERLEVAL(). 386It is useful inside C<signal on syntax> handler. PERLINIT() and PERLTERM() 387initialize and deinitialize the Perl interpreter. 388 389C<PERLEVAL(string)> initializes the Perl interpreter (if needed), and 390evaluates C<string> as Perl code. The result is returned to REXX stringified, 391undefined result is considered as failure. 392 393C<PERL(string)> does the same as C<PERLEVAL(string)> wrapped by calls to 394PERLINIT() and PERLEXIT(). 395 396=head1 NOTES 397 398Note that while function and variable names are case insensitive in the 399REXX 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 402Most REXX DLLs export function names all upper case, but there are a 403few which export mixed case names (such as RxExtras). When trying to 404find the entry point, both exact case and all upper case are searched. 405If the DLL exports "RxNap", you have to specify the exact case, if it 406exports "RXOPEN", you can use any case. 407 408To avoid interfering with subroutine names defined by Perl (DESTROY) 409or used within the REXX module (prefix, find), it is best to use mixed 410case and to avoid lowercase only or uppercase only names when calling 411REXX functions. Be consistent. The same function written in different 412ways results in different Perl stubs. 413 414There is no REXX interpolation on variable names, so the REXX variable 415name TEST.ONE is not affected by some other REXX variable ONE. And it 416is not the same variable as TEST.one! 417 418You cannot call REXX functions which are not exported by the DLL. 419While most DLLs export all their functions, some, like RxFTP, export 420only "...LoadFuncs", which registers the functions within REXX only. 421 422You cannot call 16-bit DLLs. The few interesting ones I found 423(FTP,NETB,APPC) do not export their functions. 424 425I do not know whether the REXX API is reentrant with respect to 426exceptions (signals) when the REXX top-level exception handler is 427overridden. So unless you know better than I do, do not access REXX 428variables (probably tied to Perl variables) or call REXX functions 429which access REXX queues or REXX variables in signal handlers. 430 431See 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), 462 $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 472If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime 473environment. 474 475=head1 AUTHOR 476 477Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich 478ilya@math.ohio-state.edu. 479 480=head1 SEE ALSO 481 482L<OS2::DLL>. 483 484=cut 485