Path: tut.cis.ohio-state.edu!pacific.mps.ohio-state.edu!linac!uwm.edu!cs.utexas.edu!uunet!sraco1!sakoh
From: [email protected] (Hiroshi &)
Newsgroups: comp.lang.perl
#Subject: Re: operl - an experimental object-oriented package for perl
Message-ID: <[email protected]>
Date: 22 Feb 91 08:04:57 GMT
References: <[email protected]> <[email protected]>
Sender: [email protected]
Organization: Software Research Associates, Inc. Boulder Lab.
Lines: 451
In-reply-to: [email protected]'s message of 22 Feb 91 02:41:36 GMT


in article <[email protected]>
       [email protected] (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
[email protected] 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
--
[email protected]
"Whereof one cannot speak, thereof one must remain silent."  ---Wittgenstein
"Sometimes noise is significant."                            ---William Hewlett

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.