os2/OS2/REXX/DLL/DLL.pm

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