os2/OS2/REXX/DLL/DLL.pm

   1 package OS2::DLL;
   2
   3 our $VERSION = '1.02';
   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 sub libPath_find {
  62   my ($name, $flags, @path) = (shift, shift);
  63   $flags = 0x7 unless defined $flags;
  64   push @path, split /;/, OS2::extLibpath        if $flags & 0x1;        # BEGIN
  65   push @path, split /;/, OS2::libPath           if $flags & 0x2;
  66   push @path, split /;/, OS2::extLibpath(1)     if $flags & 0x4;        # END
  67   s,(?![/\\])$,/, for @path;
  68   s,\\,/,g for @path;
  69   $name .= ".dll" unless $name =~ /\.[^\\\/]*$/;
  70   $_ .= $name for @path;
  71   -f $_ and return $_ for @path;
  72   return;
  73 }
  74
  75 package OS2::DLL::dll;
  76 use Carp;
  77 @ISA = 'OS2::DLL';
  78
  79 sub AUTOLOAD {
  80     $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/
  81       or confess("Undefined subroutine &$AUTOLOAD called");
  82     return undef if $1 eq "DESTROY";
  83     die "AUTOLOAD loop" if $1 eq "AUTOLOAD";
  84     $_[0]->find($1) or confess($@);
  85     goto &$AUTOLOAD;
  86 }
  87
  88 sub wrapper_REXX {
  89         confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2;
  90         my $self   = shift;
  91         my $file   = $self->{File};
  92         my $handle = $self->{Handle};
  93         my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
  94         my $queue  = $self->{Queue};
  95         my $name = shift;
  96         $prefix = '' if $name =~ /^#\d+/;       # loading by ordinal
  97         my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
  98                     || DynaLoader::dl_find_symbol($handle, $prefix.$name));
  99         return sub {
 100           OS2::DLL::_call($name, $addr, $queue, @_);
 101         } if $addr;
 102         my $err = DynaLoader::dl_error();
 103         $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
 104         croak "Can't find symbol `$name' in DLL `$file': $err";
 105 }
 106
 107 sub find
 108 {
 109         my $self   = shift;
 110         my $file   = $self->{File};
 111         my $p      = ref $self;
 112         foreach (@_) {
 113                 my $f = eval {$self->wrapper_REXX($_)} or return 0;
 114                 ${"${p}::"}{$_} = sub { shift; $f->(@_) };
 115         }
 116         return 1;
 117 }
 118
 119 sub handle      { shift->{Handle} }
 120 sub fullname    { OS2::DLLname(0x202, shift->handle) }
 121 #sub modname    { OS2::DLLname(0x201, shift->handle) }
 122
 123 sub has_f32 {
 124    my $handle = shift->handle;
 125    my $name = shift;
 126    DynaLoader::dl_find_symbol($handle, $name);
 127 }
 128
 129 XSLoader::load 'OS2::DLL';
 130
 131 1;
 132 __END__
 133
 134 =head1 NAME
 135
 136 OS2::DLL - access to DLLs with REXX calling convention.
 137
 138 =head2 NOTE
 139
 140 When you use this module, the REXX variable pool is not available.
 141
 142 See documentation of L<OS2::REXX> module if you need the variable pool.
 143
 144 =head1 SYNOPSIS
 145
 146         use OS2::DLL;
 147         $emx_dll = OS2::DLL->module('emx');
 148         $emx_version = $emx_dll->emx_revision();
 149         $func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
 150         $emx_version = $func_emx_version->();
 151
 152 =head1 DESCRIPTION
 153
 154 =head2 Create a DLL handle
 155
 156         $dll = OS2::DLL->module( NAME [, WHERE] );
 157
 158 Loads an OS/2 module NAME, looking in directories WHERE (adding the
 159 extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way
 160 (via LIBPATH and other settings).  Croaks with a verbose report on failure.
 161
 162 The DLL is not unloaded when the return value is destroyed.
 163
 164 =head2 Create a DLL handle (looking in some strange locations)
 165
 166         $dll = OS2::DLL->new( NAME [, WHERE] );
 167
 168 Same as L<C<module>|Create a DLL handle>, but in addition to WHERE, looks
 169 in environment paths PERL5REXX, PERLREXX, PATH (provided for backward
 170 compatibility).
 171
 172 =head2 Loads DLL by name
 173
 174         $dll = load OS2::DLL NAME [, WHERE];
 175
 176 Same as L<C<new>|Create a DLL handle (looking in some strange locations)>,
 177 but returns DLL object reference, or undef on failure (in this case one can
 178 get the reason via C<DynaLoader::dl_error()>) (provided for backward
 179 compatibility).
 180
 181 =head2 Check for functions (optional):
 182
 183         BOOL = $dll->find(NAME [, NAME [, ...]]);
 184
 185 Returns true if all functions are available.  As a side effect, creates
 186 a REXX wrapper with the specified name in the package constructed by the name
 187 of the DLL so that the next call to C<$dll->NAME()> will pick up the cached
 188 method.
 189
 190 =head2 Create a Perl wrapper (optional):
 191
 192         $func = $dll->wrapper_REXX(NAME);
 193
 194 Returns a reference to a Perl function wrapper for the entry point NAME
 195 in the DLL.  Similar to the OS/2 API, the NAME may be C<"#123"> - in this case
 196 the ordinal is loaded.   Croaks with a meaningful error message if NAME does
 197 not exists (although the message for the case when the name is an ordinal may
 198 be confusing).
 199
 200 =head2 Call external function with REXX calling convention:
 201
 202         $ret_string = $dll->function_name(arguments);
 203
 204 Returns the return string if the REXX return code is 0, else undef.
 205 Dies with error message if the function is not available.  On the first call
 206 resolves the name in the DLL and caches the Perl wrapper; future calls go
 207 through the wrapper.
 208
 209 Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime
 210 environment (variable pool, queue etc.) is not available to the called
 211 function.
 212
 213 =head1 Inspecting the module
 214
 215 =over
 216
 217 =item $module->handle
 218
 219 =item $module->fullname
 220
 221 Return the (integer) handle and full path name of a loaded DLL.
 222
 223 TODO: the module name (whatever is specified in the C<LIBRARY> statement
 224 of F<.def> file when linking) via OS2::Proc.
 225
 226 =item $module->has_f32($name)
 227
 228 Returns the address of a 32-bit entry point with name $name, or 0 if none
 229 found.  (Keep in mind that some entry points may be 16-bit, and some may have
 230 capitalized names comparing to callable-from-C counterparts.)  Name of the
 231 form C<#197> will find entry point with ordinal 197.
 232
 233 =item libPath_find($name [, $flags])
 234
 235 Looks for the DLL $name on C<BEGINLIBPATH>, C<LIBPATH>, C<ENDLIBPATH> if
 236 bits 0x1, 0x2, 0x4 of $flags are set correspondingly.  If called with no
 237 arguments, looks on all 3 locations.  Returns the full name of the found
 238 file.  B<DLL is not loaded.>
 239
 240 $name has F<.dll> appended unless it already has an extension.
 241
 242 =back
 243
 244 =head1 Low-level API
 245
 246 =over
 247
 248 =item Call a _System linkage function via a pointer
 249
 250 If a function takes up to 20 ULONGs and returns ULONG:
 251
 252  $res = call20( $pointer, $arg0, $arg1, ...);
 253
 254 =item Same for packed arguments:
 255
 256  $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...);
 257
 258 =item Same for C<regparm(3)> function:
 259
 260  $res = call20_rp3( $pointer, $arg0, $arg1, ...);
 261
 262 =item Same for packed arguments and C<regparm(3)> function
 263
 264  $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...);
 265
 266 =item Same for a function which returns non-0 and sets system-error on error
 267
 268  call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error
 269
 270 [Good for C<Dos*> API - and rare C<Win*> calls.]
 271
 272 =item Same for a function which returns 0 and sets WinLastError() on error
 273
 274  $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...);
 275  # would die("$msg: $^E") if error
 276
 277 [Good for most of C<Win*> API.]
 278
 279 =item Same for a function which returns 0 and sets WinLastError() on error but
 280 0 is also a valid return
 281
 282  $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...);
 283  # would die("$msg: $^E") if error
 284
 285 [Good for some of C<Win*> API.]
 286
 287 =item As previous, but without die()
 288
 289  $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
 290  if ($res == 0 and $^E) {       # Do error processing here
 291  }
 292
 293 [Good for some of C<Win*> API.]
 294
 295 =back
 296
 297 =head1 ENVIRONMENT
 298
 299 If C<PERL_REXX_DEBUG> is set, emits debugging output.  Looks for DLLs
 300 in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
 301
 302 =head1 AUTHOR
 303
 304 Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
 305 written by Andreas Kaiser ak@ananke.s.bawue.de.
 306
 307 =cut