[p5sagit/p5-mst-13.2.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;
	}
	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 or, as last resort, PATH.

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