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