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