[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 register);

$VERSION = '1.00';

# 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 register {_register($_) for @_}

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).

An alternative way to execute code inside a REXX compartment is

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

Here C<EXPR> is a REXX code to run; to execute Perl code one needs to put
it inside Perl_subroutine(), and call this subroutine from REXX, as in

	REXX_eval_with <<EOE, foo => sub { 123 * shift };
	  say foo(2)
	EOE

If one needs more Perl subroutines available, one can "import" them into
REXX from inside Perl_subroutine(); since REXX is not case-sensitive,
the names should be uppercased.

	use OS2::REXX 'register';

	sub BAR { 123 + shift}
	sub BAZ { 789 }
	sub importer { register qw(BAR BAZ) }

	REXX_eval_with <<'EOE', importer => \&importer;
	  call importer
	  say bar(34)
	  say baz()
	EOE

=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" [, ...]]);

=head2 Make Perl functions available in REXX:

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

Since REXX is not case-sensitive, the names should be uppercase.

=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> and the next section for examples.

=head1 EXAMPLE

  use OS2::REXX;

  sub Ender::DESTROY { $vrexx->VExit; print "Exiting...\n" }

  $vrexx = OS2::REXX->load('VREXX');
  REXX_call {			# VOpenWindow takes a stem
    local $SIG{TERM} = sub {die}; # enable Ender::DESTROY
    local $SIG{INT} = sub {die};	# enable Ender::DESTROY

    $code = $vrexx->VInit;
    print "Init code = `$code'\n";
    die "error initializing VREXX" if $code eq 'ERROR';

    my $ender = bless [], 'Ender'; # Call Ender::DESTROY on exit

    print "VREXX Version ", $vrexx->VGetVersion, "\n";

    tie %pos, 'OS2::REXX', 'POS.' or die;
    %pos = ( LEFT   => 0, RIGHT  => 7, TOP    => 5, BOTTOM => 0 );

    $id = $vrexx->VOpenWindow('To disconnect:', 'WHITE', 'POS');
    $vrexx->VForeColor($id, 'BLACK');
    $vrexx->VSetFont($id, 'TIME', '30');
    $tlim = time + 60;
    while ( ($r = $tlim - time) >= 0 ) {
      $vrexx->VClearWindow($id);
      $vrexx->VSay($id, 100, 50, (sprintf "%02i:%02i", int($r/60), $r % 60));
      sleep 1;
    }
    print "Close code = `$res'\n" if $res = $vrexx->VCloseWindow($id);
  };


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