[perl5.git] / os2 / OS2 / REXX / DLL / DLL.pm

package OS2::DLL;

our $VERSION = '1.00';

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);
}

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;
}

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 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 IZ	1	package OS2::DLL;
ed344e4f IZ	2
28b605d8 JH	3	our $VERSION = '1.00';
28b605d8 JH	4
ed344e4f	5	use Carp;
8257dec7	6	use XSLoader;
ed344e4f	7
ed344e4f IZ	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
18729d3e	14	# Cannot be autoload, the autoloader is used for the REXX functions.
ed344e4f	15
18729d3e JH	16	my $load_with_dirs = sub {
18729d3e JH	17	my ($class, $file, @where) = (@_);
ed344e4f IZ	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;
18729d3e JH	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} =
18729d3e JH	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 IZ	49	}
ed344e4f IZ	50
18729d3e JH	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	package OS2::DLL::dll;
	62	use Carp;
	63	@ISA = 'OS2::DLL';
	64
	65	sub AUTOLOAD {
	66	$AUTOLOAD =~ /^OS2::DLL::dll::.+::(.+)$/
	67	or confess("Undefined subroutine &$AUTOLOAD called");
	68	return undef if $1 eq "DESTROY";
	69	die "AUTOLOAD loop" if $1 eq "AUTOLOAD";
	70	$_[0]->find($1) or confess($@);
	71	goto &$AUTOLOAD;
	72	}
	73
	74	sub wrapper_REXX {
	75	confess 'Usage: $dllhandle->wrapper_REXX($func_name)' unless @_ == 2;
ed344e4f IZ	76	my $self = shift;
	77	my $file = $self->{File};
	78	my $handle = $self->{Handle};
	79	my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
	80	my $queue = $self->{Queue};
18729d3e JH	81	my $name = shift;
	82	$prefix = '' if $name =~ /^#\d+/; # loading by ordinal
	83	my $addr = (DynaLoader::dl_find_symbol($handle, uc $prefix.$name)
	84	\|\| DynaLoader::dl_find_symbol($handle, $prefix.$name));
	85	return sub {
	86	OS2::DLL::_call($name, $addr, $queue, @_);
	87	} if $addr;
	88	my $err = DynaLoader::dl_error();
	89	$err =~ s/\s+at\s+\S+\s+line\s+\S+\s*\z//;
	90	croak "Can't find symbol `$name' in DLL `$file': $err";
ed344e4f	91	}
18729d3e JH	92
	93	sub find
	94	{
	95	my $self = shift;
	96	my $file = $self->{File};
	97	my $p = ref $self;
	98	foreach (@_) {
	99	my $f = eval {$self->wrapper_REXX($_)} or return 0;
	100	${"${p}::"}{$_} = sub { shift; $f->(@_) };
ed344e4f IZ	101	}
	102	return 1;
	103	}
	104
8257dec7	105	XSLoader::load 'OS2::DLL';
ed344e4f IZ	106
	107	1;
	108	__END__
	109
	110	=head1 NAME
	111
	112	OS2::DLL - access to DLLs with REXX calling convention.
	113
	114	=head2 NOTE
	115
	116	When you use this module, the REXX variable pool is not available.
	117
	118	See documentation of L<OS2::REXX> module if you need the variable pool.
	119
	120	=head1 SYNOPSIS
	121
	122	use OS2::DLL;
18729d3e	123	$emx_dll = OS2::DLL->module('emx');
ed344e4f	124	$emx_version = $emx_dll->emx_revision();
18729d3e JH	125	$func_emx_version = $emx_dll->wrapper_REXX('#128'); # emx_revision
18729d3e JH	126	$emx_version = $func_emx_version->();
ed344e4f IZ	127
	128	=head1 DESCRIPTION
	129
18729d3e	130	=head2 Create a DLL handle
ed344e4f	131
18729d3e	132	$dll = OS2::DLL->module( NAME [, WHERE] );
ed344e4f	133
18729d3e JH	134	Loads an OS/2 module NAME, looking in directories WHERE (adding the
	135	extension F<.dll>), if the DLL is not found there, loads in the usual OS/2 way
	136	(via LIBPATH and other settings). Croaks with a verbose report on failure.
ed344e4f	137
18729d3e	138	The DLL is not unloaded when the return value is destroyed.
ed344e4f	139
18729d3e	140	=head2 Create a DLL handle (looking in some strange locations)
ed344e4f	141
18729d3e	142	$dll = OS2::DLL->new( NAME [, WHERE] );
a748068b	143
18729d3e JH	144	Same as L<C<module>\|Create a DLL handle>, but in addition to WHERE, looks
	145	in environment paths PERL5REXX, PERLREXX, PATH (provided for backward
	146	compatibility).
