os2/OS2/REXX/DLL/DLL.pm

   1 package OS2::DLL;
   2
   3 our $VERSION = '1.00';
   4
   5 use Carp;
   6 use DynaLoader;
   7
   8 @ISA = qw(DynaLoader);
   9
  10 sub AUTOLOAD {
  11     $AUTOLOAD =~ /^OS2::DLL::.+::(.+)$/
  12       or confess("Undefined subroutine &$AUTOLOAD called");
  13     return undef if $1 eq "DESTROY";
  14     $_[0]->find($1)
  15       or confess("Can't find entry '$1' to DLL '$_[0]->{File}': $^E");
  16     goto &$AUTOLOAD;
  17 }
  18
  19 @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
  20 %dlls = ();
  21
  22 # Preloaded methods go here.  Autoload methods go after __END__, and are
  23 # processed by the autosplit program.
  24
  25 # Cannot autoload, the autoloader is used for the REXX functions.
  26
  27 sub new {
  28   confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
  29   my ($class, $file) = (shift, shift);
  30   my $handle;
  31   $handle = $class->load($file, @_) and return $handle;
  32   my $path = @_ ? " from '@_'" : '';
  33   my $err = DynaLoader::dl_error();
  34   $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
  35   croak "Can't load '$file'$path: $err";
  36 }
  37
  38 sub load
  39 {
  40         confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
  41         my ($class, $file, @where) = (@_, @libs);
  42         return $dlls{$file} if $dlls{$file};
  43         my $handle;
  44         foreach (@where) {
  45                 $handle = DynaLoader::dl_load_file("$_/$file.dll");
  46                 last if $handle;
  47         }
  48         $handle = DynaLoader::dl_load_file($file) unless $handle;
  49         return undef unless $handle;
  50         my $packs = $INC{'OS2/REXX.pm'} ? 'OS2::DLL OS2::REXX' : 'OS2::DLL';
  51         eval <<EOE or die "eval package $@";
  52 package OS2::DLL::$file; \@ISA = qw($packs);
  53 sub AUTOLOAD {
  54   \$OS2::DLL::AUTOLOAD = \$AUTOLOAD;
  55   goto &OS2::DLL::AUTOLOAD;
  56 }
  57 1;
  58 EOE
  59         return $dlls{$file} =
  60           bless {Handle => $handle, File => $file, Queue => 'SESSION' },
  61                 "OS2::DLL::$file";
  62 }
  63
  64 sub find
  65 {
  66         my $self   = shift;
  67         my $file   = $self->{File};
  68         my $handle = $self->{Handle};
  69         my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
  70         my $queue  = $self->{Queue};
  71         foreach (@_) {
  72                 my $name = "OS2::DLL::${file}::$_";
  73                 next if defined(&$name);
  74                 my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
  75                         || DynaLoader::dl_find_symbol($handle, $prefix.$_)
  76                         or return 0;
  77                 eval <<EOE or die "eval sub";
  78 package OS2::DLL::$file;
  79 sub $_ {
  80   shift;
  81   OS2::DLL::_call('$_', $addr, '$queue', \@_);
  82 }
  83 1;
  84 EOE
  85         }
  86         return 1;
  87 }
  88
  89 bootstrap OS2::DLL;
  90
  91 1;
  92 __END__
  93
  94 =head1 NAME
  95
  96 OS2::DLL - access to DLLs with REXX calling convention.
  97
  98 =head2 NOTE
  99
 100 When you use this module, the REXX variable pool is not available.
 101
 102 See documentation of L<OS2::REXX> module if you need the variable pool.
 103
 104 =head1 SYNOPSIS
 105
 106         use OS2::DLL;
 107         $emx_dll = OS2::DLL->load('emx');
 108         $emx_version = $emx_dll->emx_revision();
 109
 110 =head1 DESCRIPTION
 111
 112 =head2 Load REXX DLL
 113
 114         $dll = load OS2::DLL NAME [, WHERE];
 115
 116 NAME is DLL name, without path and extension.
 117
 118 Directories are searched WHERE first (list of dirs), then environment
 119 paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search
 120 is performed in default DLL path (without adding paths and extensions).
 121
 122 The DLL is not unloaded when the variable dies.
 123
 124 Returns DLL object reference, or undef on failure (in this case one can
 125 get the reason via C<DynaLoader::dl_error()>).
 126
 127 =head2 Create a REXX DLL handle
 128
 129         $dll = OS2::DLL->new( NAME [, WHERE] );
 130
 131 Same as L<C<load>|Load REXX DLL>, but croaks with a meaningful message on
 132 failure.
 133
 134 =head2 Check for functions (optional):
 135
 136         BOOL = $dll->find(NAME [, NAME [, ...]]);
 137
 138 Returns true if all functions are available.
 139
 140 =head2 Call external REXX function:
 141
 142         $dll->function(arguments);
 143
 144 Returns the return string if the return code is 0, else undef.
 145 Dies with error message if the function is not available.
 146
 147 =head1 ENVIRONMENT
 148
 149 If C<PERL_REXX_DEBUG> is set, emits debugging output.  Looks for DLLs
 150 in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
 151
 152 =head1 AUTHOR
 153
 154 Extracted by Ilya Zakharevich ilya@math.ohio-state.edu from L<OS2::REXX>
 155 written by Andreas Kaiser ak@ananke.s.bawue.de.
 156
 157 =cut