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.86 by root, Thu Dec 14 05:09:32 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
21our %COMMAND = (); 23our %COMMAND = ();
22our %COMMAND_TIME = (); 24our %COMMAND_TIME = ();
23our %EXTCMD = (); 25our %EXTCMD = ();
24 26
25_init_vars; 27_init_vars;
26 28
27our @EVENT; 29our @EVENT;
28our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
29 31
30our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
31our $TICK_WATCHER; 33our $TICK_WATCHER;
32our $NEXT_TICK; 34our $NEXT_TICK;
33 35
… …
72 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
73 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
74 }; 76 };
75} 77}
76 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';
77@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 84@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
78 85
79# 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
80# within the Safe compartment. 87# within the Safe compartment.
81for my $pkg (qw( 88for my $pkg (qw(
89 cf::global
82 cf::object cf::object::player 90 cf::object cf::object::player
83 cf::client_socket cf::player 91 cf::client cf::player
84 cf::arch cf::living 92 cf::arch cf::living
85 cf::map cf::party cf::region 93 cf::map cf::party cf::region
86)) { 94)) {
87 no strict 'refs'; 95 no strict 'refs';
88 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 96 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
… …
130 138
131=cut 139=cut
132 140
133############################################################################# 141#############################################################################
134 142
135=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>.
136 149
137=over 4 150=over 4
138 151
139=item $object->attach ($attachment, key => $value...) 152=item cf::CLASS::attachment $name, ...
140 153
141=item $object->detach ($attachment) 154Register an attachment by name through which attachable objects can refer
155to this attachment.
142 156
143Attach/detach a pre-registered attachment to an object.
144
145=item $player->attach ($attachment, key => $value...)
146
147=item $player->detach ($attachment)
148
149Attach/detach a pre-registered attachment to a player.
150
151=item $map->attach ($attachment, key => $value...)
152
153=item $map->detach ($attachment)
154
155Attach/detach a pre-registered attachment to a map.
156
157=item $bool = $object->attached ($name)
158
159=item $bool = $player->attached ($name)
160
161=item $bool = $map->attached ($name) 157=item $bool = $attachable->attached ($name)
162 158
163Checks wether the named attachment is currently attached to the object. 159Checks wether the named attachment is currently attached to the object.
164 160
165=item cf::attach_global ... 161=item $attachable->attach ($attachment, key => $value...)
166 162
167Attach handlers for global events. 163=item $attachable->detach ($attachment)
168 164
169This and all following C<attach_*>-functions expect any number of the 165Attach/detach a pre-registered attachment either to a specific object
170following 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:
171 173
172=over 4 174=over 4
173 175
174=item prio => $number 176=item prio => $number
175 177
… …
177by another C<prio> setting). Lower priority handlers get executed 179by another C<prio> setting). Lower priority handlers get executed
178earlier. 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
179registered at priority C<-1000>, so lower priorities should not be used 181registered at priority C<-1000>, so lower priorities should not be used
180unless you know what you are doing. 182unless you know what you are doing.
181 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
182=item on_I<event> => \&cb 190=item on_I<event> => \&cb
183 191
184Call the given code reference whenever the named event happens (event is 192Call the given code reference whenever the named event happens (event is
185something 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
186handlers are recognised generally depends on the type of object these 194handlers are recognised generally depends on the type of object these
… …
195package and register them. Only handlers for eevents supported by the 203package and register them. Only handlers for eevents supported by the
196object/class are recognised. 204object/class are recognised.
197 205
198=back 206=back
199 207
200=item cf::attach_to_type $object_type, $subtype, ...
201
202Attach handlers for a specific object type (e.g. TRANSPORT) and
203subtype. If C<$subtype> is zero or undef, matches all objects of the given
204type.
205
206=item cf::attach_to_objects ...
207
208Attach handlers to all objects. Do not use this except for debugging or
209very rare events, as handlers are (obviously) called for I<all> objects in
210the game.
211
212=item cf::attach_to_players ...
213
214Attach handlers to all players.
215
216=item cf::attach_to_maps ...
217
218Attach handlers to all maps.
219
220=item cf:register_attachment $name, ...
221
222Register an attachment by name through which objects can refer to this
223attachment.
224
225=item cf:register_player_attachment $name, ...
226
227Register an attachment by name through which players can refer to this
228attachment.
229
230=item cf:register_map_attachment $name, ...
231
232Register an attachment by name through which maps can refer to this
233attachment.
234
235=cut 208=cut
236 209
237# 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
238our @CB_GLOBAL = (); # registry for all global events 211our @CB_GLOBAL = (); # registry for all global events
239our @CB_OBJECT = (); # all objects (should not be used except in emergency) 212our @CB_OBJECT = (); # all objects (should not be used except in emergency)
240our @CB_PLAYER = (); 213our @CB_PLAYER = ();
214our @CB_CLIENT = ();
241our @CB_TYPE = (); # registry for type (cf-object class) based events 215our @CB_TYPE = (); # registry for type (cf-object class) based events
242our @CB_MAP = (); 216our @CB_MAP = ();
243 217
244my %attachment; 218my %attachment;
245 219
246sub _attach_cb($\%$$$) { 220sub _attach_cb($$$$) {
247 my ($registry, $undo, $event, $prio, $cb) = @_; 221 my ($registry, $event, $prio, $cb) = @_;
248 222
249 use sort 'stable'; 223 use sort 'stable';
250 224
251 $cb = [$prio, $cb]; 225 $cb = [$prio, $cb];
252 226
253 @{$registry->[$event]} = sort 227 @{$registry->[$event]} = sort
254 { $a->[0] cmp $b->[0] } 228 { $a->[0] cmp $b->[0] }
255 @{$registry->[$event] || []}, $cb; 229 @{$registry->[$event] || []}, $cb;
256
257 push @{$undo->{cb}}, [$event, $cb];
258} 230}
259 231
260# attach handles attaching event callbacks 232# attach handles attaching event callbacks
261# 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
262# registry (== where the callback attaches to). 234# registry (== where the callback attaches to).
263sub _attach(\@$@) { 235sub _attach {
264 my ($registry, $klass, @arg) = @_; 236 my ($registry, $klass, @arg) = @_;
265 237
238 my $object_type;
266 my $prio = 0; 239 my $prio = 0;
267
268 my %undo = (
269 registry => $registry,
270 cb => [],
271 );
272
273 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;
274 241
275 while (@arg) { 242 while (@arg) {
276 my $type = shift @arg; 243 my $type = shift @arg;
277 244
278 if ($type eq "prio") { 245 if ($type eq "prio") {
279 $prio = shift @arg; 246 $prio = shift @arg;
280 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
281 } elsif ($type eq "package") { 257 } elsif ($type eq "package") {
282 my $pkg = shift @arg; 258 my $pkg = shift @arg;
283 259
284 while (my ($name, $id) = each %cb_id) { 260 while (my ($name, $id) = each %cb_id) {
285 if (my $cb = $pkg->can ($name)) { 261 if (my $cb = $pkg->can ($name)) {
286 _attach_cb $registry, %undo, $id, $prio, $cb; 262 _attach_cb $registry, $id, $prio, $cb;
287 } 263 }
288 } 264 }
289 265
290 } elsif (exists $cb_id{$type}) { 266 } elsif (exists $cb_id{$type}) {
291 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @arg; 267 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
292 268
293 } elsif (ref $type) { 269 } elsif (ref $type) {
294 warn "attaching objects not supported, ignoring.\n"; 270 warn "attaching objects not supported, ignoring.\n";
295 271
296 } else { 272 } else {
297 shift @arg; 273 shift @arg;
298 warn "attach argument '$type' not supported, ignoring.\n"; 274 warn "attach argument '$type' not supported, ignoring.\n";
299 } 275 }
300 } 276 }
301
302 \%undo
303} 277}
304 278
305sub _attach_attachment { 279sub _object_attach {
306 my ($obj, $name, %arg) = @_; 280 my ($obj, $name, %arg) = @_;
307 281
308 return if exists $obj->{_attachment}{$name}; 282 return if exists $obj->{_attachment}{$name};
309
310 my $res;
311 283
312 if (my $attach = $attachment{$name}) { 284 if (my $attach = $attachment{$name}) {
313 my $registry = $obj->registry; 285 my $registry = $obj->registry;
314 286
315 for (@$attach) { 287 for (@$attach) {
316 my ($klass, @attach) = @$_; 288 my ($klass, @attach) = @$_;
317 $res = _attach @$registry, $klass, @attach; 289 _attach $registry, $klass, @attach;
318 } 290 }
319 291
320 $obj->{$name} = \%arg; 292 $obj->{$name} = \%arg;
321 } else { 293 } else {
322 warn "object uses attachment '$name' that is not available, postponing.\n"; 294 warn "object uses attachment '$name' that is not available, postponing.\n";
323 } 295 }
324 296
325 $obj->{_attachment}{$name} = undef; 297 $obj->{_attachment}{$name} = undef;
326
327 $res->{attachment} = $name;
328 $res
329} 298}
330 299
331*cf::object::attach = 300sub cf::attachable::attach {
332*cf::player::attach = 301 if (ref $_[0]) {
333*cf::map::attach = sub { 302 _object_attach @_;
334 my ($obj, $name, %arg) = @_; 303 } else {
335 304 _attach shift->_attach_registry, @_;
336 _attach_attachment $obj, $name, %arg; 305 }
337}; 306};
338 307
339# all those should be optimised 308# all those should be optimised
340*cf::object::detach = 309sub cf::attachable::detach {
341*cf::player::detach =
342*cf::map::detach = sub {
343 my ($obj, $name) = @_; 310 my ($obj, $name) = @_;
344 311
312 if (ref $obj) {
345 delete $obj->{_attachment}{$name}; 313 delete $obj->{_attachment}{$name};
346 reattach ($obj); 314 reattach ($obj);
315 } else {
316 Carp::croak "cannot, currently, detach class attachments";
317 }
347}; 318};
348 319
349*cf::object::attached = 320sub cf::attachable::attached {
350*cf::player::attached =
351*cf::map::attached = sub {
352 my ($obj, $name) = @_; 321 my ($obj, $name) = @_;
353 322
354 exists $obj->{_attachment}{$name} 323 exists $obj->{_attachment}{$name}
355};
356
357sub attach_global {
358 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
359} 324}
360 325
361sub attach_to_type { 326for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) {
362 my $type = shift; 327 eval "#line " . __LINE__ . " 'cf.pm'
363 my $subtype = shift; 328 sub cf::\L$klass\E::_attach_registry {
329 (\\\@CB_$klass, KLASS_$klass)
330 }
364 331
365 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_ 332 sub cf::\L$klass\E::attachment {
366}
367
368sub attach_to_objects {
369 _attach @CB_OBJECT, KLASS_OBJECT, @_
370}
371
372sub attach_to_players {
373 _attach @CB_PLAYER, KLASS_PLAYER, @_
374}
375
376sub attach_to_maps {
377 _attach @CB_MAP, KLASS_MAP, @_
378}
379
380sub register_attachment {
381 my $name = shift; 333 my \$name = shift;
382 334
383 $attachment{$name} = [[KLASS_OBJECT, @_]];
384}
385
386sub register_player_attachment {
387 my $name = shift;
388
389 $attachment{$name} = [[KLASS_PLAYER, @_]];
390}
391
392sub register_map_attachment {
393 my $name = shift;
394
395 $attachment{$name} = [[KLASS_MAP, @_]]; 335 \$attachment{\$name} = [[KLASS_$klass, \@_]];
336 }
337 ";
338 die if $@;
396} 339}
397 340
398our $override; 341our $override;
399our @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?
400 343
… …
430 373
431=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 374=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
432 375
433=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 376=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
434 377
378=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
379
435=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 380=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
436 381
437Generate a global/object/player/map-specific event with the given arguments. 382Generate a global/object/player/map-specific event with the given arguments.
438 383
439This 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
… …
444 389
445=cut 390=cut
446 391
447############################################################################# 392#############################################################################
448 393
449=head2 METHODS VALID FOR ALL CORE OBJECTS 394=head2 METHODS VALID FOR ALL ATTACHABLE OBJECTS
395
396Attachable objects includes objects, players, clients and maps.
450 397
451=over 4 398=over 4
452 399
453=item $object->valid, $player->valid, $map->valid 400=item $object->valid
454 401
455Just 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
456C-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
457valid C counterpart anymore you get an exception at runtime. This method 404valid C counterpart anymore you get an exception at runtime. This method
458can 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
… …
460 407
461=back 408=back
462 409
463=cut 410=cut
464 411
465*cf::object::valid =
466*cf::player::valid =
467*cf::map::valid = \&cf::_valid;
468
469############################################################################# 412#############################################################################
470# object support 413# object support
471 414
472sub instantiate { 415sub instantiate {
473 my ($obj, $data) = @_; 416 my ($obj, $data) = @_;
… …
492 435
493 for my $name (keys %{ $obj->{_attachment} || {} }) { 436 for my $name (keys %{ $obj->{_attachment} || {} }) {
494 if (my $attach = $attachment{$name}) { 437 if (my $attach = $attachment{$name}) {
495 for (@$attach) { 438 for (@$attach) {
496 my ($klass, @attach) = @$_; 439 my ($klass, @attach) = @$_;
497 _attach @$registry, $klass, @attach; 440 _attach $registry, $klass, @attach;
498 } 441 }
499 } else { 442 } else {
500 warn "object uses attachment '$name' that is not available, postponing.\n"; 443 warn "object uses attachment '$name' that is not available, postponing.\n";
501 } 444 }
502 } 445 }
… …
558 } 501 }
559 502
560 () 503 ()
561} 504}
562 505
563attach_to_objects 506cf::object->attach (
564 prio => -1000000, 507 prio => -1000000,
565 on_clone => sub { 508 on_clone => sub {
566 my ($src, $dst) = @_; 509 my ($src, $dst) = @_;
567 510
568 @{$dst->registry} = @{$src->registry}; 511 @{$dst->registry} = @{$src->registry};
… …
570 %$dst = %$src; 513 %$dst = %$src;
571 514
572 %{$dst->{_attachment}} = %{$src->{_attachment}} 515 %{$dst->{_attachment}} = %{$src->{_attachment}}
573 if exists $src->{_attachment}; 516 if exists $src->{_attachment};
574 }, 517 },
575; 518);
576 519
577############################################################################# 520#############################################################################
578# command handling &c 521# command handling &c
579 522
580=item cf::register_command $name => \&callback($ob,$args); 523=item cf::register_command $name => \&callback($ob,$args);
… …
609 #warn "registering extcmd '$name' to '$caller'"; 552 #warn "registering extcmd '$name' to '$caller'";
610 553
611 $EXTCMD{$name} = [$cb, $caller]; 554 $EXTCMD{$name} = [$cb, $caller];
612} 555}
613 556
614attach_to_players 557cf::player->attach (
615 on_command => sub { 558 on_command => sub {
616 my ($pl, $name, $params) = @_; 559 my ($pl, $name, $params) = @_;
617 560
618 my $cb = $COMMAND{$name} 561 my $cb = $COMMAND{$name}
619 or return; 562 or return;
… …
639 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 582 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
640 } 583 }
641 584
642 cf::override; 585 cf::override;
643 }, 586 },
644; 587);
645 588
646sub register { 589sub register {
647 my ($base, $pkg) = @_; 590 my ($base, $pkg) = @_;
648 591
649 #TODO 592 #TODO
… …
718 661
719 Symbol::delete_package $pkg; 662 Symbol::delete_package $pkg;
720} 663}
721 664
722sub load_extensions { 665sub load_extensions {
723 my $LIBDIR = maps_directory "perl";
724
725 for my $ext (<$LIBDIR/*.ext>) { 666 for my $ext (<$LIBDIR/*.ext>) {
726 next unless -r $ext; 667 next unless -r $ext;
727 eval { 668 eval {
728 load_extension $ext; 669 load_extension $ext;
729 1 670 1
… …
741 defined $path or return; 682 defined $path or return;
742 683
743 unlink "$path.pst"; 684 unlink "$path.pst";
744}; 685};
745 686
746attach_to_maps prio => -10000, package => cf::mapsupport::; 687cf::map->attach (prio => -10000, package => cf::mapsupport::);
747 688
748############################################################################# 689#############################################################################
749# load/save perl data associated with player->ob objects 690# load/save perl data associated with player->ob objects
750 691
751sub all_objects(@) { 692sub all_objects(@) {
752 @_, map all_objects ($_->inv), @_ 693 @_, map all_objects ($_->inv), @_
753} 694}
754 695
755# TODO: compatibility cruft, remove when no longer needed 696# TODO: compatibility cruft, remove when no longer needed
756attach_to_players 697cf::player->attach (
757 on_load => sub { 698 on_load => sub {
758 my ($pl, $path) = @_; 699 my ($pl, $path) = @_;
759 700
760 for my $o (all_objects $pl->ob) { 701 for my $o (all_objects $pl->ob) {
761 if (my $value = $o->get_ob_key_value ("_perl_data")) { 702 if (my $value = $o->get_ob_key_value ("_perl_data")) {
… …
763 704
764 %$o = %{ Storable::thaw pack "H*", $value }; 705 %$o = %{ Storable::thaw pack "H*", $value };
765 } 706 }
766 } 707 }
767 }, 708 },
768; 709);
769 710
770############################################################################# 711#############################################################################
771 712
772=head2 CORE EXTENSIONS 713=head2 CORE EXTENSIONS
773 714
… …
864 805
865=pod 806=pod
866 807
867The following fucntions and emthods are available within a safe environment: 808The following fucntions and emthods are available within a safe environment:
868 809
869 cf::object contr pay_amount pay_player 810 cf::object contr pay_amount pay_player map
870 cf::object::player player 811 cf::object::player player
871 cf::player peaceful 812 cf::player peaceful
813 cf::map trigger
872 814
873=cut 815=cut
874 816
875for ( 817for (
876 ["cf::object" => qw(contr pay_amount pay_player)], 818 ["cf::object" => qw(contr pay_amount pay_player map)],
877 ["cf::object::player" => qw(player)], 819 ["cf::object::player" => qw(player)],
878 ["cf::player" => qw(peaceful)], 820 ["cf::player" => qw(peaceful)],
821 ["cf::map" => qw(trigger)],
879) { 822) {
880 no strict 'refs'; 823 no strict 'refs';
881 my ($pkg, @funs) = @$_; 824 my ($pkg, @funs) = @$_;
882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 825 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
883 for @funs; 826 for @funs;
… …
1023 sub db_sync() { 966 sub db_sync() {
1024 db_save if $dirty; 967 db_save if $dirty;
1025 undef $dirty; 968 undef $dirty;
1026 } 969 }
1027 970
1028 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 {
1029 db_sync; 972 db_sync;
1030 }); 973 });
1031 974
1032 sub db_dirty() { 975 sub db_dirty() {
1033 $dirty = 1; 976 $dirty = 1;
… …
1047 $DB->{$_[0]} = $_[1]; 990 $DB->{$_[0]} = $_[1];
1048 } 991 }
1049 db_dirty; 992 db_dirty;
1050 } 993 }
1051 994
1052 attach_global 995 cf::global->attach (
1053 prio => 10000, 996 prio => 10000,
1054 on_cleanup => sub { 997 on_cleanup => sub {
1055 db_sync; 998 db_sync;
1056 }, 999 },
1057 ; 1000 );
1058} 1001}
1059 1002
1060############################################################################# 1003#############################################################################
1061# the server's main() 1004# the server's main()
1062 1005
… …
1083 1026
1084 $msg->("reloading..."); 1027 $msg->("reloading...");
1085 1028
1086 eval { 1029 eval {
1087 # cancel all watchers 1030 # cancel all watchers
1088 $_->cancel for Event::all_watchers; 1031 for (Event::all_watchers) {
1032 $_->cancel if $_->data & WF_AUTOCANCEL;
1033 }
1089 1034
1090 # unload all extensions 1035 # unload all extensions
1091 for (@exts) { 1036 for (@exts) {
1092 $msg->("unloading <$_>"); 1037 $msg->("unloading <$_>");
1093 unload_extension $_; 1038 unload_extension $_;
… …
1169}; 1114};
1170 1115
1171unshift @INC, $LIBDIR; 1116unshift @INC, $LIBDIR;
1172 1117
1173$TICK_WATCHER = Event->timer ( 1118$TICK_WATCHER = Event->timer (
1174 prio => 1, 1119 prio => 0,
1175 async => 1,
1176 at => $NEXT_TICK || 1, 1120 at => $NEXT_TICK || 1,
1121 data => WF_AUTOCANCEL,
1177 cb => sub { 1122 cb => sub {
1178 cf::server_tick; # one server iteration 1123 cf::server_tick; # one server iteration
1179 1124
1180 my $NOW = Event::time; 1125 my $NOW = Event::time;
1181 $NEXT_TICK += $TICK; 1126 $NEXT_TICK += $TICK;
… …
1191IO::AIO::max_poll_time $TICK * 0.2; 1136IO::AIO::max_poll_time $TICK * 0.2;
1192 1137
1193Event->io (fd => IO::AIO::poll_fileno, 1138Event->io (fd => IO::AIO::poll_fileno,
1194 poll => 'r', 1139 poll => 'r',
1195 prio => 5, 1140 prio => 5,
1141 data => WF_AUTOCANCEL,
1196 cb => \&IO::AIO::poll_cb); 1142 cb => \&IO::AIO::poll_cb);
1197 1143
11981 11441
1199 1145

Diff Legend

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