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 = ();
# 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
{
	goto &OS2::REXX::_drop;
}

sub TIESCALAR
{
	my ($obj, $name) = @_;
	$name =~ s/^[\w!?]+/\U$&\E/;
	return bless \$name, OS2::REXX::_SCALAR;
}	

sub TIEARRAY
{
	my ($obj, $name) = @_;
	$name =~ s/^[\w!?]+/\U$&\E/;
	return bless [$name, 0], OS2::REXX::_ARRAY;
}

sub TIEHASH
{
	my ($obj, $name) = @_;
	$name =~ s/^[\w!?]+/\U$&\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 TieHash;
@ISA = TieHash;

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__



