ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.81 by root, Tue Nov 7 17:38:22 2006 UTC vs.
Revision 1.93 by root, Thu Dec 21 22:41:35 2006 UTC

… …
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 17$YAML::Syck::ImplicitUnicode = 1;
18 18
19use strict; 19use strict;
20 20
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
21_init_vars; 27_init_vars;
22 28
23our %COMMAND = ();
24our @EVENT; 29our @EVENT;
25our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
26 31
27our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
28our $TICK_WATCHER; 33our $TICK_WATCHER;
29our $NEXT_TICK; 34our $NEXT_TICK;
30 35
31our %CFG; 36our %CFG;
32 37
33our $uptime; 38our $UPTIME; $UPTIME ||= time;
34
35$uptime ||= time;
36 39
37############################################################################# 40#############################################################################
38 41
39=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
40 43
41=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
42 49
43=item $cf::LIBDIR 50=item $cf::LIBDIR
44 51
45The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
46be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
67 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
68 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
69 }; 76 };
70} 77}
71 78
79@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
80@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
81@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
82@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
83@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
72@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
73 85
74# we bless all objects into (empty) derived classes to force a method lookup 86# we bless all objects into (empty) derived classes to force a method lookup
75# within the Safe compartment. 87# within the Safe compartment.
76for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 88for my $pkg (qw(
89 cf::global
90 cf::object cf::object::player
91 cf::client cf::player
92 cf::arch cf::living
93 cf::map cf::party cf::region
94)) {
77 no strict 'refs'; 95 no strict 'refs';
78 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 96 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
79} 97}
80 98
81$Event::DIED = sub { 99$Event::DIED = sub {
… …
83}; 101};
84 102
85my %ext_pkg; 103my %ext_pkg;
86my @exts; 104my @exts;
87my @hook; 105my @hook;
88my %command;
89my %extcmd;
90 106
91=head2 UTILITY FUNCTIONS 107=head2 UTILITY FUNCTIONS
92 108
93=over 4 109=over 4
94 110
… …
122 138
123=cut 139=cut
124 140
125############################################################################# 141#############################################################################
126 142
127=head2 EVENTS AND OBJECT ATTACHMENTS 143=head2 ATTACHABLE OBJECTS
144
145You can define and attach attachments to each "attachable" object in
146crossfire+ (objects, players, clients, maps and the special "global"
147class). In the following description, CLASS can be any of C<global>,
148C<object> C<player>, C<client> or C<map>.
128 149
129=over 4 150=over 4
130 151
131=item $object->attach ($attachment, key => $value...) 152=item cf::CLASS::attachment $name, ...
132 153
133=item $object->detach ($attachment) 154Register an attachment by name through which attachable objects can refer
155to this attachment.
134 156
135Attach/detach a pre-registered attachment to an object.
136
137=item $player->attach ($attachment, key => $value...)
138
139=item $player->detach ($attachment)
140
141Attach/detach a pre-registered attachment to a player.
142
143=item $map->attach ($attachment, key => $value...)
144
145=item $map->detach ($attachment)
146
147Attach/detach a pre-registered attachment to a map.
148
149=item $bool = $object->attached ($name)
150
151=item $bool = $player->attached ($name)
152
153=item $bool = $map->attached ($name) 157=item $bool = $attachable->attached ($name)
154 158
155Checks wether the named attachment is currently attached to the object. 159Checks wether the named attachment is currently attached to the object.
156 160
157=item cf::attach_global ... 161=item $attachable->attach ($attachment, key => $value...)
158 162
159Attach handlers for global events. 163=item $attachable->detach ($attachment)
160 164
161This and all following C<attach_*>-functions expect any number of the 165Attach/detach a pre-registered attachment either to a specific object
162following handler/hook descriptions: 166(C<$attachable>) or all objects of the given class (if C<$attachable> is a
167class in a static method call).
168
169You can attach to global events by using the C<cf::global> class.
170
171These method calls expect any number of the following handler/hook
172descriptions:
163 173
164=over 4 174=over 4
165 175
166=item prio => $number 176=item prio => $number
167 177
… …
169by another C<prio> setting). Lower priority handlers get executed 179by another C<prio> setting). Lower priority handlers get executed
170earlier. The default priority is C<0>, and many built-in handlers are 180earlier. The default priority is C<0>, and many built-in handlers are
171registered at priority C<-1000>, so lower priorities should not be used 181registered at priority C<-1000>, so lower priorities should not be used
172unless you know what you are doing. 182unless you know what you are doing.
173 183
184=item type => $type
185
186(Only for C<< cf::object->attach >> calls), limits the attachment to the
187given type of objects only (the additional parameter C<subtype> can be
188used to further limit to the given subtype).
189
174=item on_I<event> => \&cb 190=item on_I<event> => \&cb
175 191
176Call the given code reference whenever the named event happens (event is 192Call the given code reference whenever the named event happens (event is
177something like C<instantiate>, C<apply>, C<use_skill> and so on, and which 193something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
178handlers are recognised generally depends on the type of object these 194handlers are recognised generally depends on the type of object these
… …
187package and register them. Only handlers for eevents supported by the 203package and register them. Only handlers for eevents supported by the
188object/class are recognised. 204object/class are recognised.
189 205
190=back 206=back
191 207
192=item cf::attach_to_type $object_type, $subtype, ...
193
194Attach handlers for a specific object type (e.g. TRANSPORT) and
195subtype. If C<$subtype> is zero or undef, matches all objects of the given
196type.
197
198=item cf::attach_to_objects ...
199
200Attach handlers to all objects. Do not use this except for debugging or
201very rare events, as handlers are (obviously) called for I<all> objects in
202the game.
203
204=item cf::attach_to_players ...
205
206Attach handlers to all players.
207
208=item cf::attach_to_maps ...
209
210Attach handlers to all maps.
211
212=item cf:register_attachment $name, ...
213
214Register an attachment by name through which objects can refer to this
215attachment.
216
217=item cf:register_player_attachment $name, ...
218
219Register an attachment by name through which players can refer to this
220attachment.
221
222=item cf:register_map_attachment $name, ...
223
224Register an attachment by name through which maps can refer to this
225attachment.
226
227=cut 208=cut
228 209
229# the following variables are defined in .xs and must not be re-created 210# the following variables are defined in .xs and must not be re-created
230our @CB_GLOBAL = (); # registry for all global events 211our @CB_GLOBAL = (); # registry for all global events
231our @CB_OBJECT = (); # all objects (should not be used except in emergency) 212our @CB_OBJECT = (); # all objects (should not be used except in emergency)
232our @CB_PLAYER = (); 213our @CB_PLAYER = ();
214our @CB_CLIENT = ();
233our @CB_TYPE = (); # registry for type (cf-object class) based events 215our @CB_TYPE = (); # registry for type (cf-object class) based events
234our @CB_MAP = (); 216our @CB_MAP = ();
235 217
236my %attachment; 218my %attachment;
237 219
238sub _attach_cb($\%$$$) { 220sub _attach_cb($$$$) {
239 my ($registry, $undo, $event, $prio, $cb) = @_; 221 my ($registry, $event, $prio, $cb) = @_;
240 222
241 use sort 'stable'; 223 use sort 'stable';
242 224
243 $cb = [$prio, $cb]; 225 $cb = [$prio, $cb];
244 226
245 @{$registry->[$event]} = sort 227 @{$registry->[$event]} = sort
246 { $a->[0] cmp $b->[0] } 228 { $a->[0] cmp $b->[0] }
247 @{$registry->[$event] || []}, $cb; 229 @{$registry->[$event] || []}, $cb;
248
249 push @{$undo->{cb}}, [$event, $cb];
250} 230}
251 231
252# attach handles attaching event callbacks 232# attach handles attaching event callbacks
253# the only thing the caller has to do is pass the correct 233# the only thing the caller has to do is pass the correct
254# registry (== where the callback attaches to). 234# registry (== where the callback attaches to).
255sub _attach(\@$@) { 235sub _attach {
256 my ($registry, $klass, @arg) = @_; 236 my ($registry, $klass, @arg) = @_;
257 237
238 my $object_type;
258 my $prio = 0; 239 my $prio = 0;
259
260 my %undo = (
261 registry => $registry,
262 cb => [],
263 );
264
265 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 240 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
266 241
267 while (@arg) { 242 while (@arg) {
268 my $type = shift @arg; 243 my $type = shift @arg;
269 244
270 if ($type eq "prio") { 245 if ($type eq "prio") {
271 $prio = shift @arg; 246 $prio = shift @arg;
272 247
248 } elsif ($type eq "type") {
249 $object_type = shift @arg;
250 $registry = $CB_TYPE[$object_type] ||= [];
251
252 } elsif ($type eq "subtype") {
253 defined $object_type or Carp::croak "subtype specified without type";
254 my $object_subtype = shift @arg;
255 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
256
273 } elsif ($type eq "package") { 257 } elsif ($type eq "package") {
274 my $pkg = shift @arg; 258 my $pkg = shift @arg;
275 259
276 while (my ($name, $id) = each %cb_id) { 260 while (my ($name, $id) = each %cb_id) {
277 if (my $cb = $pkg->can ($name)) { 261 if (my $cb = $pkg->can ($name)) {
278 _attach_cb $registry, %undo, $id, $prio, $cb; 262 _attach_cb $registry, $id, $prio, $cb;
279 } 263 }
280 } 264 }
281 265
282 } elsif (exists $cb_id{$type}) { 266 } elsif (exists $cb_id{$type}) {
283 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 267 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
284 268
285 } elsif (ref $type) { 269 } elsif (ref $type) {
286 warn "attaching objects not supported, ignoring.\n"; 270 warn "attaching objects not supported, ignoring.\n";
287 271
288 } else { 272 } else {
289 shift @arg; 273 shift @arg;
290 warn "attach argument '$type' not supported, ignoring.\n"; 274 warn "attach argument '$type' not supported, ignoring.\n";
291 } 275 }
292 } 276 }
293
294 \%undo
295} 277}
296 278
297sub _attach_attachment { 279sub _object_attach {
298 my ($obj, $name, %arg) = @_; 280 my ($obj, $name, %arg) = @_;
299 281
300 return if exists $obj->{_attachment}{$name}; 282 return if exists $obj->{_attachment}{$name};
301
302 my $res;
303 283
304 if (my $attach = $attachment{$name}) { 284 if (my $attach = $attachment{$name}) {
305 my $registry = $obj->registry; 285 my $registry = $obj->registry;
306 286
307 for (@$attach) { 287 for (@$attach) {
308 my ($klass, @attach) = @$_; 288 my ($klass, @attach) = @$_;
309 $res = _attach @$registry, $klass, @attach; 289 _attach $registry, $klass, @attach;
310 } 290 }
311 291
312 $obj->{$name} = \%arg; 292 $obj->{$name} = \%arg;
313 } else { 293 } else {
314 warn "object uses attachment '$name' that is not available, postponing.\n"; 294 warn "object uses attachment '$name' that is not available, postponing.\n";
315 } 295 }
316 296
317 $obj->{_attachment}{$name} = undef; 297 $obj->{_attachment}{$name} = undef;
318
319 $res->{attachment} = $name;
320 $res
321} 298}
322 299
323*cf::object::attach = 300sub cf::attachable::attach {
324*cf::player::attach = 301 if (ref $_[0]) {
325*cf::map::attach = sub { 302 _object_attach @_;
326 my ($obj, $name, %arg) = @_; 303 } else {
327 304 _attach shift->_attach_registry, @_;
328 _attach_attachment $obj, $name, %arg; 305 }
329}; 306};
330 307
331# all those should be optimised 308# all those should be optimised
332*cf::object::detach = 309sub cf::attachable::detach {
333*cf::player::detach =
334*cf::map::detach = sub {
335 my ($obj, $name) = @_; 310 my ($obj, $name) = @_;
336 311
312 if (ref $obj) {
337 delete $obj->{_attachment}{$name}; 313 delete $obj->{_attachment}{$name};
338 reattach ($obj); 314 reattach ($obj);
315 } else {
316 Carp::croak "cannot, currently, detach class attachments";
317 }
339}; 318};
340 319
341*cf::object::attached = 320sub cf::attachable::attached {
342*cf::player::attached =
343*cf::map::attached = sub {
344 my ($obj, $name) = @_; 321 my ($obj, $name) = @_;
345 322
346 exists $obj->{_attachment}{$name} 323 exists $obj->{_attachment}{$name}
347};
348
349sub attach_global {
350 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
351} 324}
352 325
353sub attach_to_type { 326for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
354 my $type = shift; 327 eval "#line " . __LINE__ . " 'cf.pm'
355 my $subtype = shift; 328 sub cf::\L$klass\E::_attach_registry {
329 (\\\@CB_$klass, KLASS_$klass)
330 }
356 331
357 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_ 332 sub cf::\L$klass\E::attachment {
358}
359
360sub attach_to_objects {
361 _attach @CB_OBJECT, KLASS_OBJECT, @_
362}
363
364sub attach_to_players {
365 _attach @CB_PLAYER, KLASS_PLAYER, @_
366}
367
368sub attach_to_maps {
369 _attach @CB_MAP, KLASS_MAP, @_
370}
371
372sub register_attachment {
373 my $name = shift; 333 my \$name = shift;
374 334
375 $attachment{$name} = [[KLASS_OBJECT, @_]];
376}
377
378sub register_player_attachment {
379 my $name = shift;
380
381 $attachment{$name} = [[KLASS_PLAYER, @_]];
382}
383
384sub register_map_attachment {
385 my $name = shift;
386
387 $attachment{$name} = [[KLASS_MAP, @_]]; 335 \$attachment{\$name} = [[KLASS_$klass, \@_]];
336 }
337 ";
338 die if $@;
388} 339}
389 340
390our $override; 341our $override;
391our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 342our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
392 343
… …
422 373
423=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 374=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
424 375
425=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 376=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
426 377
378=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
379
427=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 380=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
428 381
429Generate a global/object/player/map-specific event with the given arguments. 382Generate a global/object/player/map-specific event with the given arguments.
430 383
431This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 384This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
… …
436 389
437=cut 390=cut
438 391
439############################################################################# 392#############################################################################
440 393
441=head2 METHODS VALID FOR ALL CORE OBJECTS 394=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
395
396Attachable objects includes objects, players, clients and maps.
442 397
443=over 4 398=over 4
444 399
445=item $object->valid, $player->valid, $map->valid 400=item $object->valid
446 401
447Just because you have a perl object does not mean that the corresponding 402Just because you have a perl object does not mean that the corresponding
448C-level object still exists. If you try to access an object that has no 403C-level object still exists. If you try to access an object that has no
449valid C counterpart anymore you get an exception at runtime. This method 404valid C counterpart anymore you get an exception at runtime. This method
450can be used to test for existence of the C object part without causing an 405can be used to test for existence of the C object part without causing an
… …
452 407
453=back 408=back
454 409
455=cut 410=cut
456 411
457*cf::object::valid =
458*cf::player::valid =
459*cf::map::valid = \&cf::_valid;
460
461############################################################################# 412#############################################################################
462# object support 413# object support
463 414
464sub instantiate { 415sub instantiate {
465 my ($obj, $data) = @_; 416 my ($obj, $data) = @_;
… …
484 435
485 for my $name (keys %{ $obj->{_attachment} || {} }) { 436 for my $name (keys %{ $obj->{_attachment} || {} }) {
486 if (my $attach = $attachment{$name}) { 437 if (my $attach = $attachment{$name}) {
487 for (@$attach) { 438 for (@$attach) {
488 my ($klass, @attach) = @$_; 439 my ($klass, @attach) = @$_;
489 _attach @$registry, $klass, @attach; 440 _attach $registry, $klass, @attach;
490 } 441 }
491 } else { 442 } else {
492 warn "object uses attachment '$name' that is not available, postponing.\n"; 443 warn "object uses attachment '$name' that is not available, postponing.\n";
493 } 444 }
494 } 445 }
… …
550 } 501 }
551 502
552 () 503 ()
553} 504}
554 505
555attach_to_objects 506cf::object->attach (
556 prio => -1000000, 507 prio => -1000000,
557 on_clone => sub { 508 on_clone => sub {
558 my ($src, $dst) = @_; 509 my ($src, $dst) = @_;
559 510
560 @{$dst->registry} = @{$src->registry}; 511 @{$dst->registry} = @{$src->registry};
… …
562 %$dst = %$src; 513 %$dst = %$src;
563 514
564 %{$dst->{_attachment}} = %{$src->{_attachment}} 515 %{$dst->{_attachment}} = %{$src->{_attachment}}
565 if exists $src->{_attachment}; 516 if exists $src->{_attachment};
566 }, 517 },
567; 518);
568 519
569############################################################################# 520#############################################################################
570# old plug-in events 521# command handling &c
571 522
572sub inject_event { 523=item cf::register_command $name => \&callback($ob,$args);
573 my $extension = shift;
574 my $event_code = shift;
575 524
576 my $cb = $hook[$event_code]{$extension} 525Register a callback for execution when the client sends the user command
577 or return; 526$name.
578 527
579 &$cb 528=cut
580}
581
582sub inject_global_event {
583 my $event = shift;
584
585 my $cb = $hook[$event]
586 or return;
587
588 List::Util::max map &$_, values %$cb
589}
590
591sub inject_command {
592 my ($name, $obj, $params) = @_;
593
594 for my $cmd (@{ $command{$name} }) {
595 $cmd->[1]->($obj, $params);
596 }
597
598 -1
599}
600 529
601sub register_command { 530sub register_command {
602 my ($name, $time, $cb) = @_; 531 my ($name, $cb) = @_;
603 532
604 my $caller = caller; 533 my $caller = caller;
605 #warn "registering command '$name/$time' to '$caller'"; 534 #warn "registering command '$name/$time' to '$caller'";
606 535
607 push @{ $command{$name} }, [$time, $cb, $caller]; 536 push @{ $COMMAND{$name} }, [$caller, $cb];
608 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
609} 537}
538
539=item cf::register_extcmd $name => \&callback($pl,$packet);
540
541Register a callbackf ro execution when the client sends an extcmd packet.
542
543If the callback returns something, it is sent back as if reply was being
544called.
545
546=cut
610 547
611sub register_extcmd { 548sub register_extcmd {
612 my ($name, $cb) = @_; 549 my ($name, $cb) = @_;
613 550
614 my $caller = caller; 551 my $caller = caller;
615 #warn "registering extcmd '$name' to '$caller'"; 552 #warn "registering extcmd '$name' to '$caller'";
616 553
617 $extcmd{$name} = [$cb, $caller]; 554 $EXTCMD{$name} = [$cb, $caller];
618} 555}
556
557cf::player->attach (
558 on_command => sub {
559 my ($pl, $name, $params) = @_;
560
561 my $cb = $COMMAND{$name}
562 or return;
563
564 for my $cmd (@$cb) {
565 $cmd->[1]->($pl->ob, $params);
566 }
567
568 cf::override;
569 },
570 on_extcmd => sub {
571 my ($pl, $buf) = @_;
572
573 my $msg = eval { from_json $buf };
574
575 if (ref $msg) {
576 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
577 if (my %reply = $cb->[0]->($pl, $msg)) {
578 $pl->ext_reply ($msg->{msgid}, %reply);
579 }
580 }
581 } else {
582 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
583 }
584
585 cf::override;
586 },
587);
619 588
620sub register { 589sub register {
621 my ($base, $pkg) = @_; 590 my ($base, $pkg) = @_;
622 591
623 #TODO 592 #TODO
… …
642 . "#line 1 \"$path\"\n{\n" 611 . "#line 1 \"$path\"\n{\n"
643 . (do { local $/; <$fh> }) 612 . (do { local $/; <$fh> })
644 . "\n};\n1"; 613 . "\n};\n1";
645 614
646 eval $source 615 eval $source
647 or die "$path: $@"; 616 or die $@ ? "$path: $@\n"
617 : "extension disabled.\n";
648 618
649 push @exts, $pkg; 619 push @exts, $pkg;
650 $ext_pkg{$base} = $pkg; 620 $ext_pkg{$base} = $pkg;
651 621
652# no strict 'refs'; 622# no strict 'refs';
… …
665# for my $idx (0 .. $#PLUGIN_EVENT) { 635# for my $idx (0 .. $#PLUGIN_EVENT) {
666# delete $hook[$idx]{$pkg}; 636# delete $hook[$idx]{$pkg};
667# } 637# }
668 638
669 # remove commands 639 # remove commands
670 for my $name (keys %command) { 640 for my $name (keys %COMMAND) {
671 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 641 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
672 642
673 if (@cb) { 643 if (@cb) {
674 $command{$name} = \@cb; 644 $COMMAND{$name} = \@cb;
675 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
676 } else { 645 } else {
677 delete $command{$name};
678 delete $COMMAND{"$name\000"}; 646 delete $COMMAND{$name};
679 } 647 }
680 } 648 }
681 649
682 # remove extcmds 650 # remove extcmds
683 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 651 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
684 delete $extcmd{$name}; 652 delete $EXTCMD{$name};
685 } 653 }
686 654
687 if (my $cb = $pkg->can ("unload")) { 655 if (my $cb = $pkg->can ("unload")) {
688 eval { 656 eval {
689 $cb->($pkg); 657 $cb->($pkg);
… …
693 661
694 Symbol::delete_package $pkg; 662 Symbol::delete_package $pkg;
695} 663}
696 664
697sub load_extensions { 665sub load_extensions {
698 my $LIBDIR = maps_directory "perl";
699
700 for my $ext (<$LIBDIR/*.ext>) { 666 for my $ext (<$LIBDIR/*.ext>) {
701 next unless -r $ext; 667 next unless -r $ext;
702 eval { 668 eval {
703 load_extension $ext; 669 load_extension $ext;
704 1 670 1
705 } or warn "$ext not loaded: $@"; 671 } or warn "$ext not loaded: $@";
706 } 672 }
707} 673}
708 674
709############################################################################# 675#############################################################################
710# extcmd framework, basically convert ext <msg>
711# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
712
713attach_to_players
714 on_extcmd => sub {
715 my ($pl, $buf) = @_;
716
717 my $msg = eval { from_json $buf };
718
719 if (ref $msg) {
720 if (my $cb = $extcmd{$msg->{msgtype}}) {
721 if (my %reply = $cb->[0]->($pl, $msg)) {
722 $pl->ext_reply ($msg->{msgid}, %reply);
723 }
724 }
725 } else {
726 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
727 }
728
729 cf::override;
730 },
731;
732
733#############################################################################
734# load/save/clean perl data associated with a map 676# load/save/clean perl data associated with a map
735 677
736*cf::mapsupport::on_clean = sub { 678*cf::mapsupport::on_clean = sub {
737 my ($map) = @_; 679 my ($map) = @_;
738 680
… …
740 defined $path or return; 682 defined $path or return;
741 683
742 unlink "$path.pst"; 684 unlink "$path.pst";
743}; 685};
744 686
745attach_to_maps prio => -10000, package => cf::mapsupport::; 687cf::map->attach (prio => -10000, package => cf::mapsupport::);
746 688
747############################################################################# 689#############################################################################
748# load/save perl data associated with player->ob objects 690# load/save perl data associated with player->ob objects
749 691
750sub all_objects(@) { 692sub all_objects(@) {
751 @_, map all_objects ($_->inv), @_ 693 @_, map all_objects ($_->inv), @_
752} 694}
753 695
754# TODO: compatibility cruft, remove when no longer needed 696# TODO: compatibility cruft, remove when no longer needed
755attach_to_players 697cf::player->attach (
756 on_load => sub { 698 on_load => sub {
757 my ($pl, $path) = @_; 699 my ($pl, $path) = @_;
758 700
759 for my $o (all_objects $pl->ob) { 701 for my $o (all_objects $pl->ob) {
760 if (my $value = $o->get_ob_key_value ("_perl_data")) { 702 if (my $value = $o->get_ob_key_value ("_perl_data")) {
… …
762 704
763 %$o = %{ Storable::thaw pack "H*", $value }; 705 %$o = %{ Storable::thaw pack "H*", $value };
764 } 706 }
765 } 707 }
766 }, 708 },
767; 709);
768 710
769############################################################################# 711#############################################################################
770 712
771=head2 CORE EXTENSIONS 713=head2 CORE EXTENSIONS
772 714
… …
863 805
864=pod 806=pod
865 807
866The following fucntions and emthods are available within a safe environment: 808The following fucntions and emthods are available within a safe environment:
867 809
868 cf::object contr pay_amount pay_player 810 cf::object contr pay_amount pay_player map
869 cf::object::player player 811 cf::object::player player
870 cf::player peaceful 812 cf::player peaceful
813 cf::map trigger
871 814
872=cut 815=cut
873 816
874for ( 817for (
875 ["cf::object" => qw(contr pay_amount pay_player)], 818 ["cf::object" => qw(contr pay_amount pay_player map)],
876 ["cf::object::player" => qw(player)], 819 ["cf::object::player" => qw(player)],
877 ["cf::player" => qw(peaceful)], 820 ["cf::player" => qw(peaceful)],
821 ["cf::map" => qw(trigger)],
878) { 822) {
879 no strict 'refs'; 823 no strict 'refs';
880 my ($pkg, @funs) = @$_; 824 my ($pkg, @funs) = @$_;
881 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 825 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
882 for @funs; 826 for @funs;
… …
1022 sub db_sync() { 966 sub db_sync() {
1023 db_save if $dirty; 967 db_save if $dirty;
1024 undef $dirty; 968 undef $dirty;
1025 } 969 }
1026 970
1027 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 971 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1028 db_sync; 972 db_sync;
1029 }); 973 });
1030 974
1031 sub db_dirty() { 975 sub db_dirty() {
1032 $dirty = 1; 976 $dirty = 1;
… …
1046 $DB->{$_[0]} = $_[1]; 990 $DB->{$_[0]} = $_[1];
1047 } 991 }
1048 db_dirty; 992 db_dirty;
1049 } 993 }
1050 994
1051 attach_global 995 cf::global->attach (
1052 prio => 10000, 996 prio => 10000,
1053 on_cleanup => sub { 997 on_cleanup => sub {
1054 db_sync; 998 db_sync;
1055 }, 999 },
1056 ; 1000 );
1057} 1001}
1058 1002
1059############################################################################# 1003#############################################################################
1060# the server's main() 1004# the server's main()
1061 1005
… …
1082 1026
1083 $msg->("reloading..."); 1027 $msg->("reloading...");
1084 1028
1085 eval { 1029 eval {
1086 # cancel all watchers 1030 # cancel all watchers
1087 $_->cancel for Event::all_watchers; 1031 for (Event::all_watchers) {
1032 $_->cancel if $_->data & WF_AUTOCANCEL;
1033 }
1088 1034
1089 # unload all extensions 1035 # unload all extensions
1090 for (@exts) { 1036 for (@exts) {
1091 $msg->("unloading <$_>"); 1037 $msg->("unloading <$_>");
1092 unload_extension $_; 1038 unload_extension $_;
… …
1152 warn $_[0]; 1098 warn $_[0];
1153 print "$_[0]\n"; 1099 print "$_[0]\n";
1154 }; 1100 };
1155} 1101}
1156 1102
1103register "<global>", __PACKAGE__;
1104
1157register_command "perl-reload", 0, sub { 1105register_command "perl-reload" => sub {
1158 my ($who, $arg) = @_; 1106 my ($who, $arg) = @_;
1159 1107
1160 if ($who->flag (FLAG_WIZ)) { 1108 if ($who->flag (FLAG_WIZ)) {
1161 _perl_reload { 1109 _perl_reload {
1162 warn $_[0]; 1110 warn $_[0];
1163 $who->message ($_[0]); 1111 $who->message ($_[0]);
1164 }; 1112 };
1165 } 1113 }
1166}; 1114};
1167 1115
1168register "<global>", __PACKAGE__;
1169
1170unshift @INC, $LIBDIR; 1116unshift @INC, $LIBDIR;
1171 1117
1172$TICK_WATCHER = Event->timer ( 1118$TICK_WATCHER = Event->timer (
1173 prio => 1, 1119 prio => 0,
1174 async => 1,
1175 at => $NEXT_TICK || 1, 1120 at => $NEXT_TICK || 1,
1121 data => WF_AUTOCANCEL,
1176 cb => sub { 1122 cb => sub {
1177 cf::server_tick; # one server iteration 1123 cf::server_tick; # one server iteration
1178 1124
1179 my $NOW = Event::time; 1125 my $NOW = Event::time;
1180 $NEXT_TICK += $TICK; 1126 $NEXT_TICK += $TICK;
… …
1190IO::AIO::max_poll_time $TICK * 0.2; 1136IO::AIO::max_poll_time $TICK * 0.2;
1191 1137
1192Event->io (fd => IO::AIO::poll_fileno, 1138Event->io (fd => IO::AIO::poll_fileno,
1193 poll => 'r', 1139 poll => 'r',
1194 prio => 5, 1140 prio => 5,
1141 data => WF_AUTOCANCEL,
1195 cb => \&IO::AIO::poll_cb); 1142 cb => \&IO::AIO::poll_cb);
1196 1143
11971 11441
1198 1145

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines