1package OS2::DLL; 2 3our $VERSION = '1.06'; 4 5use Carp; 6use 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 16my $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 34my $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 46sub new { 47 confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2; 48 $new_dll->(1, @_); 49} 50 51sub module { 52 confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2; 53 $new_dll->(0, @_); 54} 55 56sub load { 57 confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1; 58 $load_with_dirs->(@_, @libs); 59} 60 61sub 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 76package OS2::DLL::dll; 77use Carp; 78@ISA = 'OS2::DLL'; 79 80sub 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 89sub 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 108sub 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 120sub handle { shift->{Handle} } 121sub fullname { OS2::DLLname(0x202, shift->handle) } 122#sub modname { OS2::DLLname(0x201, shift->handle) } 123 124sub has_f32 { 125 my $handle = shift->handle; 126 my $name = shift; 127 DynaLoader::dl_find_symbol($handle, $name); 128} 129 130XSLoader::load 'OS2::DLL'; 131 1321; 133__END__ 134 135=head1 NAME 136 137OS2::DLL - access to DLLs with REXX calling convention. 138 139=head2 NOTE 140 141When you use this module, the REXX variable pool is not available. 142 143See 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 159Loads an OS/2 module NAME, looking in directories WHERE (adding the 160extension 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 163The 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 169Same as C<module>|L<Create a DLL handle>, but in addition to WHERE, looks 170in environment paths PERL5REXX, PERLREXX, PATH (provided for backward 171compatibility). 172 173=head2 Loads DLL by name 174 175 $dll = load OS2::DLL NAME [, WHERE]; 176 177Same as C<new>|L<Create a DLL handle (looking in some strange locations)>, 178but returns DLL object reference, or undef on failure (in this case one can 179get the reason via C<DynaLoader::dl_error()>) (provided for backward 180compatibility). 181 182=head2 Check for functions (optional): 183 184 BOOL = $dll->find(NAME [, NAME [, ...]]); 185 186Returns true if all functions are available. As a side effect, creates 187a REXX wrapper with the specified name in the package constructed by the name 188of the DLL so that the next call to C<< $dll->NAME() >> will pick up the cached 189method. 190 191=head2 Create a Perl wrapper (optional): 192 193 $func = $dll->wrapper_REXX(NAME); 194 195Returns a reference to a Perl function wrapper for the entry point NAME 196in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case 197the ordinal is loaded. Croaks with a meaningful error message if NAME does 198not exists (although the message for the case when the name is an ordinal may 199be confusing). 200 201=head2 Call external function with REXX calling convention: 202 203 $ret_string = $dll->function_name(arguments); 204 205Returns the return string if the REXX return code is 0, else undef. 206Dies with error message if the function is not available. On the first call 207resolves the name in the DLL and caches the Perl wrapper; future calls go 208through the wrapper. 209 210Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime 211environment (variable pool, queue etc.) is not available to the called 212function. 213 214=head1 Inspecting the module 215 216=over 217 218=item $module->handle 219 220=item $module->fullname 221 222Return the (integer) handle and full path name of a loaded DLL. 223 224TODO: the module name (whatever is specified in the C<LIBRARY> statement 225of F<.def> file when linking) via OS2::Proc. 226 227=item $module->has_f32($name) 228 229Returns the address of a 32-bit entry point with name $name, or 0 if none 230found. (Keep in mind that some entry points may be 16-bit, and some may have 231capitalized names comparing to callable-from-C counterparts.) Name of the 232form C<#197> will find entry point with ordinal 197. 233 234=item libPath_find($name [, $flags]) 235 236Looks for the DLL $name on C<BEGINLIBPATH>, C<LIBPATH>, C<ENDLIBPATH> if 237bits 0x1, 0x2, 0x4 of $flags are set correspondingly. If called with no 238arguments, looks on all 3 locations. Returns the full name of the found 239file. 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 251If 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") 270 if error 271 272[Good for C<Dos*> API - and rare C<Win*> calls.] 273 274=item Same for a function which returns 0 and sets WinLastError() on error 275 276 $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...); 277 # would die("$msg: $^E") if error 278 279[Good for most of C<Win*> API.] 280 281=item Same for a function which returns 0 and sets WinLastError() on error but 2820 is also a valid return 283 284 $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...); 285 # would die("$msg: $^E") if error 286 287[Good for some of C<Win*> API.] 288 289=item As previous, but without die() 290 291 $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...); 292 if ($res == 0 and $^E) { # Do error processing here 293 } 294 295[Good for some of C<Win*> API.] 296 297=back 298 299=head1 ENVIRONMENT 300 301If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs 302in C<PERL5REXX>, C<PERLREXX>, C<PATH>. 303 304=head1 AUTHOR 305 306Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX> 307written by Andreas Kaiser ak@ananke.s.bawue.de. 308 309=cut 310