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

package OS2::REXX;

use Carp;
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT = qw(REXX_call REXX_eval REXX_eval_with);
# Other items we are prepared to export if requested
@EXPORT_OK = qw(drop);

sub AUTOLOAD {
    $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/
      or confess("Undefined subroutine &$AUTOLOAD called");
    return undef if $1 eq "DESTROY";
    $_[0]->find($1)
      or confess("Can't find entry '$1' to DLL '$_[0]->{File}'");
    goto &$AUTOLOAD;
}

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

bootstrap OS2::REXX;

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

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

sub load
{
	confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1;
	my ($class, $file, @where) = (@_, @libs);
	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;
	eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');"
	   . "sub AUTOLOAD {"
	   . "  \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;"
	   . "  goto &OS2::REXX::AUTOLOAD;"
	   . "} 1;" or die "eval package $@";
	return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file";
}

sub find
{
	my $self   = shift;
	my $file   = $self->{File};
	my $handle = $self->{Handle};
	my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
	my $queue  = $self->{Queue};
	foreach (@_) {
		my $name = "OS2::REXX::${file}::$_";
		next if defined(&$name);
		my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
		        || DynaLoader::dl_find_symbol($handle, $prefix.$_)
			or return 0;
		eval "package OS2::REXX::$file; sub $_".
		     "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }".
		     "1;"
			or die "eval sub";
	}
	return 1;
}

sub prefix
{
	my $self = shift;
	$self->{Prefix} = shift;
}

sub queue
{
	my $self = shift;
	$self->{Queue} = shift;
}

sub drop
{				# Supposedly should drop anything with
                                # the given prefix. Unfortunately a
                                # loop is needed after fixpack17.
&OS2::REXX::_drop(@_);
}

sub dropall
{				# Supposedly should drop anything with
                                # the given prefix. Unfortunately a
                                # loop is needed after fixpack17.
  &OS2::REXX::_drop(@_);	# Try to drop them all.
  my $name;
  for (@_) {
    if (/\.$/) {
      OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
      while (($name) = OS2::REXX::_next($_)) {
	OS2::REXX::_drop($_ . $name);
      }
    } 
  }
}

sub TIESCALAR
{
	my ($obj, $name) = @_;
	$name =~ s/^([\w!?]+)/\U$1\E/;
	return bless \$name, OS2::REXX::_SCALAR;
}	

sub TIEARRAY
{
	my ($obj, $name) = @_;
	$name =~ s/^([\w!?]+)/\U$1\E/;
	return bless [$name, 0], OS2::REXX::_ARRAY;
}

sub TIEHASH
{
	my ($obj, $name) = @_;
	$name =~ s/^([\w!?]+)/\U$1\E/;
	return bless {Stem => $name}, OS2::REXX::_HASH;
}

#############################################################################
package OS2::REXX::_SCALAR;

sub FETCH
{
	return OS2::REXX::_fetch(${$_[0]});
}

sub STORE
{
	return OS2::REXX::_set(${$_[0]}, $_[1]);
}

sub DESTROY
{
	return OS2::REXX::_drop(${$_[0]});
}

#############################################################################
package OS2::REXX::_ARRAY;

sub FETCH
{
	$_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
	return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1]));
}

sub STORE
{
	$_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
	return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]);
}

#############################################################################
package OS2::REXX::_HASH;

require Tie::Hash;
@ISA = ('Tie::Hash');

sub FIRSTKEY
{
	my ($self) = @_;
	my $stem = $self->{Stem};

	delete $self->{List} if exists $self->{List};

	my @list = ();
	my ($name, $value);
	OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
	while (($name) = OS2::REXX::_next($stem)) {
		push @list, $name;
	}
	my $key = pop @list;

	$self->{List} = \@list;
	return $key;
}

sub NEXTKEY
{
	return pop @{$_[0]->{List}};
}

sub EXISTS
{
	return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
}

sub FETCH
{
	return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
}

sub STORE
{
	return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]);
}

sub DELETE
{
	OS2::REXX::_drop($_[0]->{Stem}.$_[1]);
}

#############################################################################
package OS2::REXX;

1;
__END__

=head1 NAME

OS2::REXX - access to DLLs with REXX calling convention and REXX runtime.

