home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-osu / operl.shar / operl.pl < prev    next >
Encoding:
Perl Script  |  1991-02-25  |  3.3 KB  |  142 lines
  1. #!/usr/bin/perl
  2. #
  3. # $Header: operl.pl,v 1.7 91/02/20 15:43:19 sakoh Locked $
  4. # An experimental object-oriented package for perl.
  5. #
  6. package operl;
  7. require 'dumpvar.pl';
  8. #
  9. # an object id = $root . $salt;
  10. #
  11. $root = 'operl_';  # object id root
  12. $salt = 'a';       # object id salt;
  13.  
  14. #
  15. # &defclass(class, superclass)
  16. #
  17. sub main'defclass {
  18.     local($class) = shift;  # class name
  19.     local($super) = shift;  # super class name
  20.  
  21.     if (defined($superclass{$super})) {
  22.     $superclass{$class} = $super;
  23.     } else {
  24.     print "no such super class:" . $super . "\n";
  25.     }
  26. }
  27.  
  28. #
  29. # &defmethod(class, method, body)
  30. #
  31. sub main'defmethod {
  32.     local($class)  = shift; # class name
  33.     local($method) = shift; # method name
  34.     local($body)   = shift; # method body
  35.     local($defs);
  36.     local($result);
  37.  
  38.     if (!defined($superclass{$class})) {
  39.         print "no such class:" . $class . "\n";
  40.         return -1;
  41.     }
  42.     $methods{$class} .= "$method:";
  43.     $defs = qq!sub $class'$method {! .
  44.          q!local($context) = shift; ! .
  45.              q!eval "package $context;" . '$self = ' . "$context;"! .
  46.              qq!. q\001! .
  47.              $body . qq!\001;};!;
  48.     $result = eval $defs;
  49.     print $@ . "\n" unless $@ eq '';
  50.     $result;
  51. }
  52.  
  53. #
  54. # &newobject(class)
  55. #
  56. sub main'newobject {
  57.     local($class) = shift; # class name
  58.     local($newobj);
  59.  
  60.     if (!defined($superclass{$class})) {
  61.         print "no such class:" . $class . "\n";
  62.         return -1;
  63.     }
  64.  
  65.     $newobj = $root . $salt++;
  66.     $myclass{$newobj} = $class;
  67.  
  68.     &main'send($newobj, 'init', @_); # call init with args
  69.     return $newobj;
  70. }
  71.  
  72. #
  73. # &send(object, method, arg1, arg2, ...)
  74. #
  75. sub main'send {
  76.     local($object) = shift; # objec
  77.     local($method) = shift; # method name
  78.     local($class, $result, $xyz);
  79.  
  80.     if ($main'msgtrace != 0) {
  81.     $msglevel ++;
  82.     warn "[$msglevel]:&send($object, $method, @_)";
  83.     }
  84.     if ($object !~ /^operl_/o) {
  85.         warn "no such object:" . $object . "\n";
  86.     $msglevel -- if $main'msgtrace != 0;
  87.         return -1;
  88.     }
  89.     $class =  $myclass{$object};
  90.  
  91.     while (index($methods{$class}, "$method:") < 0) {
  92.     if ($class eq 'root') {
  93.         warn "unknown message:" . $method . "\n";
  94.         $msglevel -- if $main'msgtrace != 0;
  95.             return undef;
  96.         }
  97.         $class = $superclass{$class}; # chain to super class
  98.     }
  99.     $xyz = "$class'$method"; # subroutine to be invoked
  100.     $result = do $xyz($object, @_);   # subroutine call
  101.     print $@ . "\n" unless $@ eq '';
  102.     if ($main'msgtrace != 0) {
  103.     warn " ==> " . (($result eq undef) ? 'undef' : $result) . "\n";
  104.     $msglevel --;
  105.     }
  106.     $result;
  107. }
  108.  
  109. #
  110. # &dumpclass()
  111. #
  112. sub main'dumpclass {
  113.     while (($key, $val) = each %superclass) {
  114.     print $key . " is a subclass of " . $val . "\n";
  115.     }
  116. }
  117.  
  118. #
  119. # important built-in : 'root' class
  120. #
  121. $superclass{'root'} = 'root';     # 'root' is the super class of itself.
  122. &main'defmethod('root', 'init', ''); # do nothing
  123. &main'defmethod('root', 'class',
  124. q!
  125.     $operl'myclass{$self};
  126.  !);
  127. &main'defmethod('root', 'show_parents',
  128. q!  local($class) = $operl'myclass{$self};
  129.     while ($class ne 'root') {
  130.     print $class . " -> ";
  131.         $class = $operl'superclass{$class}; # chain to the super class
  132.     }
  133.     print "root\n";
  134.  !);
  135. &main'defmethod('root', 'show_self',
  136. q!    print "class:" . $operl'myclass{$self} . "\n";
  137.       print "methods:" . $operl'methods{$operl'myclass{$self}} . "\n";
  138.       &main'dumpvar($self);
  139.  !); # self dump
  140.  
  141. 1;
  142.