os2/OS2/REXX/REXX.pm

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