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 @libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
   9 %dlls = ();
  10
  11 # Preloaded methods go here.  Autoload methods go after __END__, and are
  12 # processed by the autosplit program.
  13
  14 # Cannot be autoload, the autoloader is used for the REXX functions.
  15
  16 my $load_with_dirs = sub {
  17         my ($class, $file, @where) = (@_);
  18         return $dlls{$file} if $dlls{$file};
  19         my $handle;
  20         foreach (@where) {
  21                 $handle = DynaLoader::dl_load_file("$_/$file.dll");
  22                 last if $handle;
  23         }
  24         $handle = DynaLoader::dl_load_file($file) unless $handle;
  25         return undef unless $handle;
  26         my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll';
  27         my $p = "OS2::DLL::dll::$file";
  28         @{"$p\::ISA"} = @packs;
  29         *{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD;
  30         return $dlls{$file} =
  31           bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p;
  32 };
  33
  34 my $new_dll = sub {
  35   my ($dirs, $class, $file) = (shift, shift, shift);
  36   my $handle;
  37   push @_, @libs if $dirs;
  38   $handle = $load_with_dirs->($class, $file, @_)
  39     and return $handle;
  40   my $path = @_ ? " from '@_'" : '';
  41   my $err = DynaLoader::dl_error();
  42   $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
  43   croak "Can't load '$file'$path: $err";
  44 };
  45
  46 sub new {
  47   confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
  48   $new_dll->(1, @_);
  49 }
  50
  51 sub module {
  52   confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2;
  53   $new_dll->(0, @_);
  54 }
  55
  56 sub load {
  57   confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
  58   $load_with_dirs->(@_, @libs);
  59 }
  60
  61 package OS2::DLL::dll;
  62 use Carp;
  63 @ISA = 'OS2::DLL';
  64
  65 sub AUTOLOAD {
  66     $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/
  67       or confess("Undefined subroutine &$AUTOLOAD called");
  68     return undef if $1 eq "DESTROY";
  69     die "AUTOLOAD loop" if $1 eq "AUTOLOAD";
  70     $_[0]->find($1) or confess($@);
  71     goto &$AUTOLOAD;
  72 }
  73
  74 sub wrapper_REXX {
  75         confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2;
  76         my $self   = shift;
  77         my $file   = $self->{File};
  78         my $handle = $self->{Handle};
  79         my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
  80         my $queue  = $self->{Queue};
  81         my $name = shift;
  82         $prefix = '' if $name =~ /^#\d+/;       # loading by ordinal
  83         my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
  84                     || DynaLoader::dl_find_symbol($handle, $prefix.$name));
  85         return sub {
  86           OS2::DLL::_call($name, $addr, $queue, @_);
  87         } if $addr;
  88         my $err = DynaLoader::dl_error();
  89         $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
  90         croak "Can't find symbol `$name' in DLL `$file': $err";
  91 }
  92
  93 sub find
  94 {
  95         my $self   = shift;
  96         my $file   = $self->{File};
  97         my $p      = ref $self;
  98         foreach (@_) {
  99                 my $f = eval {$self->wrapper_REXX($_)} or return 0;
 100                 ${"${p}::"}{$_} = sub { shift; $f->(@_) };
 101         }
 102         return 1;
 103 }
 104
 105 XSLoader::load 'OS2::DLL';
 106
 107 1;
 108 __END__
 109
 110 =head1 NAME
 111
 112 OS2::DLL - access to DLLs with REXX calling convention.
 113
 114 =head2 NOTE
 115
 116 When you use this module, the REXX variable pool is not available.
 117
 118 See documentation of L<OS2::REXX> module if you need the variable pool.
 119
 120 =head1 SYNOPSIS
 121
 122         use OS2::DLL;
 123         $emx_dll = OS2::DLL->module('emx');
 124         $emx_version = $emx_dll->emx_revision();
 125         $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
 126         $emx_version = $func_emx_version->();
 127
 128 =head1 DESCRIPTION
 129
 130 =head2 Create a DLL handle
 131
 132         $dll = OS2::DLL->module( NAME [, WHERE] );
 133
 134 Loads an OS/2 module NAME, looking in directories WHERE (adding the
 135 extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way
 136 (via LIBPATH and other settings).  Croaks with a verbose report on failure.
 137
 138 The DLL is not unloaded when the return value is destroyed.
 139
 140 =head2 Create a DLL handle (looking in some strange locations)
 141
 142         $dll = OS2::DLL->new( NAME [, WHERE] );
 143
 144 Same as L<C<module>|Create a DLL handle>, but in addition to WHERE, looks
 145 in environment paths PERL5REXX, PERLREXX, PATH (provided for backward
 146 compatibility).
 147
 148 =head2 Loads DLL by name
 149
 150         $dll = load OS2::DLL NAME [, WHERE];
 151
 152 Same as L<C<new>|Create a DLL handle (looking in some strange locations)>,
 153 but returns DLL object reference, or undef on failure (in this case one can
 154 get the reason via C<DynaLoader::dl_error()>) (provided for backward
 155 compatibility).
 156
 157 =head2 Check for functions (optional):
 158
 159         BOOL = $dll->find(NAME [, NAME [, ...]]);
 160
 161 Returns true if all functions are available.  As a side effect, creates
 162 a REXX wrapper with the specified name in the package constructed by the name
 163 of the DLL so that the next call to C<$dll->NAME()> will pick up the cached
 164 method.
 165
 166 =head2 Create a Perl wrapper (optional):
 167
 168         $func = $dll->wrapper_REXX(NAME);
 169
 170 Returns a reference to a Perl function wrapper for the entry point NAME
 171 in the DLL.  Similar to the OS/2 API, the NAME may be C<"#123"> - in this case
 172 the ordinal is loaded.   Croaks with a meaningful error message if NAME does
 173 not exists (although the message for the case when the name is an ordinal may
 174 be confusing).
 175
 176 =head2 Call external function with REXX calling convention:
 177
 178         $ret_string = $dll->function_name(arguments);
 179
 180 Returns the return string if the REXX return code is 0, else undef.
 181 Dies with error message if the function is not available.  On the first call
 182 resolves the name in the DLL and caches the Perl wrapper; future calls go
 183 through the wrapper.
 184
 185 Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime
 186 environment (variable pool, queue etc.) is not available to the called
 187 function.
 188
 189 =head1 Low-level API
 190
 191 =over
 192
 193 =item Call a _System linkage function via a pointer
 194
 195 If a function takes up to 20 ULONGs and returns ULONG:
 196
 197  $res = call20( $pointer, $arg0, $arg1, ...);
 198
 199 =item Same for packed arguments:
 200
 201  $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...);
 202
 203 =item Same for C<regparm(3)> function:
 204
 205  $res = call20_rp3( $pointer, $arg0, $arg1, ...);
 206
 207 =item Same for packed arguments and C<regparm(3)> function
 208
 209  $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...);
 210
 211 =item Same for a function which returns non-0 and sets system-error on error
 212
 213  call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error
 214
 215 [Good for C<Dos*> API - and rare C<Win*> calls.]
 216
 217 =item Same for a function which returns 0 and sets WinLastError() on error
 218
 219  $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...);
 220  # would die("$msg: $^E") if error
 221
 222 [Good for most of C<Win*> API.]
 223
 224 =item Same for a function which returns 0 and sets WinLastError() on error but
 225 0 is also a valid return
 226
 227  $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...);
 228  # would die("$msg: $^E") if error
 229
 230 [Good for some of C<Win*> API.]
 231
 232 =item As previous, but without die()
 233
 234  $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
 235  if ($res == 0 and $^E) {       # Do error processing here
 236  }
 237
 238 [Good for some of C<Win*> API.]
 239
 240 =back
 241
 242 =head1 ENVIRONMENT
 243
 244 If C<PERL_REXX_DEBUG> is set, emits debugging output.  Looks for DLLs
 245 in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
 246
 247 =head1 AUTHOR
 248
 249 Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
 250 written by Andreas Kaiser ak@ananke.s.bawue.de.
 251
 252 =cut