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

… …
14use Coro::Event; 14use Coro::Event;
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18 18
19use IO::AIO; 19use IO::AIO 2.3;
20use YAML::Syck (); 20use YAML::Syck ();
21use Time::HiRes; 21use Time::HiRes;
22 22
23use Event; $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
24 24
… …
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 31
32our %COMMAND = (); 32our %COMMAND = ();
33our %COMMAND_TIME = (); 33our %COMMAND_TIME = ();
34our %EXTCMD = (); 34our %EXTCMD = ();
35
36_init_vars;
37 35
38our @EVENT; 36our @EVENT;
39our $LIBDIR = datadir . "/ext"; 37our $LIBDIR = datadir . "/ext";
40 38
41our $TICK = MAX_TIME * 1e-6; 39our $TICK = MAX_TIME * 1e-6;
… …
93@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 91@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
94 92
95# 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
96# within the Safe compartment. 94# within the Safe compartment.
97for my $pkg (qw( 95for my $pkg (qw(
98 cf::global 96 cf::global cf::attachable
99 cf::object cf::object::player 97 cf::object cf::object::player
100 cf::client cf::player 98 cf::client cf::player
101 cf::arch cf::living 99 cf::arch cf::living
102 cf::map cf::party cf::region 100 cf::map cf::party cf::region
103)) { 101)) {
… …
269exception. 267exception.
270 268
271=cut 269=cut
272 270
273# 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
274our @CB_GLOBAL = (); # registry for all global events 272our @CB_GLOBAL = (); # registry for all global events
273our @CB_ATTACHABLE = (); # registry for all attachables
275our @CB_OBJECT = (); # all objects (should not be used except in emergency) 274our @CB_OBJECT = (); # all objects (should not be used except in emergency)
276our @CB_PLAYER = (); 275our @CB_PLAYER = ();
277our @CB_CLIENT = (); 276our @CB_CLIENT = ();
278our @CB_TYPE = (); # registry for type (cf-object class) based events 277our @CB_TYPE = (); # registry for type (cf-object class) based events
279our @CB_MAP = (); 278our @CB_MAP = ();
280 279
281my %attachment; 280my %attachment;
282 281
283sub _attach_cb($$$$) { 282sub _attach_cb($$$$) {
284 my ($registry, $event, $prio, $cb) = @_; 283 my ($registry, $event, $prio, $cb) = @_;
… …
289 288
290 @{$registry->[$event]} = sort 289 @{$registry->[$event]} = sort
291 { $a->[0] cmp $b->[0] } 290 { $a->[0] cmp $b->[0] }
292 @{$registry->[$event] || []}, $cb; 291 @{$registry->[$event] || []}, $cb;
293} 292}
293
294# hack
295my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
294 296
295# attach handles attaching event callbacks 297# attach handles attaching event callbacks
296# 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
297# registry (== where the callback attaches to). 299# registry (== where the callback attaches to).
298sub _attach { 300sub _attach {
… …
300 302
301 my $object_type; 303 my $object_type;
302 my $prio = 0; 304 my $prio = 0;
303 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;
304 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
305 while (@arg) { 312 while (@arg) {
306 my $type = shift @arg; 313 my $type = shift @arg;
307 314
308 if ($type eq "prio") { 315 if ($type eq "prio") {
309 $prio = shift @arg; 316 $prio = shift @arg;
… …
384 my ($obj, $name) = @_; 391 my ($obj, $name) = @_;
385 392
386 exists $obj->{_attachment}{$name} 393 exists $obj->{_attachment}{$name}
387} 394}
388 395
389for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 396for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
390 eval "#line " . __LINE__ . " 'cf.pm' 397 eval "#line " . __LINE__ . " 'cf.pm'
391 sub cf::\L$klass\E::_attach_registry { 398 sub cf::\L$klass\E::_attach_registry {
392 (\\\@CB_$klass, KLASS_$klass) 399 (\\\@CB_$klass, KLASS_$klass)
393 } 400 }
394 401
… …
447=cut 454=cut
448 455
449############################################################################# 456#############################################################################
450# object support 457# object support
451 458
452sub instantiate {
453 my ($obj, $data) = @_;
454
455 $data = from_json $data;
456
457 for (@$data) {
458 my ($name, $args) = @$_;
459
460 $obj->attach ($name, %{$args || {} });
461 }
462}
463
464# basically do the same as instantiate, without calling instantiate
465sub reattach { 459sub reattach {
460 # basically do the same as instantiate, without calling instantiate
466 my ($obj) = @_; 461 my ($obj) = @_;
462
467 my $registry = $obj->registry; 463 my $registry = $obj->registry;
468 464
469 @$registry = (); 465 @$registry = ();
470 466
471 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 467 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
480 warn "object uses attachment '$name' that is not available, postponing.\n"; 476 warn "object uses attachment '$name' that is not available, postponing.\n";
481 } 477 }
482 } 478 }
483} 479}
484 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
485sub object_freezer_save { 507sub object_freezer_save {
486 my ($filename, $rdata, $objs) = @_; 508 my ($filename, $rdata, $objs) = @_;
487 509
488 if (length $$rdata) { 510 if (length $$rdata) {
489 warn sprintf "saving %s (%d,%d)\n", 511 warn sprintf "saving %s (%d,%d)\n",
… …
538 } 560 }
539 561
540 () 562 ()
541} 563}
542 564
543cf::object->attach (
544 prio => -1000000,
545 on_clone => sub {
546 my ($src, $dst) = @_;
547
548 @{$dst->registry} = @{$src->registry};
549
550 %$dst = %$src;
551
552 %{$dst->{_attachment}} = %{$src->{_attachment}}
553 if exists $src->{_attachment};
554 },
555);
556
557############################################################################# 565#############################################################################
558# command handling &c 566# command handling &c
559 567
560=item cf::register_command $name => \&callback($ob,$args); 568=item cf::register_command $name => \&callback($ob,$args);
561 569
… …
886 894
887 if (@{ $ns->{query_queue} } == @$queue) { 895 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 896 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 897 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 898 } else {
891 $ns->state (ST_PLAYING); 899 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 900 }
893 } 901 }
894 }, 902 },
895); 903);
896 904
… …
1216 #Symbol::delete_package __PACKAGE__; 1224 #Symbol::delete_package __PACKAGE__;
1217 1225
1218 # reload cf.pm 1226 # reload cf.pm
1219 $msg->("reloading cf.pm"); 1227 $msg->("reloading cf.pm");
1220 require cf; 1228 require cf;
1229 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1221 1230
1222 # load config and database again 1231 # load config and database again
1223 cf::cfg_load; 1232 cf::cfg_load;
1224 cf::db_load; 1233 cf::db_load;
1225 1234

Diff Legend

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