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.99 by root, Sat Dec 23 05:25:35 2006 UTC vs.
Revision 1.100 by root, Mon Dec 25 11:25:49 2006 UTC

… …
31 31
32our %COMMAND = (); 32our %COMMAND = ();
33our %COMMAND_TIME = (); 33our %COMMAND_TIME = ();
34our %EXTCMD = (); 34our %EXTCMD = ();
35 35
36_init_vars;
37
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;
42our $TICK_WATCHER; 40our $TICK_WATCHER;
… …
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 { 459cf::attachable->attach (
460 prio => -1000000,
461 on_instantiate => sub {
453 my ($obj, $data) = @_; 462 my ($obj, $data) = @_;
454 463
455 $data = from_json $data; 464 $data = from_json $data;
456 465
457 for (@$data) { 466 for (@$data) {
458 my ($name, $args) = @$_; 467 my ($name, $args) = @$_;
459 468
460 $obj->attach ($name, %{$args || {} }); 469 $obj->attach ($name, %{$args || {} });
470 }
461 } 471 },
462} 472 on_reattach => sub {
463
464# basically do the same as instantiate, without calling instantiate 473 # basically do the same as instantiate, without calling instantiate
465sub reattach {
466 my ($obj) = @_; 474 my ($obj) = @_;
467 my $registry = $obj->registry; 475 my $registry = $obj->registry;
468 476
469 @$registry = (); 477 @$registry = ();
470 478
471 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 479 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
472 480
473 for my $name (keys %{ $obj->{_attachment} || {} }) { 481 for my $name (keys %{ $obj->{_attachment} || {} }) {
474 if (my $attach = $attachment{$name}) { 482 if (my $attach = $attachment{$name}) {
475 for (@$attach) { 483 for (@$attach) {
476 my ($klass, @attach) = @$_; 484 my ($klass, @attach) = @$_;
477 _attach $registry, $klass, @attach; 485 _attach $registry, $klass, @attach;
486 }
487 } else {
488 warn "object uses attachment '$name' that is not available, postponing.\n";
478 } 489 }
479 } else {
480 warn "object uses attachment '$name' that is not available, postponing.\n";
481 } 490 }
482 } 491 },
483} 492 on_clone => sub {
493 my ($src, $dst) = @_;
494
495 @{$dst->registry} = @{$src->registry};
496
497 %$dst = %$src;
498
499 %{$dst->{_attachment}} = %{$src->{_attachment}}
500 if exists $src->{_attachment};
501 },
502);
484 503
485sub object_freezer_save { 504sub object_freezer_save {
486 my ($filename, $rdata, $objs) = @_; 505 my ($filename, $rdata, $objs) = @_;
487 506
488 if (length $$rdata) { 507 if (length $$rdata) {
… …
537 return ($data, $av); 556 return ($data, $av);
538 } 557 }
539 558
540 () 559 ()
541} 560}
542
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 561
557############################################################################# 562#############################################################################
558# command handling &c 563# command handling &c
559 564
560=item cf::register_command $name => \&callback($ob,$args); 565=item cf::register_command $name => \&callback($ob,$args);
… …
1216 #Symbol::delete_package __PACKAGE__; 1221 #Symbol::delete_package __PACKAGE__;
1217 1222
1218 # reload cf.pm 1223 # reload cf.pm
1219 $msg->("reloading cf.pm"); 1224 $msg->("reloading cf.pm");
1220 require cf; 1225 require cf;
1226 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1227
1221 1228
1222 # load config and database again 1229 # load config and database again
1223 cf::cfg_load; 1230 cf::cfg_load;
1224 cf::db_load; 1231 cf::db_load;
1225 1232

Diff Legend

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