=head2 NOTE

By default, the REXX variable pool is not available, neither
to Perl, nor to external REXX functions. To enable it, you need to put
your code inside C<REXX_call> function.  REXX functions which do not use
variables may be usable even without C<REXX_call> though.

=head1 SYNOPSIS

	use OS2::REXX;
	$ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!";
	@pid = $ydb->RxProcId();
	REXX_call {
	  tie $s, OS2::REXX, "TEST";
	  $s = 1;
	};

=head1 DESCRIPTION

=head2 Load REXX DLL

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

NAME is DLL name, without path and extension.

Directories are searched WHERE first (list of dirs), then environment
paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search 
is performed in default DLL path (without adding paths and extensions).

The DLL is not unloaded when the variable dies.

Returns DLL object reference, or undef on failure.

=head2 Define function prefix:

	$dll->prefix(NAME);

Define the prefix of external functions, prepended to the function
names used within your program, when looking for the entries in the
DLL.

=head2 Example

		$dll = load OS2::REXX "RexxBase";
		$dll->prefix("RexxBase_");
		$dll->Init();

is the same as

		$dll = load OS2::REXX "RexxBase";
		$dll->RexxBase_Init();

=head2 Define queue:

	$dll->queue(NAME);

Define the name of the REXX queue passed to all external
functions of this module. Defaults to "SESSION".

Check for functions (optional):

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

Returns true if all functions are available.

=head2 Call external REXX function:

	$dll->function(arguments);

Returns the return string if the return code is 0, else undef.
Dies with error message if the function is not available.

=head1 Accessing REXX-runtime

While calling functions with REXX signature does not require the presence
of the system REXX DLL, there are some actions which require REXX-runtime 
present. Among them is the access to REXX variables by name.

One enables REXX runtime by bracketing your code by

	REXX_call BLOCK;

(trailing semicolon required!) or

	REXX_call \&subroutine_name;

Inside such a call one has access to REXX variables (see below), and to

	REXX_eval EXPR;
	REXX_eval_with EXPR, 
		subroutine_name_in_REXX => \&Perl_subroutine

=head2 Bind scalar variable to REXX variable:

	tie $var, OS2::REXX, "NAME";

=head2 Bind array variable to REXX stem variable:

	tie @var, OS2::REXX, "NAME.";

Only scalar operations work so far. No array assignments, no array
operations, ... FORGET IT.

=head2 Bind hash array variable to REXX stem variable:

	tie %var, OS2::REXX, "NAME.";

To access all visible REXX variables via hash array, bind to "";

No array assignments. No array operations, other than hash array
operations. Just like the *dbm based implementations.

For the usual REXX stem variables, append a "." to the name,
as shown above. If the hash key is part of the stem name, for
example if you bind to "", you cannot use lower case in the stem
part of the key and it is subject to character set restrictions.

=head2 Erase individual REXX variables (bound or not):

	OS2::REXX::drop("NAME" [, "NAME" [, ...]]);

=head2 Erase REXX variables with given stem (bound or not):

	OS2::REXX::dropall("STEM" [, "STEM" [, ...]]);

=head1 NOTES

Note that while function and variable names are case insensitive in the
REXX language, function names exported by a DLL and the REXX variables
(as seen by Perl through the chosen API) are all case sensitive!

Most REXX DLLs export function names all upper case, but there are a
few which export mixed case names (such as RxExtras). When trying to
find the entry point, both exact case and all upper case are searched.
If the DLL exports "RxNap", you have to specify the exact case, if it
exports "RXOPEN", you can use any case.

To avoid interfering with subroutine names defined by Perl (DESTROY)
or used within the REXX module (prefix, find), it is best to use mixed
case and to avoid lowercase only or uppercase only names when calling
REXX functions. Be consistent. The same function written in different
ways results in different Perl stubs.

There is no REXX interpolation on variable names, so the REXX variable
name TEST.ONE is not affected by some other REXX variable ONE. And it
is not the same variable as TEST.one!

You cannot call REXX functions which are not exported by the DLL.
While most DLLs export all their functions, some, like RxFTP, export
only "...LoadFuncs", which registers the functions within REXX only.

You cannot call 16-bit DLLs. The few interesting ones I found
(FTP,NETB,APPC) do not export their functions.

