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

package OS2::REXX;

use Carp;
require Exporter;
require DynaLoader;
require OS2::DLL;

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

# We cannot just put OS2::DLL in @ISA, since some scripts would use
# function interface, not method interface...

*_call = \&OS2::DLL::_call;
*load = \&OS2::DLL::load;
*find = \&OS2::DLL::find;

bootstrap OS2::REXX;

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

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 ENVIRONMENT

If C<PERL_REXX_DEBUG> is set, prints trace info on calls to REXX runtime
environment.

=head1 AUTHOR

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

=head1 SEE ALSO

L<OS2::DLL>.

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