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.448 by root, Fri Sep 19 05:30:23 2008 UTC vs.
Revision 1.479 by root, Thu Oct 8 05:04:27 2009 UTC

… …
21 21
22package cf; 22package cf;
23 23
24use 5.10.0; 24use 5.10.0;
25use utf8; 25use utf8;
26use strict "vars", "subs"; 26use strict qw(vars subs);
27 27
28use Symbol; 28use Symbol;
29use List::Util; 29use List::Util;
30use Socket; 30use Socket;
31use EV; 31use EV;
32use Opcode; 32use Opcode;
33use Safe; 33use Safe;
34use Safe::Hole; 34use Safe::Hole;
35use Storable (); 35use Storable ();
36 36
37use Guard ();
37use Coro (); 38use Coro ();
38use Coro::State; 39use Coro::State;
39use Coro::Handle; 40use Coro::Handle;
40use Coro::EV; 41use Coro::EV;
41use Coro::AnyEvent; 42use Coro::AnyEvent;
42use Coro::Timer; 43use Coro::Timer;
43use Coro::Signal; 44use Coro::Signal;
44use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
45use Coro::AnyEvent; 47use Coro::AnyEvent;
46use Coro::AIO; 48use Coro::AIO;
47use Coro::BDB 1.6; 49use Coro::BDB 1.6;
48use Coro::Storable; 50use Coro::Storable;
49use Coro::Util (); 51use Coro::Util ();
… …
66$Storable::canonical = 1; # reduce rsync transfers 68$Storable::canonical = 1; # reduce rsync transfers
67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 69Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
68 70
69$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 71$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
70 72
71{ 73# make sure c-lzf reinitialises itself
72 # very ugly, but ensure we acquire the storable lock
73
74 sub net_mstore {
75 my $guard = Coro::Storable::guard;
76 &Storable::net_mstore
77 }
78
79 sub mretrieve {
80 my $guard = Coro::Storable::guard;
81 &Storable::mretrieve
82 }
83
84 Compress::LZF::set_serializer "Coro::Storable", "cf::net_mstore", "cf::mretrieve"; 74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
85 Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
86} 76
77# strictly for debugging
78$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
87 79
88sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 80sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
89 81
90our %COMMAND = (); 82our %COMMAND = ();
91our %COMMAND_TIME = (); 83our %COMMAND_TIME = ();
… …
94our %EXTCMD = (); 86our %EXTCMD = ();
95our %EXTICMD = (); 87our %EXTICMD = ();
96our %EXT_CORO = (); # coroutines bound to extensions 88our %EXT_CORO = (); # coroutines bound to extensions
97our %EXT_MAP = (); # pluggable maps 89our %EXT_MAP = (); # pluggable maps
98 90
99our $RELOAD; # number of reloads so far 91our $RELOAD; # number of reloads so far, non-zero while in reload
100our @EVENT; 92our @EVENT;
93our @REFLECT; # set by XS
94our %REFLECT; # set by us
101 95
102our $CONFDIR = confdir; 96our $CONFDIR = confdir;
103our $DATADIR = datadir; 97our $DATADIR = datadir;
104our $LIBDIR = "$DATADIR/ext"; 98our $LIBDIR = "$DATADIR/ext";
105our $PODDIR = "$DATADIR/pod"; 99our $PODDIR = "$DATADIR/pod";
… …
116our %RESOURCE; 110our %RESOURCE;
117 111
118our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 112our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
119our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 113our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
120our $NEXT_TICK; 114our $NEXT_TICK;
121our $USE_FSYNC = 1; # use fsync to write maps - default off 115our $USE_FSYNC = 1; # use fsync to write maps - default on
122 116
123our $BDB_DEADLOCK_WATCHER; 117our $BDB_DEADLOCK_WATCHER;
124our $BDB_CHECKPOINT_WATCHER; 118our $BDB_CHECKPOINT_WATCHER;
125our $BDB_TRICKLE_WATCHER; 119our $BDB_TRICKLE_WATCHER;
126our $DB_ENV; 120our $DB_ENV;
127 121
122our @EXTRA_MODULES = qw(pod mapscript);
123
128our %CFG; 124our %CFG;
129 125
130our $UPTIME; $UPTIME ||= time; 126our $UPTIME; $UPTIME ||= time;
131our $RUNTIME; 127our $RUNTIME;
132our $NOW; 128our $NOW;
… …
140 136
141our $LOAD; # a number between 0 (idle) and 1 (too many objects) 137our $LOAD; # a number between 0 (idle) and 1 (too many objects)
142our $LOADAVG; # same thing, but with alpha-smoothing 138our $LOADAVG; # same thing, but with alpha-smoothing
143our $JITTER; # average jitter 139our $JITTER; # average jitter
144our $TICK_START; # for load detecting purposes 140our $TICK_START; # for load detecting purposes
141
142our @POST_INIT;
143
144our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
145our $REALLY_UNLOOP; # never set to true, please :)
145 146
146binmode STDOUT; 147binmode STDOUT;
147binmode STDERR; 148binmode STDERR;
148 149
149# read virtual server time, if available 150# read virtual server time, if available
… …
151 open my $fh, "<", $RUNTIMEFILE 152 open my $fh, "<", $RUNTIMEFILE
152 or die "unable to read $RUNTIMEFILE file: $!"; 153 or die "unable to read $RUNTIMEFILE file: $!";
153 $RUNTIME = <$fh> + 0.; 154 $RUNTIME = <$fh> + 0.;
154} 155}
155 156
157eval "sub TICK() { $TICK } 1" or die;
158
156mkdir $_ 159mkdir $_
157 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 160 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
158 161
159our $EMERGENCY_POSITION; 162our $EMERGENCY_POSITION;
160 163
161sub cf::map::normalise; 164sub cf::map::normalise;
165
166#############################################################################
167
168%REFLECT = ();
169for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect;
172}
162 173
163############################################################################# 174#############################################################################
164 175
165=head2 GLOBAL VARIABLES 176=head2 GLOBAL VARIABLES
166 177
… …
217 228
218This array contains the results of the last C<invoke ()> call. When 229This array contains the results of the last C<invoke ()> call. When
219C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 230C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
220that call. 231that call.
221 232
233=item %cf::REFLECT
234
235Contains, for each (C++) class name, a hash reference with information
236about object members (methods, scalars and arrays) and other metadata,
237which is useful for introspection.
238
222=back 239=back
223 240
224=cut 241=cut
225 242
226BEGIN { 243$Coro::State::WARNHOOK = sub {
227 *CORE::GLOBAL::warn = sub {
228 my $msg = join "", @_; 244 my $msg = join "", @_;
229 245
230 $msg .= "\n" 246 $msg .= "\n"
231 unless $msg =~ /\n$/; 247 unless $msg =~ /\n$/;
232 248
233 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 249 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
234 250
235 LOG llevError, $msg; 251 LOG llevError, $msg;
236 }; 252};
237}
238 253
239$Coro::State::DIEHOOK = sub { 254$Coro::State::DIEHOOK = sub {
240 return unless $^S eq 0; # "eq", not "==" 255 return unless $^S eq 0; # "eq", not "=="
256
257 warn Carp::longmess $_[0];
241 258
242 if ($Coro::current == $Coro::main) {#d# 259 if ($Coro::current == $Coro::main) {#d#
243 warn "DIEHOOK called in main context, Coro bug?\n";#d# 260 warn "DIEHOOK called in main context, Coro bug?\n";#d#
244 return;#d# 261 return;#d#
245 }#d# 262 }#d#
246 263
247 # kill coroutine otherwise 264 # kill coroutine otherwise
248 warn Carp::longmess $_[0];
249 Coro::terminate 265 Coro::terminate
250}; 266};
251
252$SIG{__DIE__} = sub { }; #d#?
253 267
254@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 268@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
255@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 269@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
256@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 270@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
257@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 271@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
318our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 332our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
319 333
320sub encode_json($) { $json_coder->encode ($_[0]) } 334sub encode_json($) { $json_coder->encode ($_[0]) }
321sub decode_json($) { $json_coder->decode ($_[0]) } 335sub decode_json($) { $json_coder->decode ($_[0]) }
322 336
337=item cf::post_init { BLOCK }
338
339Execute the given codeblock, I<after> all extensions have been (re-)loaded,
340but I<before> the server starts ticking again.
341
342The cdoeblock will have a single boolean argument to indicate whether this
343is a reload or not.
344
345=cut
346
347sub post_init(&) {
348 push @POST_INIT, shift;
349}
350
323=item cf::lock_wait $string 351=item cf::lock_wait $string
324 352
325Wait until the given lock is available. See cf::lock_acquire. 353Wait until the given lock is available. See cf::lock_acquire.
326 354
327=item my $lock = cf::lock_acquire $string 355=item my $lock = cf::lock_acquire $string
328 356
329Wait until the given lock is available and then acquires it and returns 357Wait until the given lock is available and then acquires it and returns
330a Coro::guard object. If the guard object gets destroyed (goes out of scope, 358a L<Guard> object. If the guard object gets destroyed (goes out of scope,
331for example when the coroutine gets canceled), the lock is automatically 359for example when the coroutine gets canceled), the lock is automatically
332returned. 360returned.
333 361
334Locks are *not* recursive, locking from the same coro twice results in a 362Locks are *not* recursive, locking from the same coro twice results in a
335deadlocked coro. 363deadlocked coro.
… …
341 369
342Return true if the lock is currently active, i.e. somebody has locked it. 370Return true if the lock is currently active, i.e. somebody has locked it.
343 371
344=cut 372=cut
345 373
346our %LOCK; 374our $LOCKS = new Coro::SemaphoreSet;
347our %LOCKER;#d#
348 375
349sub lock_wait($) { 376sub lock_wait($) {
350 my ($key) = @_; 377 $LOCKS->wait ($_[0]);
351
352 if ($LOCKER{$key} == $Coro::current) {#d#
353 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
354 return;#d#
355 }#d#
356
357 # wait for lock, if any
358 while ($LOCK{$key}) {
359 push @{ $LOCK{$key} }, $Coro::current;
360 Coro::schedule;
361 }
362} 378}
363 379
364sub lock_acquire($) { 380sub lock_acquire($) {
365 my ($key) = @_; 381 $LOCKS->guard ($_[0])
366
367 # wait, to be sure we are not locked
368 lock_wait $key;
369
370 $LOCK{$key} = [];
371 $LOCKER{$key} = $Coro::current;#d#
372
373 Coro::guard {
374 delete $LOCKER{$key};#d#
375 # wake up all waiters, to be on the safe side
376 $_->ready for @{ delete $LOCK{$key} };
377 }
378} 382}
379 383
380sub lock_active($) { 384sub lock_active($) {
381 my ($key) = @_; 385 $LOCKS->count ($_[0]) < 1
382
383 ! ! $LOCK{$key}
384} 386}
385 387
386sub freeze_mainloop { 388sub freeze_mainloop {
387 tick_inhibit_inc; 389 tick_inhibit_inc;
388 390
389 Coro::guard \&tick_inhibit_dec; 391 &Guard::guard (\&tick_inhibit_dec);
390} 392}
391 393
392=item cf::periodic $interval, $cb 394=item cf::periodic $interval, $cb
393 395
394Like EV::periodic, but randomly selects a starting point so that the actions 396Like EV::periodic, but randomly selects a starting point so that the actions
… …
1166 $decname, length $$rdata, scalar @$objs; 1168 $decname, length $$rdata, scalar @$objs;
1167 1169
1168 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1170 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1169 aio_chmod $fh, SAVE_MODE; 1171 aio_chmod $fh, SAVE_MODE;
1170 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1172 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1171 aio_fsync $fh if $cf::USE_FSYNC; 1173 if ($cf::USE_FSYNC) {
1174 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1175 aio_fsync $fh;
1176 }
1172 aio_close $fh; 1177 aio_close $fh;
1173 1178
1174 if (@$objs) { 1179 if (@$objs) {
1175 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1180 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1176 aio_chmod $fh, SAVE_MODE; 1181 aio_chmod $fh, SAVE_MODE;
1177 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1182 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1178 aio_write $fh, 0, (length $data), $data, 0; 1183 aio_write $fh, 0, (length $data), $data, 0;
1179 aio_fsync $fh if $cf::USE_FSYNC; 1184 if ($cf::USE_FSYNC) {
1185 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1186 aio_fsync $fh;
1187 }
1180 aio_close $fh; 1188 aio_close $fh;
1181 aio_rename "$filename.pst~", "$filename.pst"; 1189 aio_rename "$filename.pst~", "$filename.pst";
1182 } 1190 }
1183 } else { 1191 } else {
1184 aio_unlink "$filename.pst"; 1192 aio_unlink "$filename.pst";
1185 } 1193 }
1186 1194
1187 aio_rename "$filename~", $filename; 1195 aio_rename "$filename~", $filename;
1196
1197 $filename =~ s%/[^/]+$%%;
1198 aio_pathsync $filename if $cf::USE_FSYNC;
1188 } else { 1199 } else {
1189 warn "FATAL: $filename~: $!\n"; 1200 warn "unable to save objects: $filename~: $!\n";
1190 } 1201 }
1191 } else { 1202 } else {
1192 aio_unlink $filename; 1203 aio_unlink $filename;
1193 aio_unlink "$filename.pst"; 1204 aio_unlink "$filename.pst";
1194 } 1205 }
… …
1285 my ($name, $cb) = @_; 1296 my ($name, $cb) = @_;
1286 1297
1287 $EXTICMD{$name} = $cb; 1298 $EXTICMD{$name} = $cb;
1288} 1299}
1289 1300
1301use File::Glob ();
1302
1290cf::player->attach ( 1303cf::player->attach (
1291 on_command => sub { 1304 on_command => sub {
1292 my ($pl, $name, $params) = @_; 1305 my ($pl, $name, $params) = @_;
1293 1306
1294 my $cb = $COMMAND{$name} 1307 my $cb = $COMMAND{$name}
… …
1325 } 1338 }
1326 1339
1327 cf::override; 1340 cf::override;
1328 }, 1341 },
1329); 1342);
1343
1344# "readahead" all extensions
1345sub cache_extensions {
1346 my $grp = IO::AIO::aio_group;
1347
1348 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1349 for (grep /\.ext$/, @{$_[0]}) {
1350 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1351 }
1352 };
1353
1354 $grp
1355}
1330 1356
1331sub load_extensions { 1357sub load_extensions {
1332 cf::sync_job { 1358 cf::sync_job {
1333 my %todo; 1359 my %todo;
1334 1360
… …
1457 1483
1458sub exists($) { 1484sub exists($) {
1459 my ($login) = @_; 1485 my ($login) = @_;
1460 1486
1461 $cf::PLAYER{$login} 1487 $cf::PLAYER{$login}
1462 or cf::sync_job { !aio_stat path $login } 1488 or !aio_stat path $login
1463} 1489}
1464 1490
1465sub find($) { 1491sub find($) {
1466 return $cf::PLAYER{$_[0]} || do { 1492 return $cf::PLAYER{$_[0]} || do {
1467 my $login = $_[0]; 1493 my $login = $_[0];
… …
1863 1889
1864 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1890 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1865 "$UNIQUEDIR/$path" 1891 "$UNIQUEDIR/$path"
1866} 1892}
1867 1893
1868# and all this just because we cannot iterate over
1869# all maps in C++...
1870sub change_all_map_light {
1871 my ($change) = @_;
1872
1873 $_->change_map_light ($change)
1874 for grep $_->outdoor, values %cf::MAP;
1875}
1876
1877sub decay_objects { 1894sub decay_objects {
1878 my ($self) = @_; 1895 my ($self) = @_;
1879 1896
1880 return if $self->{deny_reset}; 1897 return if $self->{deny_reset};
1881 1898
… …
1963sub find { 1980sub find {
1964 my ($path, $origin) = @_; 1981 my ($path, $origin) = @_;
1965 1982
1966 $path = normalise $path, $origin && $origin->path; 1983 $path = normalise $path, $origin && $origin->path;
1967 1984
1968 cf::lock_wait "map_data:$path";#d#remove 1985 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1969 cf::lock_wait "map_find:$path"; 1986 my $guard2 = cf::lock_acquire "map_find:$path";
1970 1987
1971 $cf::MAP{$path} || do { 1988 $cf::MAP{$path} || do {
1972 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1973 my $guard2 = cf::lock_acquire "map_find:$path";
1974
1975 my $map = new_from_path cf::map $path 1989 my $map = new_from_path cf::map $path
1976 or return; 1990 or return;
1977 1991
1978 $map->{last_save} = $cf::RUNTIME; 1992 $map->{last_save} = $cf::RUNTIME;
1979 1993
… …
2047 unless ($self->{deny_activate}) { 2061 unless ($self->{deny_activate}) {
2048 $self->decay_objects; 2062 $self->decay_objects;
2049 $self->fix_auto_apply; 2063 $self->fix_auto_apply;
2050 $self->update_buttons; 2064 $self->update_buttons;
2051 cf::cede_to_tick; 2065 cf::cede_to_tick;
2052 $self->set_darkness_map;
2053 cf::cede_to_tick;
2054 $self->activate; 2066 $self->activate;
2055 } 2067 }
2056 2068
2057 $self->{last_save} = $cf::RUNTIME; 2069 $self->{last_save} = $cf::RUNTIME;
2058 $self->last_access ($cf::RUNTIME); 2070 $self->last_access ($cf::RUNTIME);
… …
2224 2236
2225 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2237 my $lock = cf::lock_acquire "map_data:$self->{path}";
2226 2238
2227 return if $self->players; 2239 return if $self->players;
2228 2240
2229 warn "resetting map ", $self->path; 2241 warn "resetting map ", $self->path, "\n";
2230 2242
2231 $self->in_memory (cf::MAP_SWAPPED); 2243 $self->in_memory (cf::MAP_SWAPPED);
2232 2244
2233 # need to save uniques path 2245 # need to save uniques path
2234 unless ($self->{deny_save}) { 2246 unless ($self->{deny_save}) {
… …
2399 2411
2400our $SAY_CHANNEL = { 2412our $SAY_CHANNEL = {
2401 id => "say", 2413 id => "say",
2402 title => "Map", 2414 title => "Map",
2403 reply => "say ", 2415 reply => "say ",
2404 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2416 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2405}; 2417};
2406 2418
2407our $CHAT_CHANNEL = { 2419our $CHAT_CHANNEL = {
2408 id => "chat", 2420 id => "chat",
2409 title => "Chat", 2421 title => "Chat",
… …
2535 2547
2536 $map->load; 2548 $map->load;
2537 $map->load_neighbours; 2549 $map->load_neighbours;
2538 2550
2539 return unless $self->contr->active; 2551 return unless $self->contr->active;
2540 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2541 $self->activate_recursive;
2542 2552
2543 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2553 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2544 $self->enter_map ($map, $x, $y); 2554 $self->enter_map ($map, $x, $y);
2555
2556 # only activate afterwards, to support waiting in hooks
2557 $self->activate_recursive;
2545} 2558}
2546 2559
2547=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2560=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2548 2561
2549Moves the player to the given map-path and coordinates by first freezing 2562Moves the player to the given map-path and coordinates by first freezing
… …
2784 id => "infobox", 2797 id => "infobox",
2785 title => "Body Parts", 2798 title => "Body Parts",
2786 reply => undef, 2799 reply => undef,
2787 tooltip => "Shows which body parts you posess and are available", 2800 tooltip => "Shows which body parts you posess and are available",
2788 }, 2801 },
2802 "c/statistics" => {
2803 id => "infobox",
2804 title => "Statistics",
2805 reply => undef,
2806 tooltip => "Shows your primary statistics",
2807 },
2808 "c/skills" => {
2809 id => "infobox",
2810 title => "Skills",
2811 reply => undef,
2812 tooltip => "Shows your experience per skill and item power",
2813 },
2814 "c/shopitems" => {
2815 id => "infobox",
2816 title => "Shop Items",
2817 reply => undef,
2818 tooltip => "Shows the items currently for sale in this shop",
2819 },
2820 "c/resistances" => {
2821 id => "infobox",
2822 title => "Resistances",
2823 reply => undef,
2824 tooltip => "Shows your resistances",
2825 },
2826 "c/pets" => {
2827 id => "infobox",
2828 title => "Pets",
2829 reply => undef,
2830 tooltip => "Shows information abotu your pets/a specific pet",
2831 },
2832 "c/perceiveself" => {
2833 id => "infobox",
2834 title => "Perceive Self",
2835 reply => undef,
2836 tooltip => "You gained detailed knowledge about yourself",
2837 },
2789 "c/uptime" => { 2838 "c/uptime" => {
2790 id => "infobox", 2839 id => "infobox",
2791 title => "Uptime", 2840 title => "Uptime",
2792 reply => undef, 2841 reply => undef,
2793 tooltip => "How long the server has been running since last restart", 2842 tooltip => "How long the server has been running since last restart",
… …
2802 id => "party", 2851 id => "party",
2803 title => "Party", 2852 title => "Party",
2804 reply => "gsay ", 2853 reply => "gsay ",
2805 tooltip => "Messages and chat related to your party", 2854 tooltip => "Messages and chat related to your party",
2806 }, 2855 },
2856 "c/death" => {
2857 id => "death",
2858 title => "Death",
2859 reply => undef,
2860 tooltip => "Reason for and more info about your most recent death",
2861 },
2862 "c/say" => $SAY_CHANNEL,
2863 "c/chat" => $CHAT_CHANNEL,
2807); 2864);
2808 2865
2809sub cf::client::send_msg { 2866sub cf::client::send_msg {
2810 my ($self, $channel, $msg, $color, @extra) = @_; 2867 my ($self, $channel, $msg, $color, @extra) = @_;
2811 2868
… …
2816 2873
2817 # check predefined channels, for the benefit of C 2874 # check predefined channels, for the benefit of C
2818 if ($CHANNEL{$channel}) { 2875 if ($CHANNEL{$channel}) {
2819 $channel = $CHANNEL{$channel}; 2876 $channel = $CHANNEL{$channel};
2820 2877
2821 $self->ext_msg (channel_info => $channel) 2878 $self->ext_msg (channel_info => $channel);
2822 if $self->can_msg;
2823
2824 $channel = $channel->{id}; 2879 $channel = $channel->{id};
2825 2880
2826 } elsif (ref $channel) { 2881 } elsif (ref $channel) {
2827 # send meta info to client, if not yet sent 2882 # send meta info to client, if not yet sent
2828 unless (exists $self->{channel}{$channel->{id}}) { 2883 unless (exists $self->{channel}{$channel->{id}}) {
2829 $self->{channel}{$channel->{id}} = $channel; 2884 $self->{channel}{$channel->{id}} = $channel;
2830 $self->ext_msg (channel_info => $channel) 2885 $self->ext_msg (channel_info => $channel);
2831 if $self->can_msg;
2832 } 2886 }
2833 2887
2834 $channel = $channel->{id}; 2888 $channel = $channel->{id};
2835 } 2889 }
2836 2890
2837 return unless @extra || length $msg; 2891 return unless @extra || length $msg;
2838 2892
2839 if ($self->can_msg) {
2840 # default colour, mask it out 2893 # default colour, mask it out
2841 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2894 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2842 if $color & cf::NDI_DEF; 2895 if $color & cf::NDI_DEF;
2843 2896
2844 my $pkt = "msg " 2897 my $pkt = "msg "
2845 . $self->{json_coder}->encode ( 2898 . $self->{json_coder}->encode (
2846 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2899 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2847 ); 2900 );
2848 2901
2849 # try lzf for large packets 2902 # try lzf for large packets
2850 $pkt = "lzf " . Compress::LZF::compress $pkt 2903 $pkt = "lzf " . Compress::LZF::compress $pkt
2851 if 1024 <= length $pkt and $self->{can_lzf}; 2904 if 1024 <= length $pkt and $self->{can_lzf};
2852 2905
2853 # split very large packets 2906 # split very large packets
2854 if (8192 < length $pkt and $self->{can_lzf}) { 2907 if (8192 < length $pkt and $self->{can_lzf}) {
2855 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt; 2908 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2856 $pkt = "frag"; 2909 $pkt = "frag";
2857 } 2910 }
2858 2911
2859 $self->send_packet ($pkt); 2912 $self->send_packet ($pkt);
2860 } else {
2861 if ($color >= 0) {
2862 # replace some tags by gcfclient-compatible ones
2863 for ($msg) {
2864 1 while
2865 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2866 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2867 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2868 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2869 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2870 }
2871
2872 $color &= cf::NDI_COLOR_MASK;
2873
2874 utf8::encode $msg;
2875
2876 if (0 && $msg =~ /\[/) {
2877 # COMMAND/INFO
2878 $self->send_packet ("drawextinfo $color 10 8 $msg")
2879 } else {
2880 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2881 $self->send_packet ("drawinfo $color $msg")
2882 }
2883 }
2884 }
2885} 2913}
2886 2914
2887=item $client->ext_msg ($type, @msg) 2915=item $client->ext_msg ($type, @msg)
2888 2916
2889Sends an ext event to the client. 2917Sends an ext event to the client.
… …
3064The following functions and methods are available within a safe environment: 3092The following functions and methods are available within a safe environment:
3065 3093
3066 cf::object 3094 cf::object
3067 contr pay_amount pay_player map x y force_find force_add destroy 3095 contr pay_amount pay_player map x y force_find force_add destroy
3068 insert remove name archname title slaying race decrease split 3096 insert remove name archname title slaying race decrease split
3097 value
3069 3098
3070 cf::object::player 3099 cf::object::player
3071 player 3100 player
3072 3101
3073 cf::player 3102 cf::player
… …
3079=cut 3108=cut
3080 3109
3081for ( 3110for (
3082 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3111 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3083 insert remove inv nrof name archname title slaying race 3112 insert remove inv nrof name archname title slaying race
3084 decrease split destroy change_exp)], 3113 decrease split destroy change_exp value msg lore send_msg)],
3085 ["cf::object::player" => qw(player)], 3114 ["cf::object::player" => qw(player)],
3086 ["cf::player" => qw(peaceful)], 3115 ["cf::player" => qw(peaceful send_msg)],
3087 ["cf::map" => qw(trigger)], 3116 ["cf::map" => qw(trigger)],
3088) { 3117) {
3089 no strict 'refs'; 3118 no strict 'refs';
3090 my ($pkg, @funs) = @$_; 3119 my ($pkg, @funs) = @$_;
3091 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3120 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3108 my ($code, %vars) = @_; 3137 my ($code, %vars) = @_;
3109 3138
3110 my $qcode = $code; 3139 my $qcode = $code;
3111 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3140 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3112 $qcode =~ s/\n/\\n/g; 3141 $qcode =~ s/\n/\\n/g;
3142
3143 %vars = (_dummy => 0) unless %vars;
3113 3144
3114 local $_; 3145 local $_;
3115 local @safe::cf::_safe_eval_args = values %vars; 3146 local @safe::cf::_safe_eval_args = values %vars;
3116 3147
3117 my $eval = 3148 my $eval =
… …
3347 reload_treasures; 3378 reload_treasures;
3348 3379
3349 warn "finished reloading resource files\n"; 3380 warn "finished reloading resource files\n";
3350} 3381}
3351 3382
3352sub init {
3353 my $guard = freeze_mainloop;
3354
3355 evthread_start IO::AIO::poll_fileno;
3356
3357 reload_resources;
3358}
3359
3360sub reload_config { 3383sub reload_config {
3361 open my $fh, "<:utf8", "$CONFDIR/config" 3384 open my $fh, "<:utf8", "$CONFDIR/config"
3362 or return; 3385 or return;
3363 3386
3364 local $/; 3387 local $/;
… …
3395 3418
3396 seek $fh, 0, 0; 3419 seek $fh, 0, 0;
3397 print $fh $$; 3420 print $fh $$;
3398} 3421}
3399 3422
3423sub main_loop {
3424 warn "EV::loop starting\n";
3425 if (1) {
3426 EV::loop;
3427 }
3428 warn "EV::loop returned\n";
3429 goto &main_loop unless $REALLY_UNLOOP;
3430}
3431
3400sub main { 3432sub main {
3401 atomic; 3433 cf::init_globals; # initialise logging
3434
3435 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3436 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3437 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3438 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3439
3440 cf::init_experience;
3441 cf::init_anim;
3442 cf::init_attackmess;
3443 cf::init_dynamic;
3444
3445 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3402 3446
3403 # we must not ever block the main coroutine 3447 # we must not ever block the main coroutine
3404 local $Coro::idle = sub { 3448 local $Coro::idle = sub {
3405 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3449 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3406 (async { 3450 (async {
3407 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3451 $Coro::current->{desc} = "IDLE BUG HANDLER";
3408 EV::loop EV::LOOP_ONESHOT; 3452 EV::loop EV::LOOP_ONESHOT;
3409 })->prio (Coro::PRIO_MAX); 3453 })->prio (Coro::PRIO_MAX);
3410 }; 3454 };
3411 3455
3412 { 3456 evthread_start IO::AIO::poll_fileno;
3413 my $guard = freeze_mainloop; 3457
3458 cf::sync_job {
3459 reload_resources;
3414 reload_config; 3460 reload_config;
3415 db_init; 3461 db_init;
3462
3463 cf::load_settings;
3464 cf::load_materials;
3465 cf::init_uuid;
3466 cf::init_signals;
3467 cf::init_commands;
3468 cf::init_skills;
3469
3470 cf::init_beforeplay;
3471
3472 atomic;
3473
3416 load_extensions; 3474 load_extensions;
3417 3475
3418 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3419 }
3420
3421 utime time, time, $RUNTIMEFILE; 3476 utime time, time, $RUNTIMEFILE;
3422 3477
3423 # no (long-running) fork's whatsoever before this point(!) 3478 # no (long-running) fork's whatsoever before this point(!)
3479 use POSIX ();
3424 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3480 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3425 3481
3426 EV::loop; 3482 (pop @POST_INIT)->(0) while @POST_INIT;
3483 };
3484
3485 main_loop;
3427} 3486}
3428 3487
3429############################################################################# 3488#############################################################################
3430# initialisation and cleanup 3489# initialisation and cleanup
3431 3490
… …
3487 my $uuid = "$LOCALDIR/uuid"; 3546 my $uuid = "$LOCALDIR/uuid";
3488 3547
3489 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3548 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3490 or return; 3549 or return;
3491 3550
3492 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3551 my $value = uuid_seq uuid_cur;
3552
3553 unless ($value) {
3554 warn "cowardly refusing to write zero uuid value!\n";
3555 return;
3556 }
3557
3558 my $value = uuid_str $value + $uuid_skip;
3493 $uuid_skip = 0; 3559 $uuid_skip = 0;
3494 3560
3495 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3561 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3496 and return; 3562 and return;
3497 3563
… …
3519} 3585}
3520 3586
3521sub emergency_save() { 3587sub emergency_save() {
3522 my $freeze_guard = cf::freeze_mainloop; 3588 my $freeze_guard = cf::freeze_mainloop;
3523 3589
3524 warn "enter emergency perl save\n"; 3590 warn "emergency_perl_save: enter\n";
3525 3591
3526 cf::sync_job { 3592 cf::sync_job {
3593 # this is a trade-off: we want to be very quick here, so
3594 # save all maps without fsync, and later call a global sync
3595 # (which in turn might be very very slow)
3596 local $USE_FSYNC = 0;
3597
3527 # use a peculiar iteration method to avoid tripping on perl 3598 # use a peculiar iteration method to avoid tripping on perl
3528 # refcount bugs in for. also avoids problems with players 3599 # refcount bugs in for. also avoids problems with players
3529 # and maps saved/destroyed asynchronously. 3600 # and maps saved/destroyed asynchronously.
3530 warn "begin emergency player save\n"; 3601 warn "emergency_perl_save: begin player save\n";
3531 for my $login (keys %cf::PLAYER) { 3602 for my $login (keys %cf::PLAYER) {
3532 my $pl = $cf::PLAYER{$login} or next; 3603 my $pl = $cf::PLAYER{$login} or next;
3533 $pl->valid or next; 3604 $pl->valid or next;
3534 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3605 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3535 $pl->save; 3606 $pl->save;
3536 } 3607 }
3537 warn "end emergency player save\n"; 3608 warn "emergency_perl_save: end player save\n";
3538 3609
3539 warn "begin emergency map save\n"; 3610 warn "emergency_perl_save: begin map save\n";
3540 for my $path (keys %cf::MAP) { 3611 for my $path (keys %cf::MAP) {
3541 my $map = $cf::MAP{$path} or next; 3612 my $map = $cf::MAP{$path} or next;
3542 $map->valid or next; 3613 $map->valid or next;
3543 $map->save; 3614 $map->save;
3544 } 3615 }
3545 warn "end emergency map save\n"; 3616 warn "emergency_perl_save: end map save\n";
3546 3617
3547 warn "begin emergency database checkpoint\n"; 3618 warn "emergency_perl_save: begin database checkpoint\n";
3548 BDB::db_env_txn_checkpoint $DB_ENV; 3619 BDB::db_env_txn_checkpoint $DB_ENV;
3549 warn "end emergency database checkpoint\n"; 3620 warn "emergency_perl_save: end database checkpoint\n";
3550 3621
3551 warn "begin write uuid\n"; 3622 warn "emergency_perl_save: begin write uuid\n";
3552 write_uuid_sync 1; 3623 write_uuid_sync 1;
3553 warn "end write uuid\n"; 3624 warn "emergency_perl_save: end write uuid\n";
3554 }; 3625 };
3555 3626
3627 warn "emergency_perl_save: starting sync()\n";
3628 IO::AIO::aio_sync sub {
3629 warn "emergency_perl_save: finished sync()\n";
3630 };
3631
3556 warn "leave emergency perl save\n"; 3632 warn "emergency_perl_save: leave\n";
3557} 3633}
3558 3634
3559sub post_cleanup { 3635sub post_cleanup {
3560 my ($make_core) = @_; 3636 my ($make_core) = @_;
3561 3637
… …
3587 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3663 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3588 for my $name (keys %$leaf_symtab) { 3664 for my $name (keys %$leaf_symtab) {
3589 _gv_clear *{"$pkg$name"}; 3665 _gv_clear *{"$pkg$name"};
3590# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3666# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3591 } 3667 }
3592 warn "cleared package #$pkg\n";#d# 3668 warn "cleared package $pkg\n";#d#
3593} 3669}
3594
3595our $RELOAD; # how many times to reload
3596 3670
3597sub do_reload_perl() { 3671sub do_reload_perl() {
3598 # can/must only be called in main 3672 # can/must only be called in main
3599 if ($Coro::current != $Coro::main) { 3673 if ($Coro::current != $Coro::main) {
3600 warn "can only reload from main coroutine"; 3674 warn "can only reload from main coroutine";
3601 return; 3675 return;
3602 } 3676 }
3603 3677
3604 return if $RELOAD++; 3678 return if $RELOAD++;
3679
3680 my $t1 = EV::time;
3605 3681
3606 while ($RELOAD) { 3682 while ($RELOAD) {
3607 warn "reloading..."; 3683 warn "reloading...";
3608 3684
3609 warn "entering sync_job"; 3685 warn "entering sync_job";
… …
3670 clear_package "safe::$_" 3746 clear_package "safe::$_"
3671 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3747 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3672 3748
3673 warn "unloading cf.pm \"a bit\""; 3749 warn "unloading cf.pm \"a bit\"";
3674 delete $INC{"cf.pm"}; 3750 delete $INC{"cf.pm"};
3675 delete $INC{"cf/pod.pm"}; 3751 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3676 3752
3677 # don't, removes xs symbols, too, 3753 # don't, removes xs symbols, too,
3678 # and global variables created in xs 3754 # and global variables created in xs
3679 #clear_package __PACKAGE__; 3755 #clear_package __PACKAGE__;
3680 3756
… …
3688 cf::reload_config; 3764 cf::reload_config;
3689 3765
3690 warn "loading extensions"; 3766 warn "loading extensions";
3691 cf::load_extensions; 3767 cf::load_extensions;
3692 3768
3769 if ($REATTACH_ON_RELOAD) {
3693 warn "reattaching attachments to objects/players"; 3770 warn "reattaching attachments to objects/players";
3694 _global_reattach; # objects, sockets 3771 _global_reattach; # objects, sockets
3695 warn "reattaching attachments to maps"; 3772 warn "reattaching attachments to maps";
3696 reattach $_ for values %MAP; 3773 reattach $_ for values %MAP;
3697 warn "reattaching attachments to players"; 3774 warn "reattaching attachments to players";
3698 reattach $_ for values %PLAYER; 3775 reattach $_ for values %PLAYER;
3776 }
3777
3778 warn "running post_init jobs";
3779 (pop @POST_INIT)->(1) while @POST_INIT;
3699 3780
3700 warn "leaving sync_job"; 3781 warn "leaving sync_job";
3701 3782
3702 1 3783 1
3703 } or do { 3784 } or do {
… …
3706 }; 3787 };
3707 3788
3708 warn "reloaded"; 3789 warn "reloaded";
3709 --$RELOAD; 3790 --$RELOAD;
3710 } 3791 }
3792
3793 $t1 = EV::time - $t1;
3794 warn "reload completed in ${t1}s\n";
3711}; 3795};
3712 3796
3713our $RELOAD_WATCHER; # used only during reload 3797our $RELOAD_WATCHER; # used only during reload
3714 3798
3715sub reload_perl() { 3799sub reload_perl() {
3716 # doing reload synchronously and two reloads happen back-to-back, 3800 # doing reload synchronously and two reloads happen back-to-back,
3717 # coro crashes during coro_state_free->destroy here. 3801 # coro crashes during coro_state_free->destroy here.
3718 3802
3803 $RELOAD_WATCHER ||= cf::async {
3804 Coro::AIO::aio_wait cache_extensions;
3805
3719 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3806 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3720 do_reload_perl; 3807 do_reload_perl;
3721 undef $RELOAD_WATCHER; 3808 undef $RELOAD_WATCHER;
3809 };
3722 }; 3810 };
3723} 3811}
3724 3812
3725register_command "reload" => sub { 3813register_command "reload" => sub {
3726 my ($who, $arg) = @_; 3814 my ($who, $arg) = @_;
… …
3885 LOG llevInfo, "[ABT] [suppressed]\n"; 3973 LOG llevInfo, "[ABT] [suppressed]\n";
3886 } 3974 }
3887} 3975}
3888 3976
3889# load additional modules 3977# load additional modules
3890use cf::pod; 3978require "cf/$_.pm" for @EXTRA_MODULES;
3891 3979
3892END { cf::emergency_save } 3980END { cf::emergency_save }
3893 3981
38941 39821
3895 3983

Diff Legend

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