I do not know whether the REXX API is reentrant with respect to
exceptions (signals) when the REXX top-level exception handler is
overridden. So unless you know better than I do, do not access REXX
variables (probably tied to Perl variables) or call REXX functions
which access REXX queues or REXX variables in signal handlers.

See C<t/rx*.t> for examples.

=head1 AUTHOR

Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
ilya@math.ohio-state.edu.

=cut
Commit	Line	Data
760ac839 LW	1	package OS2::REXX;
	2
	3	use Carp;
	4	require Exporter;
	5	require DynaLoader;
	6	@ISA = qw(Exporter DynaLoader);
	7	# Items to export into callers namespace by default
	8	# (move infrequently used names to @EXPORT_OK below)
	9	@EXPORT = qw(REXX_call REXX_eval REXX_eval_with);
	10	# Other items we are prepared to export if requested
	11	@EXPORT_OK = qw(drop);
	12
	13	sub AUTOLOAD {
	14	$AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/
	15	or confess("Undefined subroutine &$AUTOLOAD called");
	16	return undef if $1 eq "DESTROY";
	17	$_[0]->find($1)
	18	or confess("Can't find entry '$1' to DLL '$_[0]->{File}'");
	19	goto &$AUTOLOAD;
	20	}
	21
	22	@libs = split(/;/, $ENV{'PERL5REXX'} \|\| $ENV{'PERLREXX'} \|\| $ENV{'LIBPATH'} \|\| $ENV{'PATH'});
	23	%dlls = ();
	24
	25	bootstrap OS2::REXX;
	26
	27	# Preloaded methods go here. Autoload methods go after __END__, and are
	28	# processed by the autosplit program.
	29
	30	# Cannot autoload, the autoloader is used for the REXX functions.
	31
	32	sub load
	33	{
	34	confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1;
	35	my ($class, $file, @where) = (@_, @libs);
	36	return $dlls{$file} if $dlls{$file};
	37	my $handle;
	38	foreach (@where) {
	39	$handle = DynaLoader::dl_load_file("$_/$file.dll");
	40	last if $handle;
	41	}
fb73857a	42	$handle = DynaLoader::dl_load_file($file) unless $handle;
760ac839 LW	43	return undef unless $handle;
	44	eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');"
	45	. "sub AUTOLOAD {"
	46	. " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;"
	47	. " goto &OS2::REXX::AUTOLOAD;"
	48	. "} 1;" or die "eval package $@";
	49	return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file";
	50	}
	51
	52	sub find
	53	{
	54	my $self = shift;
	55	my $file = $self->{File};
	56	my $handle = $self->{Handle};
	57	my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
	58	my $queue = $self->{Queue};
	59	foreach (@_) {
	60	my $name = "OS2::REXX::${file}::$_";
	61	next if defined(&$name);
	62	my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
	63	\|\| DynaLoader::dl_find_symbol($handle, $prefix.$_)
	64	or return 0;
	65	eval "package OS2::REXX::$file; sub $_".
	66	"{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }".
	67	"1;"
	68	or die "eval sub";
	69	}
	70	return 1;
	71	}
	72
	73	sub prefix
	74	{
	75	my $self = shift;
	76	$self->{Prefix} = shift;
	77	}
	78
	79	sub queue
	80	{
	81	my $self = shift;
	82	$self->{Queue} = shift;
	83	}
	84
	85	sub drop
	86	{ # Supposedly should drop anything with
	87	# the given prefix. Unfortunately a
	88	# loop is needed after fixpack17.
	89	&OS2::REXX::_drop(@_);
	90	}
	91
	92	sub dropall
	93	{ # Supposedly should drop anything with
	94	# the given prefix. Unfortunately a
	95	# loop is needed after fixpack17.
	96	&OS2::REXX::_drop(@_); # Try to drop them all.
	97	my $name;
	98	for (@_) {
	99	if (/\.$/) {
	100	OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
	101	while (($name) = OS2::REXX::_next($_)) {
	102	OS2::REXX::_drop($_ . $name);
	103	}
	104	}
	105	}
	106	}