a748068b	147
18729d3e	148	=head2 Loads DLL by name
a748068b	149
18729d3e JH	150	$dll = load OS2::DLL NAME [, WHERE];
	151
	152	Same as L<C<new>\|Create a DLL handle (looking in some strange locations)>,
	153	but returns DLL object reference, or undef on failure (in this case one can
	154	get the reason via C<DynaLoader::dl_error()>) (provided for backward
	155	compatibility).
ed344e4f IZ	156
	157	=head2 Check for functions (optional):
	158
	159	BOOL = $dll->find(NAME [, NAME [, ...]]);
	160
18729d3e JH	161	Returns true if all functions are available. As a side effect, creates
	162	a REXX wrapper with the specified name in the package constructed by the name
	163	of the DLL so that the next call to C<$dll->NAME()> will pick up the cached
	164	method.
	165
	166	=head2 Create a Perl wrapper (optional):
	167
	168	$func = $dll->wrapper_REXX(NAME);
	169
	170	Returns a reference to a Perl function wrapper for the entry point NAME
	171	in the DLL. Similar to the OS/2 API, the NAME may be C<"#123"> - in this case
	172	the ordinal is loaded. Croaks with a meaningful error message if NAME does
	173	not exists (although the message for the case when the name is an ordinal may
	174	be confusing).
	175
	176	=head2 Call external function with REXX calling convention:
	177
	178	$ret_string = $dll->function_name(arguments);
	179
	180	Returns the return string if the REXX return code is 0, else undef.
	181	Dies with error message if the function is not available. On the first call
	182	resolves the name in the DLL and caches the Perl wrapper; future calls go
	183	through the wrapper.
	184
	185	Unless used inside REXX environment (see L<OS2::REXX>), the REXX runtime
	186	environment (variable pool, queue etc.) is not available to the called
	187	function.
	188
	189	=head1 Low-level API
	190
	191	=over
	192
	193	=item Call a _System linkage function via a pointer
	194
	195	If a function takes up to 20 ULONGs and returns ULONG:
	196
	197	$res = call20( $pointer, $arg0, $arg1, ...);
	198
	199	=item Same for packed arguments:
	200
	201	$res = call20_p( $pointer, pack 'L20', $arg0, $arg1, ...);
	202
	203	=item Same for C<regparm(3)> function:
	204
	205	$res = call20_rp3( $pointer, $arg0, $arg1, ...);
	206
	207	=item Same for packed arguments and C<regparm(3)> function
	208
	209	$res = call20_rp3_p( $pointer, pack 'L20', $arg0, $arg1, ...);
	210
	211	=item Same for a function which returns non-0 and sets system-error on error
	212
	213	call20_Dos( $msg, $pointer, $arg0, $arg1, ...); # die("$msg: $^E") if error
	214
	215	[Good for C<Dos> API - and rare C<Win> calls.]
	216
	217	=item Same for a function which returns 0 and sets WinLastError() on error
	218
	219	$res = call20_Win( $msg, $pointer, $arg0, $arg1, ...);
	220	# would die("$msg: $^E") if error
	221
	222	[Good for most of C<Win*> API.]
	223
	224	=item Same for a function which returns 0 and sets WinLastError() on error but
225	0 is also a valid return
226
227	$res = call20_Win_0OK( $msg, $pointer, $arg0, $arg1, ...);
228	# would die("$msg: $^E") if error
229
230	[Good for some of C<Win*> API.]
231
232	=item As previous, but without die()
ed344e4f	233
18729d3e JH	234	$res = call20_Win_0OK_survive( $pointer, $arg0, $arg1, ...);
	235	if ($res == 0 and $^E) { # Do error processing here
	236	}
ed344e4f	237
18729d3e	238	[Good for some of C<Win*> API.]
ed344e4f	239
18729d3e	240	=back
ed344e4f IZ	241
	242	=head1 ENVIRONMENT
	243
	244	If C<PERL_REXX_DEBUG> is set, emits debugging output. Looks for DLLs
	245	in C<PERL5REXX>, C<PERLREXX>, C<PATH>.
	246
	247	=head1 AUTHOR
	248
18729d3e	249	Extracted by Ilya Zakharevich perl-module-OS2-DLL@ilyaz.org from L<OS2::REXX>
ed344e4f IZ	250	written by Andreas Kaiser ak@ananke.s.bawue.de.
	251
	252	=cut