os2/OS2/REXX/DLL/DLL.pm

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