#!/usr/bin/perl
#
# $Header: operl.pl,v 1.7 91/02/20 15:43:19 sakoh Locked $
# An experimental object-oriented package for perl.
#
package operl;
require 'dumpvar.pl';
#
# an object id = $root . $salt;
#
$root = 'operl_';  # object id root
$salt = 'a';       # object id salt;

#
# &defclass(class, superclass)
#
sub main'defclass {
    local($class) = shift;  # class name
    local($super) = shift;  # super class name

    if (defined($superclass{$super})) {
	$superclass{$class} = $super;
    } else {
	print "no such super class:" . $super . "\n";
    }
}

#
# &defmethod(class, method, body)
#
sub main'defmethod {
    local($class)  = shift; # class name
    local($method) = shift; # method name
    local($body)   = shift; # method body
    local($defs);
    local($result);

    if (!defined($superclass{$class})) {
        print "no such class:" . $class . "\n";
        return -1;
    }
    $methods{$class} .= "$method:";
    $defs = qq!sub $class'$method {! .
	     q!local($context) = shift; ! .
             q!eval "package $context;" . '$self = ' . "$context;"! .
             qq!. q\001! .
             $body . qq!\001;};!;
    $result = eval $defs;
    print $@ . "\n" unless $@ eq '';
    $result;
}

#
# &newobject(class)
#
sub main'newobject {
    local($class) = shift; # class name
    local($newobj);

    if (!defined($superclass{$class})) {
        print "no such class:" . $class . "\n";
        return -1;
    }

    $newobj = $root . $salt++;
    $myclass{$newobj} = $class;

    &main'send($newobj, 'init', @_); # call init with args
    return $newobj;
}

#
# &send(object, method, arg1, arg2, ...)
#
sub main'send {
    local($object) = shift; # objec
    local($method) = shift; # method name
    local($class, $result, $xyz);

    if ($main'msgtrace != 0) {
	$msglevel ++;
	warn "[$msglevel]:&send($object, $method, @_)";
    }
    if ($object !~ /^operl_/o) {
        warn "no such object:" . $object . "\n";
	$msglevel -- if $main'msgtrace != 0;
        return -1;
    }
    $class =  $myclass{$object};

    while (index($methods{$class}, "$method:") < 0) {
	if ($class eq 'root') {
	    warn "unknown message:" . $method . "\n";
	    $msglevel -- if $main'msgtrace != 0;
            return undef;
        }
        $class = $superclass{$class}; # chain to super class
    }
    $xyz = "$class'$method"; # subroutine to be invoked
    $result = do $xyz($object, @_);   # subroutine call
    print $@ . "\n" unless $@ eq '';
    if ($main'msgtrace != 0) {
	warn " ==> " . (($result eq undef) ? 'undef' : $result) . "\n";
	$msglevel --;
    }
    $result;
}

#
# &dumpclass()
#
sub main'dumpclass {
    while (($key, $val) = each %superclass) {
	print $key . " is a subclass of " . $val . "\n";
    }
}

#
# important built-in : 'root' class
#
$superclass{'root'} = 'root';     # 'root' is the super class of itself.
&main'defmethod('root', 'init', ''); # do nothing
&main'defmethod('root', 'class',
q!
    $operl'myclass{$self};
 !);
&main'defmethod('root', 'show_parents',
q!  local($class) = $operl'myclass{$self};
    while ($class ne 'root') {
	print $class . " -> ";
        $class = $operl'superclass{$class}; # chain to the super class
    }
    print "root\n";
 !);
&main'defmethod('root', 'show_self',
q!    print "class:" . $operl'myclass{$self} . "\n";
      print "methods:" . $operl'methods{$operl'myclass{$self}} . "\n";
      &main'dumpvar($self);
 !); # self dump

1;