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.85 by root, Mon Dec 11 22:56:57 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
… …
76 78
77@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
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(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 83for my $pkg (qw(
84 cf::object cf::object::player
85 cf::client cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
82 no strict 'refs'; 89 no strict 'refs';
83 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 91}
85 92
86$Event::DIED = sub { 93$Event::DIED = sub {
… …
145 152
146=item $map->attach ($attachment, key => $value...) 153=item $map->attach ($attachment, key => $value...)
147 154
148=item $map->detach ($attachment) 155=item $map->detach ($attachment)
149 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
150Attach/detach a pre-registered attachment to a map. 163Attach/detach a pre-registered attachment to a map.
151 164
152=item $bool = $object->attached ($name) 165=item $bool = $object->attached ($name)
153 166
154=item $bool = $player->attached ($name) 167=item $bool = $player->attached ($name)
168
169=item $bool = $client->attached ($name)
155 170
156=item $bool = $map->attached ($name) 171=item $bool = $map->attached ($name)
157 172
158Checks wether the named attachment is currently attached to the object. 173Checks wether the named attachment is currently attached to the object.
159 174
… …
206 221
207=item cf::attach_to_players ... 222=item cf::attach_to_players ...
208 223
209Attach handlers to all players. 224Attach handlers to all players.
210 225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
211=item cf::attach_to_maps ... 230=item cf::attach_to_maps ...
212 231
213Attach handlers to all maps. 232Attach handlers to all maps.
214 233
215=item cf:register_attachment $name, ... 234=item cf:register_attachment $name, ...
… …
231 250
232# 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
233our @CB_GLOBAL = (); # registry for all global events 252our @CB_GLOBAL = (); # registry for all global events
234our @CB_OBJECT = (); # all objects (should not be used except in emergency) 253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
235our @CB_PLAYER = (); 254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
236our @CB_TYPE = (); # registry for type (cf-object class) based events 256our @CB_TYPE = (); # registry for type (cf-object class) based events
237our @CB_MAP = (); 257our @CB_MAP = ();
238 258
239my %attachment; 259my %attachment;
240 260
… …
323 $res 343 $res
324} 344}
325 345
326*cf::object::attach = 346*cf::object::attach =
327*cf::player::attach = 347*cf::player::attach =
348*cf::client::attach =
328*cf::map::attach = sub { 349*cf::map::attach = sub {
329 my ($obj, $name, %arg) = @_; 350 my ($obj, $name, %arg) = @_;
330 351
331 _attach_attachment $obj, $name, %arg; 352 _attach_attachment $obj, $name, %arg;
332}; 353};
333 354
334# all those should be optimised 355# all those should be optimised
335*cf::object::detach = 356*cf::object::detach =
336*cf::player::detach = 357*cf::player::detach =
358*cf::client::detach =
337*cf::map::detach = sub { 359*cf::map::detach = sub {
338 my ($obj, $name) = @_; 360 my ($obj, $name) = @_;
339 361
340 delete $obj->{_attachment}{$name}; 362 delete $obj->{_attachment}{$name};
341 reattach ($obj); 363 reattach ($obj);
342}; 364};
343 365
344*cf::object::attached = 366*cf::object::attached =
345*cf::player::attached = 367*cf::player::attached =
368*cf::client::attached =
346*cf::map::attached = sub { 369*cf::map::attached = sub {
347 my ($obj, $name) = @_; 370 my ($obj, $name) = @_;
348 371
349 exists $obj->{_attachment}{$name} 372 exists $obj->{_attachment}{$name}
350}; 373};
… …
366 389
367sub attach_to_players { 390sub attach_to_players {
368 _attach @CB_PLAYER, KLASS_PLAYER, @_ 391 _attach @CB_PLAYER, KLASS_PLAYER, @_
369} 392}
370 393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
371sub attach_to_maps { 398sub attach_to_maps {
372 _attach @CB_MAP, KLASS_MAP, @_ 399 _attach @CB_MAP, KLASS_MAP, @_
373} 400}
374 401
375sub register_attachment { 402sub register_attachment {
… …
380 407
381sub register_player_attachment { 408sub register_player_attachment {
382 my $name = shift; 409 my $name = shift;
383 410
384 $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, @_]];
385} 418}
386 419
387sub register_map_attachment { 420sub register_map_attachment {
388 my $name = shift; 421 my $name = shift;
389 422
… …
425 458
426=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
427 460
428=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
429 462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
430=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
431 466
432Generate a global/object/player/map-specific event with the given arguments. 467Generate a global/object/player/map-specific event with the given arguments.
433 468
434This 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
… …
443 478
444=head2 METHODS VALID FOR ALL CORE OBJECTS 479=head2 METHODS VALID FOR ALL CORE OBJECTS
445 480
446=over 4 481=over 4
447 482
448=item $object->valid, $player->valid, $map->valid 483=item $object->valid, $player->valid, $client->valid, $map->valid
449 484
450Just 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
451C-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
452valid C counterpart anymore you get an exception at runtime. This method 487valid C counterpart anymore you get an exception at runtime. This method
453can 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
… …
457 492
458=cut 493=cut
459 494
460*cf::object::valid = 495*cf::object::valid =
461*cf::player::valid = 496*cf::player::valid =
497*cf::client::valid =
462*cf::map::valid = \&cf::_valid; 498*cf::map::valid = \&cf::_valid;
463 499
464############################################################################# 500#############################################################################
465# object support 501# object support
466 502
… …
713 749
714 Symbol::delete_package $pkg; 750 Symbol::delete_package $pkg;
715} 751}
716 752
717sub load_extensions { 753sub load_extensions {
718 my $LIBDIR = maps_directory "perl";
719
720 for my $ext (<$LIBDIR/*.ext>) { 754 for my $ext (<$LIBDIR/*.ext>) {
721 next unless -r $ext; 755 next unless -r $ext;
722 eval { 756 eval {
723 load_extension $ext; 757 load_extension $ext;
724 1 758 1
… …
859 893
860=pod 894=pod
861 895
862The following fucntions and emthods are available within a safe environment: 896The following fucntions and emthods are available within a safe environment:
863 897
864 cf::object contr pay_amount pay_player 898 cf::object contr pay_amount pay_player map
865 cf::object::player player 899 cf::object::player player
866 cf::player peaceful 900 cf::player peaceful
901 cf::map trigger
867 902
868=cut 903=cut
869 904
870for ( 905for (
871 ["cf::object" => qw(contr pay_amount pay_player)], 906 ["cf::object" => qw(contr pay_amount pay_player map)],
872 ["cf::object::player" => qw(player)], 907 ["cf::object::player" => qw(player)],
873 ["cf::player" => qw(peaceful)], 908 ["cf::player" => qw(peaceful)],
909 ["cf::map" => qw(trigger)],
874) { 910) {
875 no strict 'refs'; 911 no strict 'refs';
876 my ($pkg, @funs) = @$_; 912 my ($pkg, @funs) = @$_;
877 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 913 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
878 for @funs; 914 for @funs;
… …
1018 sub db_sync() { 1054 sub db_sync() {
1019 db_save if $dirty; 1055 db_save if $dirty;
1020 undef $dirty; 1056 undef $dirty;
1021 } 1057 }
1022 1058
1023 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 {
1024 db_sync; 1060 db_sync;
1025 }); 1061 });
1026 1062
1027 sub db_dirty() { 1063 sub db_dirty() {
1028 $dirty = 1; 1064 $dirty = 1;
… …
1078 1114
1079 $msg->("reloading..."); 1115 $msg->("reloading...");
1080 1116
1081 eval { 1117 eval {
1082 # cancel all watchers 1118 # cancel all watchers
1083 $_->cancel for Event::all_watchers; 1119 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 }
1084 1122
1085 # unload all extensions 1123 # unload all extensions
1086 for (@exts) { 1124 for (@exts) {
1087 $msg->("unloading <$_>"); 1125 $msg->("unloading <$_>");
1088 unload_extension $_; 1126 unload_extension $_;
… …
1164}; 1202};
1165 1203
1166unshift @INC, $LIBDIR; 1204unshift @INC, $LIBDIR;
1167 1205
1168$TICK_WATCHER = Event->timer ( 1206$TICK_WATCHER = Event->timer (
1169 prio => 1, 1207 prio => 0,
1170 async => 1,
1171 at => $NEXT_TICK || 1, 1208 at => $NEXT_TICK || 1,
1209 data => WF_AUTOCANCEL,
1172 cb => sub { 1210 cb => sub {
1173 cf::server_tick; # one server iteration 1211 cf::server_tick; # one server iteration
1174 1212
1175 my $NOW = Event::time; 1213 my $NOW = Event::time;
1176 $NEXT_TICK += $TICK; 1214 $NEXT_TICK += $TICK;
… …
1186IO::AIO::max_poll_time $TICK * 0.2; 1224IO::AIO::max_poll_time $TICK * 0.2;
1187 1225
1188Event->io (fd => IO::AIO::poll_fileno, 1226Event->io (fd => IO::AIO::poll_fileno,
1189 poll => 'r', 1227 poll => 'r',
1190 prio => 5, 1228 prio => 5,
1229 data => WF_AUTOCANCEL,
1191 cb => \&IO::AIO::poll_cb); 1230 cb => \&IO::AIO::poll_cb);
1192 1231
11931 12321
1194 1233

Diff Legend

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