home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl502b.zip / ext / OS2 / REXX / REXX.pm next >
Text File  |  1995-05-13  |  4KB  |  201 lines
  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 = ();
  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. {
  86.     goto &OS2::REXX::_drop;
  87. }
  88.  
  89. sub TIESCALAR
  90. {
  91.     my ($obj, $name) = @_;
  92.     $name =~ s/^[\w!?]+/\U$&\E/;
  93.     return bless \$name, OS2::REXX::_SCALAR;
  94. }    
  95.  
  96. sub TIEARRAY
  97. {
  98.     my ($obj, $name) = @_;
  99.     $name =~ s/^[\w!?]+/\U$&\E/;
  100.     return bless [$name, 0], OS2::REXX::_ARRAY;
  101. }
  102.  
  103. sub TIEHASH
  104. {
  105.     my ($obj, $name) = @_;
  106.     $name =~ s/^[\w!?]+/\U$&\E/;
  107.     return bless {Stem => $name}, OS2::REXX::_HASH;
  108. }
  109.  
  110. #############################################################################
  111. package OS2::REXX::_SCALAR;
  112.  
  113. sub FETCH
  114. {
  115.     return OS2::REXX::_fetch(${$_[0]});
  116. }
  117.  
  118. sub STORE
  119. {
  120.     return OS2::REXX::_set(${$_[0]}, $_[1]);
  121. }
  122.  
  123. sub DESTROY
  124. {
  125.     return OS2::REXX::_drop(${$_[0]});
  126. }
  127.  
  128. #############################################################################
  129. package OS2::REXX::_ARRAY;
  130.  
  131. sub FETCH
  132. {
  133.     $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
  134.     return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1]));
  135. }
  136.  
  137. sub STORE
  138. {
  139.     $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
  140.     return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]);
  141. }
  142.  
  143. #############################################################################
  144. package OS2::REXX::_HASH;
  145.  
  146. require TieHash;
  147. @ISA = TieHash;
  148.  
  149. sub FIRSTKEY
  150. {
  151.     my ($self) = @_;
  152.     my $stem = $self->{Stem};
  153.  
  154.     delete $self->{List} if exists $self->{List};
  155.  
  156.     my @list = ();
  157.     my ($name, $value);
  158.     OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
  159.     while (($name) = OS2::REXX::_next($stem)) {
  160.         push @list, $name;
  161.     }
  162.     my $key = pop @list;
  163.  
  164.     $self->{List} = \@list;
  165.     return $key;
  166. }
  167.  
  168. sub NEXTKEY
  169. {
  170.     return pop @{$_[0]->{List}};
  171. }
  172.  
  173. sub EXISTS
  174. {
  175.     return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
  176. }
  177.  
  178. sub FETCH
  179. {
  180.     return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
  181. }
  182.  
  183. sub STORE
  184. {
  185.     return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]);
  186. }
  187.  
  188. sub DELETE
  189. {
  190.     OS2::REXX::_drop($_[0]->{Stem}.$_[1]);
  191. }
  192.  
  193. #############################################################################
  194. package OS2::REXX;
  195.  
  196. 1;
  197. __END__
  198.  
  199.  
  200.  
  201.