X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=os2%2FOS2%2FREXX%2FREXX.pm;h=57e6d6d1a43482dc991c66f728632671d299dc97;hb=2035c5e8eb03b194190a7ef87630a0e4cc7c6251;hp=78e0cf917ddd428f6d03c3db0e84f27de6717050;hpb=760ac839baf413929cd31cc32ffd6dba6b781a81;p=p5sagit%2Fp5-mst-13.2.git diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm index 78e0cf9..57e6d6d 100644 --- a/os2/OS2/REXX/REXX.pm +++ b/os2/OS2/REXX/REXX.pm @@ -3,71 +3,30 @@ 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); - -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; -} +@EXPORT_OK = qw(drop register); + +$VERSION = '1.01'; + +# We cannot just put OS2::DLL in @ISA, since some scripts would use +# function interface, not method interface... -@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); -%dlls = (); +*_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. -# Cannot autoload, the autoloader is used for the REXX functions. - -sub load -{ - confess 'Usage: load OS2::REXX []' 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 register {_register($_) for @_} sub prefix { @@ -107,21 +66,21 @@ sub dropall sub TIESCALAR { my ($obj, $name) = @_; - $name =~ s/^[\w!?]+/\U$&\E/; + $name =~ s/^([\w!?]+)/\U$1\E/; return bless \$name, OS2::REXX::_SCALAR; } sub TIEARRAY { my ($obj, $name) = @_; - $name =~ s/^[\w!?]+/\U$&\E/; + $name =~ s/^([\w!?]+)/\U$1\E/; return bless [$name, 0], OS2::REXX::_ARRAY; } sub TIEHASH { my ($obj, $name) = @_; - $name =~ s/^[\w!?]+/\U$&\E/; + $name =~ s/^([\w!?]+)/\U$1\E/; return bless {Stem => $name}, OS2::REXX::_HASH; } @@ -244,7 +203,8 @@ variables may be usable even without C though. 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. +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. @@ -303,12 +263,37 @@ One enables REXX runtime by bracketing your code by REXX_call \&subroutine_name; -Inside such a call one has access to REXX variables (see below), and to +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 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 < 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"; @@ -342,6 +327,73 @@ part of the key and it is subject to character set restrictions. 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 Subcommand handlers + +By default, the executed REXX code runs without any default subcommand +handler present. A subcommand handler named C is defined, but +not made a default. Use C
REXX command to make it a default +handler; alternatively, use C
to direct a command +to the handler you like. + +Experiments show that the handler C is also available; probably it is +provided by the REXX runtime. + +=head1 Interfacing from REXX to Perl + +This module provides an interface from Perl to REXX, and from REXX-inside-Perl +back to Perl. There is an alternative scenario which allows usage of Perl +from inside REXX. + +A DLL F provides an API to Perl as REXX functions + + PERL + PERLTERM + PERLINIT + PERLEXIT + PERLEVAL + PERLLASTERROR + PERLEXPORTALL + PERLDROPALL + PERLDROPALLEXIT + +A subcommand handler C can also be registered. Calling +the function PERLEXPORTALL() exports all these functions, as well as +exports this subcommand handler under the name C. PERLDROPALL() +inverts this action (and unloads PERLEXPORTALL() as well). In particular + + rc = RxFuncAdd("PerlExportAll", 'PerlRexx', "PERLEXPORTALL") + rc = PerlExportAll() + res = PERLEVAL(perlarg) + ADDRESS EVALPERL perlarg1 + rc = PerlDropAllExit() + +loads all the functions above, evals the Perl code in the REXX variable +C, putting the result into the REXX variable C, +then evals the Perl code in the REXX variable C, and, finally, +drops the loaded functions and the subcommand handler, deinitializes +the Perl interpreter, and exits the Perl's C runtime library. + +PERLEXIT() or PERLDROPALLEXIT() should be called as the last command of +the REXX program. (This is considered as a bug.) Their purpose is to flush +all the output buffers of the Perl's C runtime library. + +C gives the reason for the failure of the last PERLEVAL(). +It is useful inside C handler. PERLINIT() and PERLTERM() +initialize and deinitialize the Perl interpreter. + +C initializes the Perl interpreter (if needed), and +evaluates C as Perl code. The result is returned to REXX stringified, +undefined result is considered as failure. + +C does the same as C wrapped by calls to +PERLINIT() and PERLEXIT(). + =head1 NOTES Note that while function and variable names are case insensitive in the @@ -377,11 +429,56 @@ 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 for examples. +See C 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 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. + =cut