Path: tut.cis.ohio-state.edu!pacific.mps.ohio-state.edu!linac!uwm.edu!cs.utexas.edu!uunet!sraco1!sakoh
From: sakoh@sraco2.us.sra.co.jp (Hiroshi &)
Newsgroups: comp.lang.perl
#Subject: Re: operl - an experimental object-oriented package for perl
Message-ID: <SAKOH.91Feb22170457@sraco2.us.sra.co.jp>
Date: 22 Feb 91 08:04:57 GMT
References: <SAKOH.91Feb21092426@sraco2.us.sra.co.jp> <123551@uunet.UU.NET>
Sender: usenet@sraco1.us.sra.CO.JP
Organization: Software Research Associates, Inc. Boulder Lab.
Lines: 451
In-reply-to: rbj@uunet.UU.NET's message of 22 Feb 91 02:41:36 GMT
in article <123551@uunet.UU.NET>
rbj@uunet.UU.NET (Root Boy Jim) wrote:
>>Why, pray tell, does source code contain unprintables?
>>
>>Like C and postscript, perl makes it possible to represent
>>unprintables by using \ escapes. It is bad form to do otherwise.
Actually ,the formerly posted source code contains portion like : q^A ... q^A
(where ^A represents control-A) for some reason.
I dont't think we can use q\001 ... q\001 instead.
But you are right. That nuisance should be avoided as much as possible.
Here I recode and repost my submission.
There are no unprintable characters now.
Thank you for your advice.
* I don't want to claim that we should incorporate
* OO features into perl itself.
* I've just present this package as a tiny proof of flexibility of perl
* and for fun :-)
Hiroshi Sakoh
sakoh@sra.co.jp or uunet!sraco1!sakoh
---<cut here>-----------------------------------------------
#/bin/sh
# This is a shell archive. Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by sraco2! on Fri Feb 22 00:58:00 MST 1991
# Contents: bag.pl operl.pl point.pl set.pl stack.pl sample1 sample2 sample3
# sample4 sample5 sample6
echo x - bag.pl
sed 's/^@//' > "bag.pl" <<'@//E*O*F bag.pl//'
#/usr/bin/perl
require 'operl.pl';
&defclass ('bag','root');
&defmethod('bag','put', '$elements{$_[0]}++;');
&defmethod('bag','how_many', '$elements{$_[0]};');
&defmethod('bag','kinds', 'keys(%elements);');
&defmethod('bag','delete',
'delete $elements{$_[0]} if --$elements{$_[0]} <= 0;');
&defmethod('bag','has', 'defined($elements{$_[0]})');
&defmethod('bag','size', 'foreach $n (%elements) {$sum += $n;};$sum;');
&defmethod('bag','dump',
'while (($key, $val) = each %elements) {print "$key = $val\n";}');
1;
@//E*O*F bag.pl//
chmod u=r,g=r,o=r bag.pl
echo x - operl.pl
sed 's/^@//' > "operl.pl" <<'@//E*O*F operl.pl//'
#/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;
@//E*O*F operl.pl//
chmod u=rw,g=r,o=r operl.pl
echo x - point.pl
sed 's/^@//' > "point.pl" <<'@//E*O*F point.pl//'
#/usr/bin/perl
require 'operl.pl';
&defclass ('point','root');
&defmethod('point','init',
'$xx = defined($_[0]) ? $_[0] : 0; $yy = defined($_[1]) ? $_[1] : 0;');
&defmethod('point','move',
'$xx = defined($_[0]) ? $_[0] : $xx; $yy = defined($_[1]) ? $_[1] : $yy;');
&defmethod('point','movex', '$xx = defined($_[0]) ? $_[0] : $xx;');
&defmethod('point','movey', '$yy = defined($_[0]) ? $_[0] : $yy;');
&defmethod('point','rmove',
'$xx += defined($_[0]) ? $_[0] : 0; $yy += defined($_[1]) ? $_[1] : 0;');
&defmethod('point','rmovex', '$xx += defined($_[0]) ? $_[0] : 0;');
&defmethod('point','rmovey', '$yy += defined($_[0]) ? $_[0] : 0;');
&defmethod('point','x', '$xx;');
&defmethod('point','y', '$yy;');
1;
@//E*O*F point.pl//
chmod u=r,g=r,o=r point.pl
echo x - set.pl
sed 's/^@//' > "set.pl" <<'@//E*O*F set.pl//'
#/usr/bin/perl
require 'bag.pl';
&defclass ('set','bag');
&defmethod('set','put', '$elements{$_[0]}=1;');
&defmethod('set','size', 'length(%elements);');
1;
@//E*O*F set.pl//
chmod u=r,g=r,o=r set.pl
echo x - stack.pl
sed 's/^@//' > "stack.pl" <<'@//E*O*F stack.pl//'
#/usr/bin/perl
require 'operl.pl';
&defclass ('stack','root');
&defmethod('stack','init','$inx = 0');
&defmethod('stack','push','$stk[$inx++] = $_[0];');
&defmethod('stack','pop',
'warn "warn: empty stack.\n" if ($inx <= 0);$inx -- if $inx > 0;');
&defmethod('stack','top',
'warn "warn: empty stack.\n" if ($inx <= 0);$stk[$inx - 1]');
&defmethod('stack','length','$inx;');
&defmethod('stack','dump','foreach $item (@stk) {print "(" . $item . ")\n";}');
1;
@//E*O*F stack.pl//
chmod u=r,g=r,o=r stack.pl
echo x - sample1
sed 's/^@//' > "sample1" <<'@//E*O*F sample1//'
#/usr/bin/perl
require 'operl.pl';
&defclass('hello', 'root');
&defclass('hehe', 'hello');
&defclass('fufu', 'hehe');
&dumpclass();
@//E*O*F sample1//
chmod u=rwx,g=rwx,o=rx sample1
echo x - sample2
sed 's/^@//' > "sample2" <<'@//E*O*F sample2//'
#/usr/bin/perl
require 'operl.pl';
# define new class 'hello' as subclass of 'root'
&defclass ('hello', 'root');
# 'init' method will be invoked on creating an object
&defmethod('hello', 'init', '$i = 0;');
# method 'add1' adds 1 to $i
&defmethod('hello', 'add1', '$i++;');
# method 'show' shows the value of $i
&defmethod('hello', 'show', 'print "-> " . $i . "\n";');
$o1 = &newobject('hello');
$o2 = &newobject('hello');
print "first object=" . $o1 . "\n";
print "second object=" . $o2 . "\n";
print "Apply several operations on $o1\n";
&send($o1, 'add1');
&send($o1, 'show');
&send($o1, 'add1');
&send($o1, 'show');
&send($o1, 'add1');
&send($o1, 'show');
&send($o1, 'add1');
&send($o1, 'show');
print "See? There is no change in $o2\n";
&send($o2, 'show');
&dumpclass();
@//E*O*F sample2//
chmod u=rwx,g=rwx,o=rx sample2
echo x - sample3
sed 's/^@//' > "sample3" <<'@//E*O*F sample3//'
#/usr/bin/perl
require 'set.pl';
$set1 = &newobject('set'); # Elements can't duplicate in set class
$bag1 = &newobject('bag'); # Elements can duplicate in bag class
print "** set **\n";
&send($set1, 'put', 'banana');
&send($set1, 'put', 'apple');
&send($set1, 'put', 'orange');
&send($set1, 'put', 'orange');
&send($set1, 'put', 'orange');
print "Orange Total=" . &send($set1, 'how_many', 'orange') . "\n";
&send($set1, 'dump');
&send($set1, 'show_self');
&send($set1, 'delete', 'orange');
print "Orange Total=" . &send($set1, 'how_many', 'orange') . "\n";
&send($set1, 'dump');
&send($set1, 'show_self');
print "** bag **\n";
&send($bag1, 'put', 'banana');
&send($bag1, 'put', 'apple');
&send($bag1, 'put', 'orange');
&send($bag1, 'put', 'orange');
&send($bag1, 'put', 'orange');
print "Orange Total=" . &send($bag1, 'how_many', 'orange') . "\n";
&send($bag1, 'dump');
&send($bag1, 'show_self');
&send($bag1, 'delete', 'orange');
print "Orange Total=" . &send($bag1, 'how_many', 'orange') . "\n";
&send($bag1, 'dump');
&send($bag1, 'show_self');
@//E*O*F sample3//
chmod u=rwx,g=rwx,o=rx sample3
echo x - sample4
sed 's/^@//' > "sample4" <<'@//E*O*F sample4//'
#/usr/bin/perl
require 'stack.pl';
# create two instances of class 'stack'
$s1 = &newobject('stack');
$s2 = &newobject('stack');
# push items onto stack $s1
&send($s1, 'push', 10);
&send($s1, 'push', 20);
&send($s1, 'push', 30);
print "top of stack 1=" . &send($s1, 'top') . "\n";
print "--- dump of stack 1 ---\n";
&send($s1, 'dump');
&send($s2, 'push', 'Hello, world.');
print "top of stack 2=" . &send($s2, 'top') . "\n";
print "--- show me ---\n";
&send($s1, 'show_self');
print "--- show me ---\n";
&send($s2, 'show_self');
&send($s1, 'pop');
print "top of stack 1=" . &send($s1, 'top') . "\n";
&send($s1, 'pop');
print "top of stack 1=" . &send($s1, 'top') . "\n";
&send($s1, 'pop');
print "top of stack 1=" . &send($s1, 'top') . "\n";
@//E*O*F sample4//
chmod u=rwx,g=rwx,o=rx sample4
echo x - sample5
sed 's/^@//' > "sample5" <<'@//E*O*F sample5//'
#/usr/bin/perl
require 'point.pl';
$msgtrace = 1; # message trace on
# create a point @ (10, 20) ... see 'init' method
$p1 = &newobject('point', 10, 20);
&send($p1, 'show_self');
&send($p1, 'move', 100, 100);
&send($p1, 'show_self');
&send($p1, 'rmove', 20, 20);
&send($p1, 'show_self');
@//E*O*F sample5//
chmod u=rwx,g=rwx,o=rx sample5
echo x - sample6
sed 's/^@//' > "sample6" <<'@//E*O*F sample6//'
#/usr/bin/perl
require 'operl.pl';
# define new class 'hello' as subclass of 'root'
&defclass ('hello', 'root');
# 'init' method will be invoked on creating an object
&defmethod('hello', 'init', '$i = 0;');
# method 'add1' adds 1 to $i
&defmethod('hello', 'add1', '$i++;');
# method 'show' shows the value of $i
&defmethod('hello', 'show', 'print "-> " . $i . "\n";');
# define new class 'hello2' as subclass of 'hello'
&defclass ('hello2', 'hello');
# method 'add2' adds 2 to itself (send add1 to self twice)
# you can refer to the current object as $self
&defmethod('hello', 'add2', <<'METHOD' );
&main'send($self, 'add1');
&main'send($self, 'add1');
METHOD
$o1 = &newobject('hello2');
&send($o1, 'show');
&send($o1, 'add2');
&send($o1, 'show');
@//E*O*F sample6//
chmod u=rwx,g=rwx,o=rx sample6
exit 0
--
sakoh@sra.co.jp
"Whereof one cannot speak, thereof one must remain silent." ---Wittgenstein
"Sometimes noise is significant." ---William Hewlett