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.104 by root, Sat Dec 30 16:56:16 2006 UTC

… …
8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro; 13use Coro 3.3;
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
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1; 26$YAML::Syck::ImplicitUnicode = 1;
27 27
28$Coro::main->prio (Coro::PRIO_MIN); 28$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
29 29
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 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;
43our $NEXT_TICK; 41our $NEXT_TICK;
42our $NOW;
44 43
45our %CFG; 44our %CFG;
46 45
47our $UPTIME; $UPTIME ||= time; 46our $UPTIME; $UPTIME ||= time;
47our $RUNTIME;
48
49our %MAP; # all maps
50our $LINK_MAP; # the special {link} map
51our $FREEZE;
52
53binmode STDOUT;
54binmode STDERR;
55
56# read virtual server time, if available
57unless ($RUNTIME || !-e cf::localdir . "/runtime") {
58 open my $fh, "<", cf::localdir . "/runtime"
59 or die "unable to read runtime file: $!";
60 $RUNTIME = <$fh> + 0.;
61}
62
63mkdir cf::localdir;
64mkdir cf::localdir . "/" . cf::playerdir;
65mkdir cf::localdir . "/" . cf::tmpdir;
66mkdir cf::localdir . "/" . cf::uniquedir;
67
68our %EXT_CORO;
48 69
49############################################################################# 70#############################################################################
50 71
51=head2 GLOBAL VARIABLES 72=head2 GLOBAL VARIABLES
52 73
53=over 4 74=over 4
54 75
55=item $cf::UPTIME 76=item $cf::UPTIME
56 77
57The timestamp of the server start (so not actually an uptime). 78The timestamp of the server start (so not actually an uptime).
79
80=item $cf::RUNTIME
81
82The time this server has run, starts at 0 and is increased by $cf::TICK on
83every server tick.
58 84
59=item $cf::LIBDIR 85=item $cf::LIBDIR
60 86
61The perl library directory, where extensions and cf-specific modules can 87The perl library directory, where extensions and cf-specific modules can
62be found. It will be added to C<@INC> automatically. 88be found. It will be added to C<@INC> automatically.
89
90=item $cf::NOW
91
92The time of the last (current) server tick.
63 93
64=item $cf::TICK 94=item $cf::TICK
65 95
66The interval between server ticks, in seconds. 96The interval between server ticks, in seconds.
67 97
… …
75=cut 105=cut
76 106
77BEGIN { 107BEGIN {
78 *CORE::GLOBAL::warn = sub { 108 *CORE::GLOBAL::warn = sub {
79 my $msg = join "", @_; 109 my $msg = join "", @_;
110 utf8::encode $msg;
111
80 $msg .= "\n" 112 $msg .= "\n"
81 unless $msg =~ /\n$/; 113 unless $msg =~ /\n$/;
82 114
83 print STDERR "cfperl: $msg";
84 LOG llevError, "cfperl: $msg"; 115 LOG llevError, "cfperl: $msg";
85 }; 116 };
86} 117}
87 118
88@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 119@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
93@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 124@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
94 125
95# we bless all objects into (empty) derived classes to force a method lookup 126# we bless all objects into (empty) derived classes to force a method lookup
96# within the Safe compartment. 127# within the Safe compartment.
97for my $pkg (qw( 128for my $pkg (qw(
98 cf::global 129 cf::global cf::attachable
99 cf::object cf::object::player 130 cf::object cf::object::player
100 cf::client cf::player 131 cf::client cf::player
101 cf::arch cf::living 132 cf::arch cf::living
102 cf::map cf::party cf::region 133 cf::map cf::party cf::region
103)) { 134)) {
… …
139=cut 170=cut
140 171
141sub to_json($) { 172sub to_json($) {
142 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 173 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
143 JSON::Syck::Dump $_[0] 174 JSON::Syck::Dump $_[0]
175}
176
177=item $coro = cf::coro { BLOCK }
178
179Creates and returns a new coro. This coro is automcatially being canceled
180when the extension calling this is being unloaded.
181
182=cut
183
184sub coro(&) {
185 my $cb = shift;
186
187 my $coro; $coro = async {
188 eval {
189 $cb->();
190 };
191 warn $@ if $@;
192 };
193
194 $coro->on_destroy (sub {
195 delete $EXT_CORO{$coro+0};
196 });
197 $EXT_CORO{$coro+0} = $coro;
198
199 $coro
144} 200}
145 201
146=back 202=back
147 203
148=cut 204=cut
… …
269exception. 325exception.
270 326
271=cut 327=cut
272 328
273# the following variables are defined in .xs and must not be re-created 329# the following variables are defined in .xs and must not be re-created
274our @CB_GLOBAL = (); # registry for all global events 330our @CB_GLOBAL = (); # registry for all global events
331our @CB_ATTACHABLE = (); # registry for all attachables
275our @CB_OBJECT = (); # all objects (should not be used except in emergency) 332our @CB_OBJECT = (); # all objects (should not be used except in emergency)
276our @CB_PLAYER = (); 333our @CB_PLAYER = ();
277our @CB_CLIENT = (); 334our @CB_CLIENT = ();
278our @CB_TYPE = (); # registry for type (cf-object class) based events 335our @CB_TYPE = (); # registry for type (cf-object class) based events
279our @CB_MAP = (); 336our @CB_MAP = ();
280 337
281my %attachment; 338my %attachment;
282 339
283sub _attach_cb($$$$) { 340sub _attach_cb($$$$) {
284 my ($registry, $event, $prio, $cb) = @_; 341 my ($registry, $event, $prio, $cb) = @_;
… …
289 346
290 @{$registry->[$event]} = sort 347 @{$registry->[$event]} = sort
291 { $a->[0] cmp $b->[0] } 348 { $a->[0] cmp $b->[0] }
292 @{$registry->[$event] || []}, $cb; 349 @{$registry->[$event] || []}, $cb;
293} 350}
351
352# hack
353my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
294 354
295# attach handles attaching event callbacks 355# attach handles attaching event callbacks
296# the only thing the caller has to do is pass the correct 356# the only thing the caller has to do is pass the correct
297# registry (== where the callback attaches to). 357# registry (== where the callback attaches to).
298sub _attach { 358sub _attach {
… …
300 360
301 my $object_type; 361 my $object_type;
302 my $prio = 0; 362 my $prio = 0;
303 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 363 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
304 364
365 #TODO: get rid of this hack
366 if ($attachable_klass{$klass}) {
367 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
368 }
369
305 while (@arg) { 370 while (@arg) {
306 my $type = shift @arg; 371 my $type = shift @arg;
307 372
308 if ($type eq "prio") { 373 if ($type eq "prio") {
309 $prio = shift @arg; 374 $prio = shift @arg;
… …
384 my ($obj, $name) = @_; 449 my ($obj, $name) = @_;
385 450
386 exists $obj->{_attachment}{$name} 451 exists $obj->{_attachment}{$name}
387} 452}
388 453
389for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 454for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
390 eval "#line " . __LINE__ . " 'cf.pm' 455 eval "#line " . __LINE__ . " 'cf.pm'
391 sub cf::\L$klass\E::_attach_registry { 456 sub cf::\L$klass\E::_attach_registry {
392 (\\\@CB_$klass, KLASS_$klass) 457 (\\\@CB_$klass, KLASS_$klass)
393 } 458 }
394 459
… …
447=cut 512=cut
448 513
449############################################################################# 514#############################################################################
450# object support 515# object support
451 516
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 { 517sub reattach {
518 # basically do the same as instantiate, without calling instantiate
466 my ($obj) = @_; 519 my ($obj) = @_;
520
467 my $registry = $obj->registry; 521 my $registry = $obj->registry;
468 522
469 @$registry = (); 523 @$registry = ();
470 524
471 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 525 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
… …
480 warn "object uses attachment '$name' that is not available, postponing.\n"; 534 warn "object uses attachment '$name' that is not available, postponing.\n";
481 } 535 }
482 } 536 }
483} 537}
484 538
539cf::attachable->attach (
540 prio => -1000000,
541 on_instantiate => sub {
542 my ($obj, $data) = @_;
543
544 $data = from_json $data;
545
546 for (@$data) {
547 my ($name, $args) = @$_;
548
549 $obj->attach ($name, %{$args || {} });
550 }
551 },
552 on_reattach => \&reattach,
553 on_clone => sub {
554 my ($src, $dst) = @_;
555
556 @{$dst->registry} = @{$src->registry};
557
558 %$dst = %$src;
559
560 %{$dst->{_attachment}} = %{$src->{_attachment}}
561 if exists $src->{_attachment};
562 },
563);
564
485sub object_freezer_save { 565sub object_freezer_save {
486 my ($filename, $rdata, $objs) = @_; 566 my ($filename, $rdata, $objs) = @_;
487 567
488 if (length $$rdata) { 568 if (length $$rdata) {
489 warn sprintf "saving %s (%d,%d)\n", 569 warn sprintf "saving %s (%d,%d)\n",
… …
538 } 618 }
539 619
540 () 620 ()
541} 621}
542 622
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############################################################################# 623#############################################################################
558# command handling &c 624# command handling &c
559 625
560=item cf::register_command $name => \&callback($ob,$args); 626=item cf::register_command $name => \&callback($ob,$args);
561 627
… …
886 952
887 if (@{ $ns->{query_queue} } == @$queue) { 953 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 954 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 955 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 956 } else {
891 $ns->state (ST_PLAYING); 957 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 958 }
893 } 959 }
894 }, 960 },
895); 961);
896 962
… …
908 my $coro; $coro = async { 974 my $coro; $coro = async {
909 eval { 975 eval {
910 $cb->(); 976 $cb->();
911 }; 977 };
912 warn $@ if $@; 978 warn $@ if $@;
979 };
980
981 $coro->on_destroy (sub {
913 delete $self->{_coro}{$coro+0}; 982 delete $self->{_coro}{$coro+0};
914 }; 983 });
915 984
916 $self->{_coro}{$coro+0} = $coro; 985 $self->{_coro}{$coro+0} = $coro;
986
987 $coro
917} 988}
918 989
919cf::client->attach ( 990cf::client->attach (
920 on_destroy => sub { 991 on_destroy => sub {
921 my ($ns) = @_; 992 my ($ns) = @_;
… …
1162} 1233}
1163 1234
1164############################################################################# 1235#############################################################################
1165# initialisation 1236# initialisation
1166 1237
1167sub _perl_reload(&) { 1238sub _perl_reload() {
1168 my ($msg) = @_; 1239 warn "reloading...";
1169
1170 $msg->("reloading...");
1171 1240
1172 eval { 1241 eval {
1242 local $FREEZE = 1;
1243
1244 cf::emergency_save;
1245
1173 # cancel all watchers 1246 # cancel all watchers
1174 for (Event::all_watchers) { 1247 for (Event::all_watchers) {
1175 $_->cancel if $_->data & WF_AUTOCANCEL; 1248 $_->cancel if $_->data & WF_AUTOCANCEL;
1176 } 1249 }
1177 1250
1251 # cancel all extension coros
1252 $_->cancel for values %EXT_CORO;
1253 %EXT_CORO = ();
1254
1178 # unload all extensions 1255 # unload all extensions
1179 for (@exts) { 1256 for (@exts) {
1180 $msg->("unloading <$_>"); 1257 warn "unloading <$_>";
1181 unload_extension $_; 1258 unload_extension $_;
1182 } 1259 }
1183 1260
1184 # unload all modules loaded from $LIBDIR 1261 # unload all modules loaded from $LIBDIR
1185 while (my ($k, $v) = each %INC) { 1262 while (my ($k, $v) = each %INC) {
1186 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1263 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1187 1264
1188 $msg->("removing <$k>"); 1265 warn "removing <$k>";
1189 delete $INC{$k}; 1266 delete $INC{$k};
1190 1267
1191 $k =~ s/\.pm$//; 1268 $k =~ s/\.pm$//;
1192 $k =~ s/\//::/g; 1269 $k =~ s/\//::/g;
1193 1270
… …
1198 Symbol::delete_package $k; 1275 Symbol::delete_package $k;
1199 } 1276 }
1200 1277
1201 # sync database to disk 1278 # sync database to disk
1202 cf::db_sync; 1279 cf::db_sync;
1280 IO::AIO::flush;
1203 1281
1204 # get rid of safe::, as good as possible 1282 # get rid of safe::, as good as possible
1205 Symbol::delete_package "safe::$_" 1283 Symbol::delete_package "safe::$_"
1206 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 1284 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1207 1285
1208 # remove register_script_function callbacks 1286 # remove register_script_function callbacks
1209 # TODO 1287 # TODO
1210 1288
1211 # unload cf.pm "a bit" 1289 # unload cf.pm "a bit"
… …
1214 # don't, removes xs symbols, too, 1292 # don't, removes xs symbols, too,
1215 # and global variables created in xs 1293 # and global variables created in xs
1216 #Symbol::delete_package __PACKAGE__; 1294 #Symbol::delete_package __PACKAGE__;
1217 1295
1218 # reload cf.pm 1296 # reload cf.pm
1219 $msg->("reloading cf.pm"); 1297 warn "reloading cf.pm";
1220 require cf; 1298 require cf;
1299 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1221 1300
1222 # load config and database again 1301 # load config and database again
1223 cf::cfg_load; 1302 cf::cfg_load;
1224 cf::db_load; 1303 cf::db_load;
1225 1304
1226 # load extensions 1305 # load extensions
1227 $msg->("load extensions"); 1306 warn "load extensions";
1228 cf::load_extensions; 1307 cf::load_extensions;
1229 1308
1230 # reattach attachments to objects 1309 # reattach attachments to objects
1231 $msg->("reattach"); 1310 warn "reattach";
1232 _global_reattach; 1311 _global_reattach;
1233 }; 1312 };
1234 $msg->($@) if $@; 1313 warn $@ if $@;
1235 1314
1236 $msg->("reloaded"); 1315 warn "reloaded";
1237}; 1316};
1238 1317
1239sub perl_reload() { 1318sub perl_reload() {
1240 _perl_reload { 1319 _perl_reload;
1241 warn $_[0];
1242 print "$_[0]\n";
1243 };
1244} 1320}
1245 1321
1246register "<global>", __PACKAGE__; 1322register "<global>", __PACKAGE__;
1247 1323
1248register_command "perl-reload" => sub { 1324register_command "perl-reload" => sub {
1249 my ($who, $arg) = @_; 1325 my ($who, $arg) = @_;
1250 1326
1251 if ($who->flag (FLAG_WIZ)) { 1327 if ($who->flag (FLAG_WIZ)) {
1328 $who->message ("reloading...");
1252 _perl_reload { 1329 _perl_reload;
1253 warn $_[0];
1254 $who->message ($_[0]);
1255 };
1256 } 1330 }
1257}; 1331};
1258 1332
1259unshift @INC, $LIBDIR; 1333unshift @INC, $LIBDIR;
1260 1334
1261$TICK_WATCHER = Event->timer ( 1335$TICK_WATCHER = Event->timer (
1336 reentrant => 0,
1262 prio => 0, 1337 prio => 0,
1263 at => $NEXT_TICK || 1, 1338 at => $NEXT_TICK || $TICK,
1264 data => WF_AUTOCANCEL, 1339 data => WF_AUTOCANCEL,
1265 cb => sub { 1340 cb => sub {
1341 unless ($FREEZE) {
1266 cf::server_tick; # one server iteration 1342 cf::server_tick; # one server iteration
1343 $RUNTIME += $TICK;
1344 }
1267 1345
1268 my $NOW = Event::time;
1269 $NEXT_TICK += $TICK; 1346 $NEXT_TICK += $TICK;
1270 1347
1271 # if we are delayed by four ticks or more, skip them all 1348 # if we are delayed by four ticks or more, skip them all
1272 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1349 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1273 1350
1274 $TICK_WATCHER->at ($NEXT_TICK); 1351 $TICK_WATCHER->at ($NEXT_TICK);
1275 $TICK_WATCHER->start; 1352 $TICK_WATCHER->start;
1276 }, 1353 },
1277); 1354);
… …
1282 poll => 'r', 1359 poll => 'r',
1283 prio => 5, 1360 prio => 5,
1284 data => WF_AUTOCANCEL, 1361 data => WF_AUTOCANCEL,
1285 cb => \&IO::AIO::poll_cb); 1362 cb => \&IO::AIO::poll_cb);
1286 1363
1364# we must not ever block the main coroutine
1365$Coro::idle = sub {
1366 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1367 warn "FATAL: Coro::idle was called, major BUG\n";
1368 (Coro::unblock_sub {
1369 Event::one_event;
1370 })->();
1371};
1372
12871 13731
1288 1374

Diff Legend

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