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.92 by root, Thu Dec 21 06:42:28 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
… …
78 80
79# we bless all objects into (empty) derived classes to force a method lookup 81# we bless all objects into (empty) derived classes to force a method lookup
80# within the Safe compartment. 82# within the Safe compartment.
81for my $pkg (qw( 83for my $pkg (qw(
82 cf::object cf::object::player 84 cf::object cf::object::player
83 cf::client_socket cf::player 85 cf::client cf::player
84 cf::arch cf::living 86 cf::arch cf::living
85 cf::map cf::party cf::region 87 cf::map cf::party cf::region
86)) { 88)) {
87 no strict 'refs'; 89 no strict 'refs';
88 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
… …
150 152
151=item $map->attach ($attachment, key => $value...) 153=item $map->attach ($attachment, key => $value...)
152 154
153=item $map->detach ($attachment) 155=item $map->detach ($attachment)
154 156
157Attach/detach a pre-registered attachment to a client.
158
159=item $client->attach ($attachment, key => $value...)
160
161=item $client->detach ($attachment)
162
155Attach/detach a pre-registered attachment to a map. 163Attach/detach a pre-registered attachment to a map.
156 164
157=item $bool = $object->attached ($name) 165=item $bool = $object->attached ($name)
158 166
159=item $bool = $player->attached ($name) 167=item $bool = $player->attached ($name)
168
169=item $bool = $client->attached ($name)
160 170
161=item $bool = $map->attached ($name) 171=item $bool = $map->attached ($name)
162 172
163Checks wether the named attachment is currently attached to the object. 173Checks wether the named attachment is currently attached to the object.
164 174
… …
211 221
212=item cf::attach_to_players ... 222=item cf::attach_to_players ...
213 223
214Attach handlers to all players. 224Attach handlers to all players.
215 225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
216=item cf::attach_to_maps ... 230=item cf::attach_to_maps ...
217 231
218Attach handlers to all maps. 232Attach handlers to all maps.
219 233
220=item cf:register_attachment $name, ... 234=item cf:register_attachment $name, ...
… …
236 250
237# the following variables are defined in .xs and must not be re-created 251# the following variables are defined in .xs and must not be re-created
238our @CB_GLOBAL = (); # registry for all global events 252our @CB_GLOBAL = (); # registry for all global events
239our @CB_OBJECT = (); # all objects (should not be used except in emergency) 253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
240our @CB_PLAYER = (); 254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
241our @CB_TYPE = (); # registry for type (cf-object class) based events 256our @CB_TYPE = (); # registry for type (cf-object class) based events
242our @CB_MAP = (); 257our @CB_MAP = ();
243 258
244my %attachment; 259my %attachment;
245 260
… …
328 $res 343 $res
329} 344}
330 345
331*cf::object::attach = 346*cf::object::attach =
332*cf::player::attach = 347*cf::player::attach =
348*cf::client::attach =
333*cf::map::attach = sub { 349*cf::map::attach = sub {
334 my ($obj, $name, %arg) = @_; 350 my ($obj, $name, %arg) = @_;
335 351
336 _attach_attachment $obj, $name, %arg; 352 _attach_attachment $obj, $name, %arg;
337}; 353};
338 354
339# all those should be optimised 355# all those should be optimised
340*cf::object::detach = 356*cf::object::detach =
341*cf::player::detach = 357*cf::player::detach =
358*cf::client::detach =
342*cf::map::detach = sub { 359*cf::map::detach = sub {
343 my ($obj, $name) = @_; 360 my ($obj, $name) = @_;
344 361
345 delete $obj->{_attachment}{$name}; 362 delete $obj->{_attachment}{$name};
346 reattach ($obj); 363 reattach ($obj);
347}; 364};
348 365
349*cf::object::attached = 366*cf::object::attached =
350*cf::player::attached = 367*cf::player::attached =
368*cf::client::attached =
351*cf::map::attached = sub { 369*cf::map::attached = sub {
352 my ($obj, $name) = @_; 370 my ($obj, $name) = @_;
353 371
354 exists $obj->{_attachment}{$name} 372 exists $obj->{_attachment}{$name}
355}; 373};
… …
371 389
372sub attach_to_players { 390sub attach_to_players {
373 _attach @CB_PLAYER, KLASS_PLAYER, @_ 391 _attach @CB_PLAYER, KLASS_PLAYER, @_
374} 392}
375 393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
376sub attach_to_maps { 398sub attach_to_maps {
377 _attach @CB_MAP, KLASS_MAP, @_ 399 _attach @CB_MAP, KLASS_MAP, @_
378} 400}
379 401
380sub register_attachment { 402sub register_attachment {
… …
385 407
386sub register_player_attachment { 408sub register_player_attachment {
387 my $name = shift; 409 my $name = shift;
388 410
389 $attachment{$name} = [[KLASS_PLAYER, @_]]; 411 $attachment{$name} = [[KLASS_PLAYER, @_]];
412}
413
414sub register_client_attachment {
415 my $name = shift;
416
417 $attachment{$name} = [[KLASS_CLIENT, @_]];
390} 418}
391 419
392sub register_map_attachment { 420sub register_map_attachment {
393 my $name = shift; 421 my $name = shift;
394 422
… …
430 458
431=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
432 460
433=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
434 462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
435=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
436 466
437Generate a global/object/player/map-specific event with the given arguments. 467Generate a global/object/player/map-specific event with the given arguments.
438 468
439This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 469This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
… …
448 478
449=head2 METHODS VALID FOR ALL CORE OBJECTS 479=head2 METHODS VALID FOR ALL CORE OBJECTS
450 480
451=over 4 481=over 4
452 482
453=item $object->valid, $player->valid, $map->valid 483=item $object->valid, $player->valid, $client->valid, $map->valid
454 484
455Just because you have a perl object does not mean that the corresponding 485Just 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 486C-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 487valid 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 488can be used to test for existence of the C object part without causing an
… …
462 492
463=cut 493=cut
464 494
465*cf::object::valid = 495*cf::object::valid =
466*cf::player::valid = 496*cf::player::valid =
497*cf::client::valid =
467*cf::map::valid = \&cf::_valid; 498*cf::map::valid = \&cf::_valid;
468 499
469############################################################################# 500#############################################################################
470# object support 501# object support
471 502
… …
718 749
719 Symbol::delete_package $pkg; 750 Symbol::delete_package $pkg;
720} 751}
721 752
722sub load_extensions { 753sub load_extensions {
723 my $LIBDIR = maps_directory "perl";
724
725 for my $ext (<$LIBDIR/*.ext>) { 754 for my $ext (<$LIBDIR/*.ext>) {
726 next unless -r $ext; 755 next unless -r $ext;
727 eval { 756 eval {
728 load_extension $ext; 757 load_extension $ext;
729 1 758 1
… …
864 893
865=pod 894=pod
866 895
867The following fucntions and emthods are available within a safe environment: 896The following fucntions and emthods are available within a safe environment:
868 897
869 cf::object contr pay_amount pay_player 898 cf::object contr pay_amount pay_player map
870 cf::object::player player 899 cf::object::player player
871 cf::player peaceful 900 cf::player peaceful
901 cf::map trigger
872 902
873=cut 903=cut
874 904
875for ( 905for (
876 ["cf::object" => qw(contr pay_amount pay_player)], 906 ["cf::object" => qw(contr pay_amount pay_player map)],
877 ["cf::object::player" => qw(player)], 907 ["cf::object::player" => qw(player)],
878 ["cf::player" => qw(peaceful)], 908 ["cf::player" => qw(peaceful)],
909 ["cf::map" => qw(trigger)],
879) { 910) {
880 no strict 'refs'; 911 no strict 'refs';
881 my ($pkg, @funs) = @$_; 912 my ($pkg, @funs) = @$_;
882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 913 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
883 for @funs; 914 for @funs;
… …
1023 sub db_sync() { 1054 sub db_sync() {
1024 db_save if $dirty; 1055 db_save if $dirty;
1025 undef $dirty; 1056 undef $dirty;
1026 } 1057 }
1027 1058
1028 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1059 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1029 db_sync; 1060 db_sync;
1030 }); 1061 });
1031 1062
1032 sub db_dirty() { 1063 sub db_dirty() {
1033 $dirty = 1; 1064 $dirty = 1;
… …
1083 1114
1084 $msg->("reloading..."); 1115 $msg->("reloading...");
1085 1116
1086 eval { 1117 eval {
1087 # cancel all watchers 1118 # cancel all watchers
1088 $_->cancel for Event::all_watchers; 1119 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 }
1089 1122
1090 # unload all extensions 1123 # unload all extensions
1091 for (@exts) { 1124 for (@exts) {
1092 $msg->("unloading <$_>"); 1125 $msg->("unloading <$_>");
1093 unload_extension $_; 1126 unload_extension $_;
… …
1169}; 1202};
1170 1203
1171unshift @INC, $LIBDIR; 1204unshift @INC, $LIBDIR;
1172 1205
1173$TICK_WATCHER = Event->timer ( 1206$TICK_WATCHER = Event->timer (
1174 prio => 1, 1207 prio => 0,
1175 async => 1,
1176 at => $NEXT_TICK || 1, 1208 at => $NEXT_TICK || 1,
1209 data => WF_AUTOCANCEL,
1177 cb => sub { 1210 cb => sub {
1178 cf::server_tick; # one server iteration 1211 cf::server_tick; # one server iteration
1179 1212
1180 my $NOW = Event::time; 1213 my $NOW = Event::time;
1181 $NEXT_TICK += $TICK; 1214 $NEXT_TICK += $TICK;
… …
1191IO::AIO::max_poll_time $TICK * 0.2; 1224IO::AIO::max_poll_time $TICK * 0.2;
1192 1225
1193Event->io (fd => IO::AIO::poll_fileno, 1226Event->io (fd => IO::AIO::poll_fileno,
1194 poll => 'r', 1227 poll => 'r',
1195 prio => 5, 1228 prio => 5,
1229 data => WF_AUTOCANCEL,
1196 cb => \&IO::AIO::poll_cb); 1230 cb => \&IO::AIO::poll_cb);
1197 1231
11981 12321
1199 1233

Diff Legend

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