[p5sagit/p5-mst-13.2.git] / os2 / OS2 / REXX / DLL / DLL.pm

package OS2::DLL;

our $VERSION = '1.02';

use Carp;
use XSLoader;

@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
%dlls = ();

# Preloaded methods go here.  Autoload methods go after __END__, and are
# processed by the autosplit program.

# Cannot be autoload, the autoloader is used for the REXX functions.

my $load_with_dirs = sub {
	my ($class, $file, @where) = (@_);
	return $dlls{$file} if $dlls{$file};
	my $handle;
	foreach (@where) {
		$handle = DynaLoader::dl_load_file("$_/$file.dll");
		last if $handle;
	}
	$handle = DynaLoader::dl_load_file($file) unless $handle;
	return undef unless $handle;
	my @packs = $INC{'OS2/REXX.pm'} ? qw(OS2::DLL::dll OS2::REXX) : 'OS2::DLL::dll';
	my $p = "OS2::DLL::dll::$file";
	@{"$p\::ISA"} = @packs;
	*{"$p\::AUTOLOAD"} = \&OS2::DLL::dll::AUTOLOAD;
	return $dlls{$file} = 
	  bless {Handle => $handle, File => $file, Queue => 'SESSION' }, $p;
};

my $new_dll = sub {
  my ($dirs, $class, $file) = (shift, shift, shift);
  my $handle;
  push @_, @libs if $dirs;
  $handle = $load_with_dirs->($class, $file, @_)
    and return $handle;
  my $path = @_ ? " from '@_'" : '';
  my $err = DynaLoader::dl_error();
  $err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
  croak "Can't load '$file'$path: $err";
};

sub new {
  confess 'Usage: OS2::DLL->new( <file> [<dirs>] )' unless @_ >= 2;
  $new_dll->(1, @_);
}

sub module {
  confess 'Usage: OS2::DLL->module( <file> [<dirs>] )' unless @_ >= 2;
  $new_dll->(0, @_);
}

sub load {
  confess 'Usage: load OS2::DLL <file> [<dirs>]' unless $#_ >= 1;
  $load_with_dirs->(@_, @libs);
}

sub libPath_find {
  my ($name, $flags, @path) = (shift, shift);
  $flags = 0x7 unless defined $flags;
  push @path, split /;/, OS2::extLibpath	if $flags & 0x1;	# BEGIN
  push @path, split /;/, OS2::libPath		if $flags & 0x2;
  push @path, split /;/, OS2::extLibpath(1)	if $flags & 0x4;	# END
  s,(?![/\\])$,/, for @path;
  s,\\,/,g for @path;
  $name .= ".dll" unless $name =~ /\.[^\\\/]*$/;
  $_ .= $name for @path;
  -f $_ and return $_ for @path;
  return;
}

package OS2::DLL::dll;
use Carp;
@ISA = 'OS2::DLL';

sub AUTOLOAD {
    $AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/
      or confess("Undefined subroutine &$AUTOLOAD called");
    return undef if $1 eq "DESTROY";
    die "AUTOLOAD loop" if $1 eq "AUTOLOAD";
    $_[0]->find($1) or confess($@);
    goto &$AUTOLOAD;
}

sub wrapper_REXX {
	confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2;
	my $self   = shift;
	my $file   = $self->{File};
	my $handle = $self->{Handle};
	my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
	my $queue  = $self->{Queue};
	my $name = shift;
	$prefix = '' if $name =~ /^#\d+/;	# loading by ordinal
	my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
		    || DynaLoader::dl_find_symbol($handle, $prefix.$name));
	return sub {
	  OS2::DLL::_call($name, $addr, $queue, @_);
	} if $addr;
	my $err = DynaLoader::dl_error();
	$err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
	croak "Can't find symbol `$name' in DLL `$file': $err";
}

sub find
{
	my $self   = shift;
	my $file   = $self->{File};
	my $p	   = ref $self;
	foreach (@_) {
		my $f = eval {$self->wrapper_REXX($_)} or return 0;
		${"${p}::"}{$_} = sub { shift; $f->(@_) };
	}
	return 1;
}

sub handle	{ shift->{Handle} }
sub fullname	{ OS2::DLLname(0x202, shift->handle) }
#sub modname	{ OS2::DLLname(0x201, shift->handle) }

sub has_f32 {
   my $handle = shift->handle;
   my $name = shift;
   DynaLoader::dl_find_symbol($handle, $name);
}

XSLoader::load 'OS2::DLL';

1;
__END__

=head1 NAME

OS2::DLL - access to DLLs with REXX calling convention.

=head2 NOTE

When you use this module, the REXX variable pool is not available.

See documentation of L<OS2::REXX> module if you need the variable pool.

=head1 SYNOPSIS

	use OS2::DLL;
	$emx_dll = OS2::DLL->module('emx');
	$emx_version = $emx_dll->emx_revision();
	$func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
	$emx_version = $func_emx_version->();

=head1 DESCRIPTION

=head2 Create a DLL handle

	$dll = OS2::DLL->module( NAME [, WHERE] );

Loads an OS/2 module NAME, looking in directories WHERE (adding the
extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way
(via LIBPATH and other settings).  Croaks with a verbose report on failure.

The DLL is not unloaded when the return value is destroyed.

=head2 Create a DLL handle (looking in some strange locations)

	$dll = OS2::DLL->new( NAME [, WHERE] );

Same as L<C<module>|Create a DLL handle>, but in addition to WHERE, looks
in environment paths PERL5REXX, PERLREXX, PATH (provided for backward
compatibility).

=head2 Loads DLL by name

	$dll = load OS2::DLL NAME [, WHERE];

Same as L<C<new>|Create a DLL handle (looking in some strange locations)>,
but returns DLL object reference, or undef on failure (in this case one can
get the reason via C<DynaLoader::dl_error()>) (provided for backward
compatibility).

=head2 Check for functions (optional):

	BOOL = $dll->find(NAME [, NAME [, ...]]);

Returns true if all functions are available.  As a side effect, creates
a REXX wrapper with the specified name in the package constructed by the name
of the DLL so that the next call to C<$dll->NAME()> will pick up the cached
method.

=head2 Create a Perl wrapper (optional):

	$func = $dll->wrapper_REXX(NAME);

Returns a reference to a Perl function wrapper for the entry point NAME
in the DLL.  Similar to the OS/2 API, the NAME may be C<"#123"> - in this case
the ordinal is loaded.   Croaks with a meaningful error message if NAME does
not exists (although the message for the case when the name is an ordinal may
be confusing).

=head2 Call external function with REXX calling convention:

	$ret_string = $dll->function_name(arguments);

Returns the return string if the REXX return code is 0, else undef.
Dies with error message if the function is not available.  On the first call
resolves the name in the DLL and caches the Perl wrapper; future calls go
through the wrapper.

Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime
environment (variable pool, queue etc.) is not available to the called
function.

=head1 Inspecting the module

=over

=item $module->handle

=item $module->fullname

Return the (integer) handle and full path name of a loaded DLL.

TODO: the module name (whatever is specified in the C<LIBRARY> statement
of F<.def> file when linking) via OS2::Proc.

=item $module->has_f32($name)

Returns the address of a 32-bit entry point with name $name, or 0 if none
found.  (Keep in mind that some entry points may be 16-bit, and some may have
capitalized names comparing to callable-from-C counterparts.)  Name of the
form C<#197> will find entry point with ordinal 197.

=item libPath_find($name [, $flags])

Looks for the DLL $name on C<BEGINLIBPATH>, C<LIBPATH>, C<ENDLIBPATH> if
bits 0x1, 0x2, 0x4 of $flags are set correspondingly.  If called with no
arguments, looks on all 3 locations.  Returns the full name of the found
file.  B<DLL is not loaded.>

$name has F<.dll> appended unless it already has an extension.

=back

=head1 Low-level API

=over

=item Call a _System linkage function via a pointer

If a function takes up to 20 ULONGs and returns ULONG:

 $res = call20( $pointer, $arg0, $arg1, ...);

=item Same for packed arguments:

 $res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...);

