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.101 by root, Mon Dec 25 14:43:23 2006 UTC vs.
Revision 1.103 by root, Sat Dec 30 10:16:11 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
… …
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 = ();
… …
37our $LIBDIR = datadir . "/ext"; 37our $LIBDIR = datadir . "/ext";
38 38
39our $TICK = MAX_TIME * 1e-6; 39our $TICK = MAX_TIME * 1e-6;
40our $TICK_WATCHER; 40our $TICK_WATCHER;
41our $NEXT_TICK; 41our $NEXT_TICK;
42our $NOW;
42 43
43our %CFG; 44our %CFG;
44 45
45our $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;
46 69
47############################################################################# 70#############################################################################
48 71
49=head2 GLOBAL VARIABLES 72=head2 GLOBAL VARIABLES
50 73
51=over 4 74=over 4
52 75
53=item $cf::UPTIME 76=item $cf::UPTIME
54 77
55The 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.
56 84
57=item $cf::LIBDIR 85=item $cf::LIBDIR
58 86
59The perl library directory, where extensions and cf-specific modules can 87The perl library directory, where extensions and cf-specific modules can
60be 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.
61 93
62=item $cf::TICK 94=item $cf::TICK
63 95
64The interval between server ticks, in seconds. 96The interval between server ticks, in seconds.
65 97
… …
73=cut 105=cut
74 106
75BEGIN { 107BEGIN {
76 *CORE::GLOBAL::warn = sub { 108 *CORE::GLOBAL::warn = sub {
77 my $msg = join "", @_; 109 my $msg = join "", @_;
110 utf8::encode $msg;
111
78 $msg .= "\n" 112 $msg .= "\n"
79 unless $msg =~ /\n$/; 113 unless $msg =~ /\n$/;
80 114
81 print STDERR "cfperl: $msg";
82 LOG llevError, "cfperl: $msg"; 115 LOG llevError, "cfperl: $msg";
83 }; 116 };
84} 117}
85 118
86@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 119@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
139sub to_json($) { 172sub to_json($) {
140 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 173 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
141 JSON::Syck::Dump $_[0] 174 JSON::Syck::Dump $_[0]
142} 175}
143 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
200}
201
144=back 202=back
145 203
146=cut 204=cut
147 205
148############################################################################# 206#############################################################################
… …
454=cut 512=cut
455 513
456############################################################################# 514#############################################################################
457# object support 515# object support
458 516
517sub reattach {
518 # basically do the same as instantiate, without calling instantiate
519 my ($obj) = @_;
520
521 my $registry = $obj->registry;
522
523 @$registry = ();
524
525 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
526
527 for my $name (keys %{ $obj->{_attachment} || {} }) {
528 if (my $attach = $attachment{$name}) {
529 for (@$attach) {
530 my ($klass, @attach) = @$_;
531 _attach $registry, $klass, @attach;
532 }
533 } else {
534 warn "object uses attachment '$name' that is not available, postponing.\n";
535 }
536 }
537}
538
459cf::attachable->attach ( 539cf::attachable->attach (
460 prio => -1000000, 540 prio => -1000000,
461 on_instantiate => sub { 541 on_instantiate => sub {
462 my ($obj, $data) = @_; 542 my ($obj, $data) = @_;
463 543
… …
467 my ($name, $args) = @$_; 547 my ($name, $args) = @$_;
468 548
469 $obj->attach ($name, %{$args || {} }); 549 $obj->attach ($name, %{$args || {} });
470 } 550 }
471 }, 551 },
472 on_reattach => sub { 552 on_reattach => \&reattach,
473 # basically do the same as instantiate, without calling instantiate
474 my ($obj) = @_;
475 my $registry = $obj->registry;
476
477 @$registry = ();
478
479 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
480
481 for my $name (keys %{ $obj->{_attachment} || {} }) {
482 if (my $attach = $attachment{$name}) {
483 for (@$attach) {
484 my ($klass, @attach) = @$_;
485 _attach $registry, $klass, @attach;
486 }
487 } else {
488 warn "object uses attachment '$name' that is not available, postponing.\n";
489 }
490 }
491 },
492 on_clone => sub { 553 on_clone => sub {
493 my ($src, $dst) = @_; 554 my ($src, $dst) = @_;
494 555
495 @{$dst->registry} = @{$src->registry}; 556 @{$dst->registry} = @{$src->registry};
496 557
… …
913 my $coro; $coro = async { 974 my $coro; $coro = async {
914 eval { 975 eval {
915 $cb->(); 976 $cb->();
916 }; 977 };
917 warn $@ if $@; 978 warn $@ if $@;
979 };
980
981 $coro->on_destroy (sub {
918 delete $self->{_coro}{$coro+0}; 982 delete $self->{_coro}{$coro+0};
919 }; 983 });
920 984
921 $self->{_coro}{$coro+0} = $coro; 985 $self->{_coro}{$coro+0} = $coro;
986
987 $coro
922} 988}
923 989
924cf::client->attach ( 990cf::client->attach (
925 on_destroy => sub { 991 on_destroy => sub {
926 my ($ns) = @_; 992 my ($ns) = @_;
… …
1167} 1233}
1168 1234
1169############################################################################# 1235#############################################################################
1170# initialisation 1236# initialisation
1171 1237
1172sub _perl_reload(&) { 1238sub _perl_reload() {
1173 my ($msg) = @_; 1239 warn "reloading...";
1174
1175 $msg->("reloading...");
1176 1240
1177 eval { 1241 eval {
1242 local $FREEZE = 1;
1243
1244 cf::emergency_save;
1245
1178 # cancel all watchers 1246 # cancel all watchers
1179 for (Event::all_watchers) { 1247 for (Event::all_watchers) {
1180 $_->cancel if $_->data & WF_AUTOCANCEL; 1248 $_->cancel if $_->data & WF_AUTOCANCEL;
1181 } 1249 }
1182 1250
1251 # cancel all extension coros
1252 $_->cancel for values %EXT_CORO;
1253 %EXT_CORO = ();
1254
1183 # unload all extensions 1255 # unload all extensions
1184 for (@exts) { 1256 for (@exts) {
1185 $msg->("unloading <$_>"); 1257 warn "unloading <$_>";
1186 unload_extension $_; 1258 unload_extension $_;
1187 } 1259 }
1188 1260
1189 # unload all modules loaded from $LIBDIR 1261 # unload all modules loaded from $LIBDIR
1190 while (my ($k, $v) = each %INC) { 1262 while (my ($k, $v) = each %INC) {
1191 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1263 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1192 1264
1193 $msg->("removing <$k>"); 1265 warn "removing <$k>";
1194 delete $INC{$k}; 1266 delete $INC{$k};
1195 1267
1196 $k =~ s/\.pm$//; 1268 $k =~ s/\.pm$//;
1197 $k =~ s/\//::/g; 1269 $k =~ s/\//::/g;
1198 1270
… …
1203 Symbol::delete_package $k; 1275 Symbol::delete_package $k;
1204 } 1276 }
1205 1277
1206 # sync database to disk 1278 # sync database to disk
1207 cf::db_sync; 1279 cf::db_sync;
1280 IO::AIO::flush;
1208 1281
1209 # get rid of safe::, as good as possible 1282 # get rid of safe::, as good as possible
1210 Symbol::delete_package "safe::$_" 1283 Symbol::delete_package "safe::$_"
1211 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);
1212 1285
1213 # remove register_script_function callbacks 1286 # remove register_script_function callbacks
1214 # TODO 1287 # TODO
1215 1288
1216 # unload cf.pm "a bit" 1289 # unload cf.pm "a bit"
… …
1219 # don't, removes xs symbols, too, 1292 # don't, removes xs symbols, too,
1220 # and global variables created in xs 1293 # and global variables created in xs
1221 #Symbol::delete_package __PACKAGE__; 1294 #Symbol::delete_package __PACKAGE__;
1222 1295
1223 # reload cf.pm 1296 # reload cf.pm
1224 $msg->("reloading cf.pm"); 1297 warn "reloading cf.pm";
1225 require cf; 1298 require cf;
1226 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 1299 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1227 1300
1228 # load config and database again 1301 # load config and database again
1229 cf::cfg_load; 1302 cf::cfg_load;
1230 cf::db_load; 1303 cf::db_load;
1231 1304
1232 # load extensions 1305 # load extensions
1233 $msg->("load extensions"); 1306 warn "load extensions";
1234 cf::load_extensions; 1307 cf::load_extensions;
1235 1308
1236 # reattach attachments to objects 1309 # reattach attachments to objects
1237 $msg->("reattach"); 1310 warn "reattach";
1238 _global_reattach; 1311 _global_reattach;
1239 }; 1312 };
1240 $msg->($@) if $@; 1313 warn $@ if $@;
1241 1314
1242 $msg->("reloaded"); 1315 warn "reloaded";
1243}; 1316};
1244 1317
1245sub perl_reload() { 1318sub perl_reload() {
1246 _perl_reload { 1319 _perl_reload;
1247 warn $_[0];
1248 print "$_[0]\n";
1249 };
1250} 1320}
1251 1321
1252register "<global>", __PACKAGE__; 1322register "<global>", __PACKAGE__;
1253 1323
1254register_command "perl-reload" => sub { 1324register_command "perl-reload" => sub {
1255 my ($who, $arg) = @_; 1325 my ($who, $arg) = @_;
1256 1326
1257 if ($who->flag (FLAG_WIZ)) { 1327 if ($who->flag (FLAG_WIZ)) {
1328 $who->message ("reloading...");
1258 _perl_reload { 1329 _perl_reload;
1259 warn $_[0];
1260 $who->message ($_[0]);
1261 };
1262 } 1330 }
1263}; 1331};
1264 1332
1265unshift @INC, $LIBDIR; 1333unshift @INC, $LIBDIR;
1266 1334
1267$TICK_WATCHER = Event->timer ( 1335$TICK_WATCHER = Event->timer (
1268 prio => 0, 1336 prio => 0,
1269 at => $NEXT_TICK || 1, 1337 at => $NEXT_TICK || $TICK,
1270 data => WF_AUTOCANCEL, 1338 data => WF_AUTOCANCEL,
1271 cb => sub { 1339 cb => sub {
1340 unless ($FREEZE) {
1272 cf::server_tick; # one server iteration 1341 cf::server_tick; # one server iteration
1342 $RUNTIME += $TICK;
1343 }
1273 1344
1274 my $NOW = Event::time;
1275 $NEXT_TICK += $TICK; 1345 $NEXT_TICK += $TICK;
1276 1346
1277 # if we are delayed by four ticks or more, skip them all 1347 # if we are delayed by four ticks or more, skip them all
1278 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1348 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1279 1349
1280 $TICK_WATCHER->at ($NEXT_TICK); 1350 $TICK_WATCHER->at ($NEXT_TICK);
1281 $TICK_WATCHER->start; 1351 $TICK_WATCHER->start;
1282 }, 1352 },
1283); 1353);
… …
1288 poll => 'r', 1358 poll => 'r',
1289 prio => 5, 1359 prio => 5,
1290 data => WF_AUTOCANCEL, 1360 data => WF_AUTOCANCEL,
1291 cb => \&IO::AIO::poll_cb); 1361 cb => \&IO::AIO::poll_cb);
1292 1362
1363# we must not ever block the main coroutine
1364$Coro::idle = sub {
1365 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1366 warn "FATAL: Coro::idle was called, major BUG\n";
1367 (Coro::unblock_sub {
1368 Event::one_event;
1369 })->();
1370};
1371
12931 13721
1294 1373

Diff Legend

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