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.95 by root, Fri Dec 22 02:04:20 2006 UTC vs.
Revision 1.102 by root, Wed Dec 27 15:20:54 2006 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18
10use IO::AIO (); 19use IO::AIO 2.3;
11use YAML::Syck (); 20use YAML::Syck ();
12use Time::HiRes; 21use Time::HiRes;
13use Event; 22
14$Event::Eval = 1; # no idea why this is required, but it is 23use Event; $Event::Eval = 1; # no idea why this is required, but it is
15 24
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 26$YAML::Syck::ImplicitUnicode = 1;
18 27
19use strict; 28$Coro::main->prio (Coro::PRIO_MIN);
20 29
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22 31
23our %COMMAND = (); 32our %COMMAND = ();
24our %COMMAND_TIME = (); 33our %COMMAND_TIME = ();
25our %EXTCMD = (); 34our %EXTCMD = ();
26
27_init_vars;
28 35
29our @EVENT; 36our @EVENT;
30our $LIBDIR = datadir . "/ext"; 37our $LIBDIR = datadir . "/ext";
31 38
32our $TICK = MAX_TIME * 1e-6; 39our $TICK = MAX_TIME * 1e-6;
… …
84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 91@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
85 92
86# we bless all objects into (empty) derived classes to force a method lookup 93# we bless all objects into (empty) derived classes to force a method lookup
87# within the Safe compartment. 94# within the Safe compartment.
88for my $pkg (qw( 95for my $pkg (qw(
89 cf::global 96 cf::global cf::attachable
90 cf::object cf::object::player 97 cf::object cf::object::player
91 cf::client cf::player 98 cf::client cf::player
92 cf::arch cf::living 99 cf::arch cf::living
93 cf::map cf::party cf::region 100 cf::map cf::party cf::region
94)) { 101)) {
… …
249 my ($self, $victim) = @_; 256 my ($self, $victim) = @_;
250 ... 257 ...
251 } 258 }
252 } 259 }
253 260
261=item $attachable->valid
262
263Just because you have a perl object does not mean that the corresponding
264C-level object still exists. If you try to access an object that has no
265valid C counterpart anymore you get an exception at runtime. This method
266can be used to test for existence of the C object part without causing an
267exception.
268
254=cut 269=cut
255 270
256# the following variables are defined in .xs and must not be re-created 271# the following variables are defined in .xs and must not be re-created
257our @CB_GLOBAL = (); # registry for all global events 272our @CB_GLOBAL = (); # registry for all global events
273our @CB_ATTACHABLE = (); # registry for all attachables
258our @CB_OBJECT = (); # all objects (should not be used except in emergency) 274our @CB_OBJECT = (); # all objects (should not be used except in emergency)
259our @CB_PLAYER = (); 275our @CB_PLAYER = ();
260our @CB_CLIENT = (); 276our @CB_CLIENT = ();
261our @CB_TYPE = (); # registry for type (cf-object class) based events 277our @CB_TYPE = (); # registry for type (cf-object class) based events
262our @CB_MAP = (); 278our @CB_MAP = ();
263 279
264my %attachment; 280my %attachment;
265 281
266sub _attach_cb($$$$) { 282sub _attach_cb($$$$) {
267 my ($registry, $event, $prio, $cb) = @_; 283 my ($registry, $event, $prio, $cb) = @_;
… …
272 288
273 @{$registry->[$event]} = sort 289 @{$registry->[$event]} = sort
274 { $a->[0] cmp $b->[0] } 290 { $a->[0] cmp $b->[0] }
275 @{$registry->[$event] || []}, $cb; 291 @{$registry->[$event] || []}, $cb;
276} 292}
293
294# hack
295my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
277 296
278# attach handles attaching event callbacks 297# attach handles attaching event callbacks
279# the only thing the caller has to do is pass the correct 298# the only thing the caller has to do is pass the correct
280# registry (== where the callback attaches to). 299# registry (== where the callback attaches to).
281sub _attach { 300sub _attach {
… …
283 302
284 my $object_type; 303 my $object_type;
285 my $prio = 0; 304 my $prio = 0;
286 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 305 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
287 306
307 #TODO: get rid of this hack
308 if ($attachable_klass{$klass}) {
309 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
310 }
311
288 while (@arg) { 312 while (@arg) {
289 my $type = shift @arg; 313 my $type = shift @arg;
290 314
291 if ($type eq "prio") { 315 if ($type eq "prio") {
292 $prio = shift @arg; 316 $prio = shift @arg;
… …
367 my ($obj, $name) = @_; 391 my ($obj, $name) = @_;
368 392
369 exists $obj->{_attachment}{$name} 393 exists $obj->{_attachment}{$name}
370} 394}
371 395
372for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 396for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
373 eval "#line " . __LINE__ . " 'cf.pm' 397 eval "#line " . __LINE__ . " 'cf.pm'
374 sub cf::\L$klass\E::_attach_registry { 398 sub cf::\L$klass\E::_attach_registry {
375 (\\\@CB_$klass, KLASS_$klass) 399 (\\\@CB_$klass, KLASS_$klass)
376 } 400 }
377 401
… …
413 } 437 }
414 438
415 0 439 0
416} 440}
417 441
418=item $bool = cf::invoke EVENT_GLOBAL_XXX, ... 442=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
419 443
420=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
421
422=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
423
424=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...) 444=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
425 445
426=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
427
428Generate a global/object/player/map-specific event with the given arguments. 446Generate an object-specific event with the given arguments.
429 447
430This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 448This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
431removed in future versions), and there is no public API to access override 449removed in future versions), and there is no public API to access override
432results (if you must, access C<@cf::invoke_results> directly). 450results (if you must, access C<@cf::invoke_results> directly).
433 451
434=back 452=back
435 453
436=cut 454=cut
437 455
438############################################################################# 456#############################################################################
439
440=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
441
442Attachable objects includes objects, players, clients and maps.
443
444=over 4
445
446=item $object->valid
447
448Just because you have a perl object does not mean that the corresponding
449C-level object still exists. If you try to access an object that has no
450valid C counterpart anymore you get an exception at runtime. This method
451can be used to test for existence of the C object part without causing an
452exception.
453
454=back
455
456=cut
457
458#############################################################################
459# object support 457# object support
460 458
461sub instantiate {
462 my ($obj, $data) = @_;
463
464 $data = from_json $data;
465
466 for (@$data) {
467 my ($name, $args) = @$_;
468
469 $obj->attach ($name, %{$args || {} });
470 }
471}
472
473# basically do the same as instantiate, without calling instantiate
474sub reattach { 459sub reattach {
460 # basically do the same as instantiate, without calling instantiate
475 my ($obj) = @_; 461 my ($obj) = @_;
462
476 my $registry = $obj->registry; 463 my $registry = $obj->registry;
477 464
478 @$registry = (); 465 @$registry = ();
479 466
480 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 467 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
489 warn "object uses attachment '$name' that is not available, postponing.\n"; 476 warn "object uses attachment '$name' that is not available, postponing.\n";
490 } 477 }
491 } 478 }
492} 479}
493 480
481cf::attachable->attach (
482 prio => -1000000,
483 on_instantiate => sub {
484 my ($obj, $data) = @_;
485
486 $data = from_json $data;
487
488 for (@$data) {
489 my ($name, $args) = @$_;
490
491 $obj->attach ($name, %{$args || {} });
492 }
493 },
494 on_reattach => \&reattach,
495 on_clone => sub {
496 my ($src, $dst) = @_;
497
498 @{$dst->registry} = @{$src->registry};
499
500 %$dst = %$src;
501
502 %{$dst->{_attachment}} = %{$src->{_attachment}}
503 if exists $src->{_attachment};
504 },
505);
506
494sub object_freezer_save { 507sub object_freezer_save {
495 my ($filename, $rdata, $objs) = @_; 508 my ($filename, $rdata, $objs) = @_;
496 509
497 if (length $$rdata) { 510 if (length $$rdata) {
498 warn sprintf "saving %s (%d,%d)\n", 511 warn sprintf "saving %s (%d,%d)\n",
… …
547 } 560 }
548 561
549 () 562 ()
550} 563}
551 564
552cf::object->attach (
553 prio => -1000000,
554 on_clone => sub {
555 my ($src, $dst) = @_;
556
557 @{$dst->registry} = @{$src->registry};
558
559 %$dst = %$src;
560
561 %{$dst->{_attachment}} = %{$src->{_attachment}}
562 if exists $src->{_attachment};
563 },
564);
565
566############################################################################# 565#############################################################################
567# command handling &c 566# command handling &c
568 567
569=item cf::register_command $name => \&callback($ob,$args); 568=item cf::register_command $name => \&callback($ob,$args);
570 569
… …
895 894
896 if (@{ $ns->{query_queue} } == @$queue) { 895 if (@{ $ns->{query_queue} } == @$queue) {
897 if (@$queue) { 896 if (@$queue) {
898 $ns->send_packet ($ns->{query_queue}[0][0]); 897 $ns->send_packet ($ns->{query_queue}[0][0]);
899 } else { 898 } else {
900 $ns->state (ST_PLAYING); 899 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
901 } 900 }
902 } 901 }
902 },
903);
904
905=item $client->coro (\&cb)
906
907Create a new coroutine, running the specified callback. The coroutine will
908be automatically cancelled when the client gets destroyed (e.g. on logout,
909or loss of connection).
910
911=cut
912
913sub cf::client::coro {
914 my ($self, $cb) = @_;
915
916 my $coro; $coro = async {
917 eval {
918 $cb->();
919 };
920 warn $@ if $@;
921 delete $self->{_coro}{$coro+0};
922 };
923
924 $self->{_coro}{$coro+0} = $coro;
925}
926
927cf::client->attach (
928 on_destroy => sub {
929 my ($ns) = @_;
930
931 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
903 }, 932 },
904); 933);
905 934
906=back 935=back
907 936
… …
1195 #Symbol::delete_package __PACKAGE__; 1224 #Symbol::delete_package __PACKAGE__;
1196 1225
1197 # reload cf.pm 1226 # reload cf.pm
1198 $msg->("reloading cf.pm"); 1227 $msg->("reloading cf.pm");
1199 require cf; 1228 require cf;
1229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1200 1230
1201 # load config and database again 1231 # load config and database again
1202 cf::cfg_load; 1232 cf::cfg_load;
1203 cf::db_load; 1233 cf::db_load;
1204 1234

Diff Legend

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