=item Same for C<regparm(3)> function:

 $res = call20_rp3( $pointer, $arg0, $arg1, ...);

=item Same for packed arguments and C<regparm(3)> function

 $res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...);

=item Same for a function which returns non-0 and sets system-error on error

 call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error

[Good for C<Dos*> API - and rare C<Win*> calls.]

=item Same for a function which returns 0 and sets WinLastError() on error

 $res = call20_Win( $msg, $pointer, $arg0, $arg1, ...);
 # would die("$msg: $^E") if error

[Good for most of C<Win*> API.]

=item Same for a function which returns 0 and sets WinLastError() on error but
0 is also a valid return

 $res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...);
 # would die("$msg: $^E") if error

[Good for some of C<Win*> API.]

=item As previous, but without die()

 $res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
 if ($res == 0 and $^E) {	# Do error processing here
 }

[Good for some of C<Win*> API.]

=back

=head1 ENVIRONMENT

If C<PERL_REXX_DEBUG> is set, emits debugging output.  Looks for DLLs
in C<PERL5REXX>, C<PERLREXX>, C<PATH>.

=head1 AUTHOR

Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
written by Andreas Kaiser ak@ananke.s.bawue.de.

=cut
Commit	Line	Data
ed344e4f	1	package OS2::DLL;
ed344e4f	2
1933e12c	3	our $VERSION = '1.02';
28b605d8	4
ed344e4f	5	use Carp;
5c728af0	6	use XSLoader;
ed344e4f	7
ed344e4f	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
622913ab	14	# Cannot be autoload, the autoloader is used for the REXX functions.
ed344e4f	15
622913ab	16	my $load_with_dirs = sub {
622913ab	17	my ($class, $file, @where) = (@_);
ed344e4f	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;
622913ab	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;
ed344e4f	30	return $dlls{$file} =
622913ab	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, @_);
ed344e4f	49	}
ed344e4f	50
622913ab	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
1933e12c	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
622913ab	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;
ed344e4f	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};
622913ab	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";
ed344e4f	105	}
622913ab	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->(@_) };
ed344e4f	115	}
	116	return 1;
	117	}
	118
1933e12c	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
5c728af0	129	XSLoader::load 'OS2::DLL';
ed344e4f	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;
622913ab	147	$emx_dll = OS2::DLL->module('emx');
ed344e4f	148	$emx_version = $emx_dll->emx_revision();
622913ab	149	$func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
622913ab	150	$emx_version = $func_emx_version->();
ed344e4f	151
	152	=head1 DESCRIPTION
	153
622913ab	154	=head2 Create a DLL handle
ed344e4f	155
622913ab	156	$dll = OS2::DLL->module( NAME [, WHERE] );
ed344e4f	157
622913ab	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.
ed344e4f	161
622913ab	162	The DLL is not unloaded when the return value is destroyed.
ed344e4f	163
622913ab	164	=head2 Create a DLL handle (looking in some strange locations)
ed344e4f	165
622913ab	166	$dll = OS2::DLL->new( NAME [, WHERE] );
a748068b	167
622913ab	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).
a748068b	171
622913ab	172	=head2 Loads DLL by name
a748068b	173
622913ab	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).
ed344e4f	180
	181	=head2 Check for functions (optional):
	182
	183	BOOL = $dll->find(NAME [, NAME [, ...]]);
	184
622913ab	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
1933e12c	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
622913ab	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()
ed344e4f	288
622913ab	289	$res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
	290	if ($res == 0 and $^E) { # Do error processing here
	291	}
ed344e4f	292
622913ab	293	[Good for some of C<Win*> API.]
ed344e4f	294
622913ab	295	=back
ed344e4f	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
622913ab	304	Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
ed344e4f	305	written by Andreas Kaiser ak@ananke.s.bawue.de.
	306
	307	=cut