1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
# A person who can *gasp* execute perl code in the moo! (In a Safe.)
package Programmer;
use strict;
use vars qw(@ISA);
use Builder;
use Safe;
use Verb;
use Error;
use VerbCall;
use Method;
use UNIVERSAL qw(isa);
@ISA=qw{Builder};
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
# Set up a protected space for running perl commands in.
my $compartment=Safe->new;
$compartment->permit_only(qw{:default entereval rand});
$compartment->share_from('UNIVERSAL',['can']);
my $this = Builder::new($class,
compartment => $compartment,
@_
);
bless ($this, $class);
return $this;
}
# Immediatly run code in the moo.
sub verb_eval {
my $this=shift;
my $verbcall=shift;
my $text=$verbcall->command;
$text=~s/^\s*\w+\s+//; # remove command.
$text=~s/[\r\n]//g; # have to handle both types of line endings.
# FIXME: ugly hack, using these globals.
$Programmer::me=$this;
$Programmer::location=$this->location;
$this->compartment->share(qw{$location $me});
undef *_; # paranoia, this gets into the safe otherwise.
return $this->compartment->reval($text), $@;
}
# Add a verb to an object.
sub verb_teach {
my $this=shift;
my $verbcall=shift;
if (! $verbcall->direct_object) {
return Error->new("Teach what?");
}
my $command = $verbcall->word('indirect_object');
if (! $command) {
return Error->new("Must specify a command to teach it.");
}
my @words=$verbcall->words;
my $ret=$verbcall->direct_object->addverb(Verb->new(
'sub' => "verb_${command}_safe",
command => $command,
direct_object => $words[4],
preposition => $words[5],
indirect_object => $words[6],
));
if (Error::iserror($ret)) {
return $ret;
}
else {
return $verbcall->direct_object->name." can now $command.";
}
}
# Add code for a verb to an object.
sub verb_verbcode {
my $this=shift;
my $verbcall=shift;
return $this->verb_code($verbcall,1);
}
# Add code for a method to an object.
sub verb_code {
my $this=shift;
my $verbcall=shift;
my $isverb=shift; # pass something true here if you want it to be forced to be a verb.
if (! $verbcall->direct_object) {
return Error->new("Must specify an object.");
}
my $command=$verbcall->word('preposition');
if (!$command) {
return Error->new("Must specify a command.");
}
my $code=$verbcall->word('indirect_object');
# Null code is ok, I guess.
my $methods=$verbcall->direct_object->methods;
my %methods;
if (ref($methods) eq 'HASH') {
%methods=%{$methods};
}
$methods{"verb_".$command."_safe"} = Method->new(
owner => $this,
'sub' => ($isverb ? "verb" : "")."verb_${command}_safe",
code => "$code",
);
my $ret=$verbcall->direct_object->methods(\%methods);
if (Error::iserror($ret)) {
return $ret;
}
else {
return "Code added.";
}
}
# Remove a method from an object.
sub verb_codedel {
my $this=shift;
my $verbcall=shift;
my $isverb=shift; # pass something true here if you want it to be forced to be a verb.
if (! $verbcall->direct_object) {
return Error->new("Must specify an object.");
}
my $command=$verbcall->word('preposition');
if (!$command) {
return Error->new("Must specify a method.");
}
my $methods=$verbcall->direct_object->methods;
my %methods;
if (ref($methods) eq 'HASH') {
%methods=%{$methods};
}
if (delete $methods{($isverb ? "verb_" : "").$verbcall->word('preposition')} eq undef) {
return Error->new("That object does not define a method named \"".$verbcall->word('preposition')."\".");
}
my $ret=$verbcall->direct_object->methods(\%methods);
if (Error::iserror($ret)) {
return $ret;
}
else {
return "Method deleted.";
}
}
# Remove a verb (method definition and prototype) from an object.
sub verb_verbdel {
my $this=shift;
my $verbcall=shift;
if (! $verbcall->direct_object) {
return Error->new("Must specify an object.");
}
my $command=$verbcall->word('preposition');
if (!$command) {
return Error->new("Must specify a verb.");
}
my $ret=$verbcall->direct_object->removeverb($verbcall->word('preposition'));
if (!$ret) {
return Error->new("Unable to remove verb definition.");
}
my $ret=$this->verb_codedel($verbcall,1);
if (Error::iserror($ret)) {
return "Deleting verb defintion: success.",
"Deleting verb code: ".$ret->message;
}
else {
return "Deleting verb defintion: success.",
"Deleting verb code: success.";
}
}
1
|