107
108	sub TIESCALAR
109	{
110	my ($obj, $name) = @_;
f02a87df	111	$name =~ s/^([\w!?]+)/\U$1\E/;
760ac839 LW	112	return bless \$name, OS2::REXX::_SCALAR;
	113	}
	114
	115	sub TIEARRAY
	116	{
	117	my ($obj, $name) = @_;
f02a87df	118	$name =~ s/^([\w!?]+)/\U$1\E/;
760ac839 LW	119	return bless [$name, 0], OS2::REXX::_ARRAY;
	120	}
	121
	122	sub TIEHASH
	123	{
	124	my ($obj, $name) = @_;
f02a87df	125	$name =~ s/^([\w!?]+)/\U$1\E/;
760ac839 LW	126	return bless {Stem => $name}, OS2::REXX::_HASH;
	127	}
	128
	129	#############################################################################
	130	package OS2::REXX::_SCALAR;
	131
	132	sub FETCH
	133	{
	134	return OS2::REXX::_fetch(${$_[0]});
	135	}
	136
	137	sub STORE
	138	{
	139	return OS2::REXX::_set(${$_[0]}, $_[1]);
	140	}
	141
	142	sub DESTROY
	143	{
	144	return OS2::REXX::_drop(${$_[0]});
	145	}
	146
	147	#############################################################################
	148	package OS2::REXX::_ARRAY;
	149
	150	sub FETCH
	151	{
	152	$_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
	153	return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1]));
	154	}
	155
	156	sub STORE
	157	{
	158	$_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
	159	return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]);
	160	}
	161
	162	#############################################################################
	163	package OS2::REXX::_HASH;
	164
	165	require Tie::Hash;
	166	@ISA = ('Tie::Hash');
	167
	168	sub FIRSTKEY
	169	{
	170	my ($self) = @_;
	171	my $stem = $self->{Stem};
	172
	173	delete $self->{List} if exists $self->{List};
	174
	175	my @list = ();
	176	my ($name, $value);
	177	OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
	178	while (($name) = OS2::REXX::_next($stem)) {
	179	push @list, $name;
	180	}
	181	my $key = pop @list;
	182
	183	$self->{List} = \@list;
	184	return $key;
	185	}
	186
	187	sub NEXTKEY
	188	{
	189	return pop @{$_[0]->{List}};
190	}
191
192	sub EXISTS
193	{
194	return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
195	}
196
197	sub FETCH
198	{
199	return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
200	}
201
202	sub STORE
203	{
204	return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]);
205	}
206
207	sub DELETE
208	{
209	OS2::REXX::_drop($_[0]->{Stem}.$_[1]);
210	}
211
212	#############################################################################
213	package OS2::REXX;
214
215	1;
216	__END__
217
218	=head1 NAME
219
220	OS2::REXX - access to DLLs with REXX calling convention and REXX runtime.
221
222	=head2 NOTE
223
224	By default, the REXX variable pool is not available, neither
225	to Perl, nor to external REXX functions. To enable it, you need to put
226	your code inside C<REXX_call> function. REXX functions which do not use
227	variables may be usable even without C<REXX_call> though.
228
229	=head1 SYNOPSIS
230
231	use OS2::REXX;
232	$ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!";
233	@pid = $ydb->RxProcId();
234	REXX_call {
235	tie $s, OS2::REXX, "TEST";
236	$s = 1;
237	};
238
239	=head1 DESCRIPTION
240
241	=head2 Load REXX DLL
242
243	$dll = load OS2::REXX NAME [, WHERE];
244
245	NAME is DLL name, without path and extension.
246
247	Directories are searched WHERE first (list of dirs), then environment
fb73857a	248	paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search
fb73857a	249	is performed in default DLL path (without adding paths and extensions).
760ac839 LW	250
	251	The DLL is not unloaded when the variable dies.
	252
	253	Returns DLL object reference, or undef on failure.
	254
	255	=head2 Define function prefix:
	256
	257	$dll->prefix(NAME);
	258
	259	Define the prefix of external functions, prepended to the function
	260	names used within your program, when looking for the entries in the
	261	DLL.
	262
	263	=head2 Example
	264
	265	$dll = load OS2::REXX "RexxBase";
	266	$dll->prefix("RexxBase_");
	267	$dll->Init();
	268
	269	is the same as
	270
	271	$dll = load OS2::REXX "RexxBase";
	272	$dll->RexxBase_Init();
	273
	274	=head2 Define queue:
	275
	276	$dll->queue(NAME);
	277
	278	Define the name of the REXX queue passed to all external
	279	functions of this module. Defaults to "SESSION".
	280
	281	Check for functions (optional):
	282
	283	BOOL = $dll->find(NAME [, NAME [, ...]]);
	284
	285	Returns true if all functions are available.
	286
	287	=head2 Call external REXX function:
	288
	289	$dll->function(arguments);
	290
	291	Returns the return string if the return code is 0, else undef.
	292	Dies with error message if the function is not available.
	293
	294	=head1 Accessing REXX-runtime
	295
	296	While calling functions with REXX signature does not require the presence
	297	of the system REXX DLL, there are some actions which require REXX-runtime
	298	present. Among them is the access to REXX variables by name.
	299
	300	One enables REXX runtime by bracketing your code by
	301
	302	REXX_call BLOCK;
	303
	304	(trailing semicolon required!) or
	305
	306	REXX_call \&subroutine_name;
	307
	308	Inside such a call one has access to REXX variables (see below), and to
	309
	310	REXX_eval EXPR;
	311	REXX_eval_with EXPR,
	312	subroutine_name_in_REXX => \&Perl_subroutine
	313
