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

package OS2::DLL;

our $VERSION = '1.03';

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;
  return grep -f $_, @path if $flags & 0x8;
  -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
9d419b5f	3	our $VERSION = '1.03';
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
9d419b5f	67	s,(?![/\\])$,/, for @path;
9d419b5f	68	s,\\,/,g for @path;
1933e12c	69	$name .= ".dll" unless $name =~ /\.[^\\\/]*$/;
1933e12c	70	$_ .= $name for @path;
9d419b5f	71	return grep -f $_, @path if $flags & 0x8;
1933e12c	72	-f $_ and return $_ for @path;
	73	return;
	74	}
	75
622913ab	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;
ed344e4f	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};
622913ab	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";
ed344e4f	106	}
622913ab	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->(@_) };
ed344e4f	116	}
	117	return 1;
	118	}
	119
1933e12c	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
5c728af0	130	XSLoader::load 'OS2::DLL';
ed344e4f	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;
622913ab	148	$emx_dll = OS2::DLL->module('emx');
ed344e4f	149	$emx_version = $emx_dll->emx_revision();
622913ab	150	$func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
622913ab	151	$emx_version = $func_emx_version->();
ed344e4f	152
	153	=head1 DESCRIPTION
	154
622913ab	155	=head2 Create a DLL handle
ed344e4f	156
622913ab	157	$dll = OS2::DLL->module( NAME [, WHERE] );
ed344e4f	158
622913ab	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.
ed344e4f	162
622913ab	163	The DLL is not unloaded when the return value is destroyed.
ed344e4f	164
622913ab	165	=head2 Create a DLL handle (looking in some strange locations)
ed344e4f	166
622913ab	167	$dll = OS2::DLL->new( NAME [, WHERE] );
a748068b	168
622913ab	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).
a748068b	172
622913ab	173	=head2 Loads DLL by name
a748068b	174
622913ab	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).
ed344e4f	181
	182	=head2 Check for functions (optional):
	183
	184	BOOL = $dll->find(NAME [, NAME [, ...]]);
	185
622913ab	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
1933e12c	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
622913ab	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()
ed344e4f	289
622913ab	290	$res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
	291	if ($res == 0 and $^E) { # Do error processing here
	292	}
ed344e4f	293
622913ab	294	[Good for some of C<Win*> API.]
ed344e4f	295
622913ab	296	=back
ed344e4f	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
622913ab	305	Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
ed344e4f	306	written by Andreas Kaiser ak@ananke.s.bawue.de.
	307
	308	=cut