314	=head2 Bind scalar variable to REXX variable:
315
316	tie $var, OS2::REXX, "NAME";
317
318	=head2 Bind array variable to REXX stem variable:
319
320	tie @var, OS2::REXX, "NAME.";
321
322	Only scalar operations work so far. No array assignments, no array
323	operations, ... FORGET IT.
324
325	=head2 Bind hash array variable to REXX stem variable:
326
327	tie %var, OS2::REXX, "NAME.";
328
329	To access all visible REXX variables via hash array, bind to "";
330
331	No array assignments. No array operations, other than hash array
332	operations. Just like the *dbm based implementations.
333
334	For the usual REXX stem variables, append a "." to the name,
335	as shown above. If the hash key is part of the stem name, for
336	example if you bind to "", you cannot use lower case in the stem
337	part of the key and it is subject to character set restrictions.
338
339	=head2 Erase individual REXX variables (bound or not):
340
341	OS2::REXX::drop("NAME" [, "NAME" [, ...]]);
342
343	=head2 Erase REXX variables with given stem (bound or not):
344
345	OS2::REXX::dropall("STEM" [, "STEM" [, ...]]);
346
347	=head1 NOTES
348
349	Note that while function and variable names are case insensitive in the
350	REXX language, function names exported by a DLL and the REXX variables
351	(as seen by Perl through the chosen API) are all case sensitive!
352
353	Most REXX DLLs export function names all upper case, but there are a
354	few which export mixed case names (such as RxExtras). When trying to
355	find the entry point, both exact case and all upper case are searched.
356	If the DLL exports "RxNap", you have to specify the exact case, if it
357	exports "RXOPEN", you can use any case.
358
359	To avoid interfering with subroutine names defined by Perl (DESTROY)
360	or used within the REXX module (prefix, find), it is best to use mixed
361	case and to avoid lowercase only or uppercase only names when calling
362	REXX functions. Be consistent. The same function written in different
363	ways results in different Perl stubs.
364
365	There is no REXX interpolation on variable names, so the REXX variable
366	name TEST.ONE is not affected by some other REXX variable ONE. And it
367	is not the same variable as TEST.one!
368
369	You cannot call REXX functions which are not exported by the DLL.
370	While most DLLs export all their functions, some, like RxFTP, export
371	only "...LoadFuncs", which registers the functions within REXX only.
372
373	You cannot call 16-bit DLLs. The few interesting ones I found
374	(FTP,NETB,APPC) do not export their functions.
375
376	I do not know whether the REXX API is reentrant with respect to
377	exceptions (signals) when the REXX top-level exception handler is
378	overridden. So unless you know better than I do, do not access REXX
379	variables (probably tied to Perl variables) or call REXX functions
380	which access REXX queues or REXX variables in signal handlers.
381
382	See C<t/rx*.t> for examples.
383
384	=head1 AUTHOR
385
386	Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
387	ilya@math.ohio-state.edu.
388
389	=cut