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.446 by root, Tue Sep 16 16:03:02 2008 UTC vs.
Revision 1.476 by root, Wed Sep 2 16:54:20 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 ();
… …
63 65
64# configure various modules to our taste 66# configure various modules to our taste
65# 67#
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
70
71$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
72
73# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
68Compress::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
69 76
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 77# strictly for debugging
78$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
71 79
72sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 80sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
73 81
74our %COMMAND = (); 82our %COMMAND = ();
75our %COMMAND_TIME = (); 83our %COMMAND_TIME = ();
… …
78our %EXTCMD = (); 86our %EXTCMD = ();
79our %EXTICMD = (); 87our %EXTICMD = ();
80our %EXT_CORO = (); # coroutines bound to extensions 88our %EXT_CORO = (); # coroutines bound to extensions
81our %EXT_MAP = (); # pluggable maps 89our %EXT_MAP = (); # pluggable maps
82 90
83our $RELOAD; # number of reloads so far 91our $RELOAD; # number of reloads so far, non-zero while in reload
84our @EVENT; 92our @EVENT;
85 93
86our $CONFDIR = confdir; 94our $CONFDIR = confdir;
87our $DATADIR = datadir; 95our $DATADIR = datadir;
88our $LIBDIR = "$DATADIR/ext"; 96our $LIBDIR = "$DATADIR/ext";
… …
100our %RESOURCE; 108our %RESOURCE;
101 109
102our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 110our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
103our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 111our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
104our $NEXT_TICK; 112our $NEXT_TICK;
105our $USE_FSYNC = 1; # use fsync to write maps - default off 113our $USE_FSYNC = 1; # use fsync to write maps - default on
106 114
107our $BDB_DEADLOCK_WATCHER; 115our $BDB_DEADLOCK_WATCHER;
108our $BDB_CHECKPOINT_WATCHER; 116our $BDB_CHECKPOINT_WATCHER;
109our $BDB_TRICKLE_WATCHER; 117our $BDB_TRICKLE_WATCHER;
110our $DB_ENV; 118our $DB_ENV;
111 119
120our @EXTRA_MODULES = qw(pod mapscript);
121
112our %CFG; 122our %CFG;
113 123
114our $UPTIME; $UPTIME ||= time; 124our $UPTIME; $UPTIME ||= time;
115our $RUNTIME; 125our $RUNTIME;
116our $NOW; 126our $NOW;
… …
124 134
125our $LOAD; # a number between 0 (idle) and 1 (too many objects) 135our $LOAD; # a number between 0 (idle) and 1 (too many objects)
126our $LOADAVG; # same thing, but with alpha-smoothing 136our $LOADAVG; # same thing, but with alpha-smoothing
127our $JITTER; # average jitter 137our $JITTER; # average jitter
128our $TICK_START; # for load detecting purposes 138our $TICK_START; # for load detecting purposes
139
140our @POST_INIT;
141
142our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
143our $REALLY_UNLOOP; # never set to true, please :)
129 144
130binmode STDOUT; 145binmode STDOUT;
131binmode STDERR; 146binmode STDERR;
132 147
133# read virtual server time, if available 148# read virtual server time, if available
134unless ($RUNTIME || !-e $RUNTIMEFILE) { 149unless ($RUNTIME || !-e $RUNTIMEFILE) {
135 open my $fh, "<", $RUNTIMEFILE 150 open my $fh, "<", $RUNTIMEFILE
136 or die "unable to read $RUNTIMEFILE file: $!"; 151 or die "unable to read $RUNTIMEFILE file: $!";
137 $RUNTIME = <$fh> + 0.; 152 $RUNTIME = <$fh> + 0.;
138} 153}
154
155eval "sub TICK() { $TICK } 1" or die;
139 156
140mkdir $_ 157mkdir $_
141 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 158 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
142 159
143our $EMERGENCY_POSITION; 160our $EMERGENCY_POSITION;
… …
302our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 319our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
303 320
304sub encode_json($) { $json_coder->encode ($_[0]) } 321sub encode_json($) { $json_coder->encode ($_[0]) }
305sub decode_json($) { $json_coder->decode ($_[0]) } 322sub decode_json($) { $json_coder->decode ($_[0]) }
306 323
324=item cf::post_init { BLOCK }
325
326Execute the given codeblock, I<after> all extensions have been (re-)loaded,
327but I<before> the server starts ticking again.
328
329The cdoeblock will have a single boolean argument to indicate whether this
330is a reload or not.
331
332=cut
333
334sub post_init(&) {
335 push @POST_INIT, shift;
336}
337
307=item cf::lock_wait $string 338=item cf::lock_wait $string
308 339
309Wait until the given lock is available. See cf::lock_acquire. 340Wait until the given lock is available. See cf::lock_acquire.
310 341
311=item my $lock = cf::lock_acquire $string 342=item my $lock = cf::lock_acquire $string
312 343
313Wait until the given lock is available and then acquires it and returns 344Wait until the given lock is available and then acquires it and returns
314a Coro::guard object. If the guard object gets destroyed (goes out of scope, 345a L<Guard> object. If the guard object gets destroyed (goes out of scope,
315for example when the coroutine gets canceled), the lock is automatically 346for example when the coroutine gets canceled), the lock is automatically
316returned. 347returned.
317 348
318Locks are *not* recursive, locking from the same coro twice results in a 349Locks are *not* recursive, locking from the same coro twice results in a
319deadlocked coro. 350deadlocked coro.
… …
325 356
326Return true if the lock is currently active, i.e. somebody has locked it. 357Return true if the lock is currently active, i.e. somebody has locked it.
327 358
328=cut 359=cut
329 360
330our %LOCK; 361our $LOCKS = new Coro::SemaphoreSet;
331our %LOCKER;#d#
332 362
333sub lock_wait($) { 363sub lock_wait($) {
334 my ($key) = @_; 364 $LOCKS->wait ($_[0]);
335
336 if ($LOCKER{$key} == $Coro::current) {#d#
337 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
338 return;#d#
339 }#d#
340
341 # wait for lock, if any
342 while ($LOCK{$key}) {
343 push @{ $LOCK{$key} }, $Coro::current;
344 Coro::schedule;
345 }
346} 365}
347 366
348sub lock_acquire($) { 367sub lock_acquire($) {
349 my ($key) = @_; 368 $LOCKS->guard ($_[0])
350
351 # wait, to be sure we are not locked
352 lock_wait $key;
353
354 $LOCK{$key} = [];
355 $LOCKER{$key} = $Coro::current;#d#
356
357 Coro::guard {
358 delete $LOCKER{$key};#d#
359 # wake up all waiters, to be on the safe side
360 $_->ready for @{ delete $LOCK{$key} };
361 }
362} 369}
363 370
364sub lock_active($) { 371sub lock_active($) {
365 my ($key) = @_; 372 $LOCKS->count ($_[0]) < 1
366
367 ! ! $LOCK{$key}
368} 373}
369 374
370sub freeze_mainloop { 375sub freeze_mainloop {
371 tick_inhibit_inc; 376 tick_inhibit_inc;
372 377
373 Coro::guard \&tick_inhibit_dec; 378 &Guard::guard (\&tick_inhibit_dec);
374} 379}
375 380
376=item cf::periodic $interval, $cb 381=item cf::periodic $interval, $cb
377 382
378Like EV::periodic, but randomly selects a starting point so that the actions 383Like EV::periodic, but randomly selects a starting point so that the actions
… …
730 735
731############################################################################# 736#############################################################################
732 737
733=head2 ATTACHABLE OBJECTS 738=head2 ATTACHABLE OBJECTS
734 739
735Many objects in crossfire are so-called attachable objects. That means you can 740Many objects in deliantra are so-called attachable objects. That means you can
736attach callbacks/event handlers (a collection of which is called an "attachment") 741attach callbacks/event handlers (a collection of which is called an "attachment")
737to it. All such attachable objects support the following methods. 742to it. All such attachable objects support the following methods.
738 743
739In the following description, CLASS can be any of C<global>, C<object> 744In the following description, CLASS can be any of C<global>, C<object>
740C<player>, C<client> or C<map> (i.e. the attachable objects in 745C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
790=item cf::CLASS::attachment $name, ... 795=item cf::CLASS::attachment $name, ...
791 796
792Register an attachment by C<$name> through which attachable objects of the 797Register an attachment by C<$name> through which attachable objects of the
793given CLASS can refer to this attachment. 798given CLASS can refer to this attachment.
794 799
795Some classes such as crossfire maps and objects can specify attachments 800Some classes such as deliantra maps and objects can specify attachments
796that are attached at load/instantiate time, thus the need for a name. 801that are attached at load/instantiate time, thus the need for a name.
797 802
798These calls expect any number of the following handler/hook descriptions: 803These calls expect any number of the following handler/hook descriptions:
799 804
800=over 4 805=over 4
… …
1150 $decname, length $$rdata, scalar @$objs; 1155 $decname, length $$rdata, scalar @$objs;
1151 1156
1152 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1157 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1153 aio_chmod $fh, SAVE_MODE; 1158 aio_chmod $fh, SAVE_MODE;
1154 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1159 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1155 aio_fsync $fh if $cf::USE_FSYNC; 1160 if ($cf::USE_FSYNC) {
1161 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;
1162 aio_fsync $fh;
1163 }
1156 aio_close $fh; 1164 aio_close $fh;
1157 1165
1158 if (@$objs) { 1166 if (@$objs) {
1159 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1167 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1160 aio_chmod $fh, SAVE_MODE; 1168 aio_chmod $fh, SAVE_MODE;
1161 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1169 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1162 aio_write $fh, 0, (length $data), $data, 0; 1170 aio_write $fh, 0, (length $data), $data, 0;
1163 aio_fsync $fh if $cf::USE_FSYNC; 1171 if ($cf::USE_FSYNC) {
1172 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;
1173 aio_fsync $fh;
1174 }
1164 aio_close $fh; 1175 aio_close $fh;
1165 aio_rename "$filename.pst~", "$filename.pst"; 1176 aio_rename "$filename.pst~", "$filename.pst";
1166 } 1177 }
1167 } else { 1178 } else {
1168 aio_unlink "$filename.pst"; 1179 aio_unlink "$filename.pst";
1169 } 1180 }
1170 1181
1171 aio_rename "$filename~", $filename; 1182 aio_rename "$filename~", $filename;
1183
1184 $filename =~ s%/[^/]+$%%;
1185 aio_pathsync $filename if $cf::USE_FSYNC;
1172 } else { 1186 } else {
1173 warn "FATAL: $filename~: $!\n"; 1187 warn "unable to save objects: $filename~: $!\n";
1174 } 1188 }
1175 } else { 1189 } else {
1176 aio_unlink $filename; 1190 aio_unlink $filename;
1177 aio_unlink "$filename.pst"; 1191 aio_unlink "$filename.pst";
1178 } 1192 }
… …
1269 my ($name, $cb) = @_; 1283 my ($name, $cb) = @_;
1270 1284
1271 $EXTICMD{$name} = $cb; 1285 $EXTICMD{$name} = $cb;
1272} 1286}
1273 1287
1288use File::Glob ();
1289
1274cf::player->attach ( 1290cf::player->attach (
1275 on_command => sub { 1291 on_command => sub {
1276 my ($pl, $name, $params) = @_; 1292 my ($pl, $name, $params) = @_;
1277 1293
1278 my $cb = $COMMAND{$name} 1294 my $cb = $COMMAND{$name}
… …
1309 } 1325 }
1310 1326
1311 cf::override; 1327 cf::override;
1312 }, 1328 },
1313); 1329);
1330
1331# "readahead" all extensions
1332sub cache_extensions {
1333 my $grp = IO::AIO::aio_group;
1334
1335 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1336 for (grep /\.ext$/, @{$_[0]}) {
1337 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1338 }
1339 };
1340
1341 $grp
1342}
1314 1343
1315sub load_extensions { 1344sub load_extensions {
1316 cf::sync_job { 1345 cf::sync_job {
1317 my %todo; 1346 my %todo;
1318 1347
… …
1388 1417
1389=back 1418=back
1390 1419
1391=head2 CORE EXTENSIONS 1420=head2 CORE EXTENSIONS
1392 1421
1393Functions and methods that extend core crossfire objects. 1422Functions and methods that extend core deliantra objects.
1394 1423
1395=cut 1424=cut
1396 1425
1397package cf::player; 1426package cf::player;
1398 1427
… …
1441 1470
1442sub exists($) { 1471sub exists($) {
1443 my ($login) = @_; 1472 my ($login) = @_;
1444 1473
1445 $cf::PLAYER{$login} 1474 $cf::PLAYER{$login}
1446 or cf::sync_job { !aio_stat path $login } 1475 or !aio_stat path $login
1447} 1476}
1448 1477
1449sub find($) { 1478sub find($) {
1450 return $cf::PLAYER{$_[0]} || do { 1479 return $cf::PLAYER{$_[0]} || do {
1451 my $login = $_[0]; 1480 my $login = $_[0];
… …
1622 } 1651 }
1623 1652
1624 \@paths 1653 \@paths
1625} 1654}
1626 1655
1627=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1656=item $protocol_xml = $player->expand_cfpod ($cfpod)
1628 1657
1629Expand crossfire pod fragments into protocol xml. 1658Expand deliantra pod fragments into protocol xml.
1630 1659
1631=item $player->ext_reply ($msgid, @msg) 1660=item $player->ext_reply ($msgid, @msg)
1632 1661
1633Sends an ext reply to the player. 1662Sends an ext reply to the player.
1634 1663
… …
1847 1876
1848 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1877 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1849 "$UNIQUEDIR/$path" 1878 "$UNIQUEDIR/$path"
1850} 1879}
1851 1880
1852# and all this just because we cannot iterate over
1853# all maps in C++...
1854sub change_all_map_light {
1855 my ($change) = @_;
1856
1857 $_->change_map_light ($change)
1858 for grep $_->outdoor, values %cf::MAP;
1859}
1860
1861sub decay_objects { 1881sub decay_objects {
1862 my ($self) = @_; 1882 my ($self) = @_;
1863 1883
1864 return if $self->{deny_reset}; 1884 return if $self->{deny_reset};
1865 1885
… …
1947sub find { 1967sub find {
1948 my ($path, $origin) = @_; 1968 my ($path, $origin) = @_;
1949 1969
1950 $path = normalise $path, $origin && $origin->path; 1970 $path = normalise $path, $origin && $origin->path;
1951 1971
1952 cf::lock_wait "map_data:$path";#d#remove 1972 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1953 cf::lock_wait "map_find:$path"; 1973 my $guard2 = cf::lock_acquire "map_find:$path";
1954 1974
1955 $cf::MAP{$path} || do { 1975 $cf::MAP{$path} || do {
1956 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1957 my $guard2 = cf::lock_acquire "map_find:$path";
1958
1959 my $map = new_from_path cf::map $path 1976 my $map = new_from_path cf::map $path
1960 or return; 1977 or return;
1961 1978
1962 $map->{last_save} = $cf::RUNTIME; 1979 $map->{last_save} = $cf::RUNTIME;
1963 1980
… …
2030 2047
2031 unless ($self->{deny_activate}) { 2048 unless ($self->{deny_activate}) {
2032 $self->decay_objects; 2049 $self->decay_objects;
2033 $self->fix_auto_apply; 2050 $self->fix_auto_apply;
2034 $self->update_buttons; 2051 $self->update_buttons;
2035 cf::cede_to_tick;
2036 $self->set_darkness_map;
2037 cf::cede_to_tick; 2052 cf::cede_to_tick;
2038 $self->activate; 2053 $self->activate;
2039 } 2054 }
2040 2055
2041 $self->{last_save} = $cf::RUNTIME; 2056 $self->{last_save} = $cf::RUNTIME;
… …
2383 2398
2384our $SAY_CHANNEL = { 2399our $SAY_CHANNEL = {
2385 id => "say", 2400 id => "say",
2386 title => "Map", 2401 title => "Map",
2387 reply => "say ", 2402 reply => "say ",
2388 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2403 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2389}; 2404};
2390 2405
2391our $CHAT_CHANNEL = { 2406our $CHAT_CHANNEL = {
2392 id => "chat", 2407 id => "chat",
2393 title => "Chat", 2408 title => "Chat",
… …
2519 2534
2520 $map->load; 2535 $map->load;
2521 $map->load_neighbours; 2536 $map->load_neighbours;
2522 2537
2523 return unless $self->contr->active; 2538 return unless $self->contr->active;
2524 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2525 $self->activate_recursive;
2526 2539
2527 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2540 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2528 $self->enter_map ($map, $x, $y); 2541 $self->enter_map ($map, $x, $y);
2542
2543 # only activate afterwards, to support waiting in hooks
2544 $self->activate_recursive;
2529} 2545}
2530 2546
2531=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2547=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2532 2548
2533Moves the player to the given map-path and coordinates by first freezing 2549Moves the player to the given map-path and coordinates by first freezing
… …
2692 $self->contr->savebed ($map, $x, $y) 2708 $self->contr->savebed ($map, $x, $y)
2693 if $exit->flag (cf::FLAG_DAMNED); 2709 if $exit->flag (cf::FLAG_DAMNED);
2694 2710
2695 1 2711 1
2696 }) { 2712 }) {
2697 $self->message ("Something went wrong deep within the crossfire server. " 2713 $self->message ("Something went wrong deep within the deliantra server. "
2698 . "I'll try to bring you back to the map you were before. " 2714 . "I'll try to bring you back to the map you were before. "
2699 . "Please report this to the dungeon master!", 2715 . "Please report this to the dungeon master!",
2700 cf::NDI_UNIQUE | cf::NDI_RED); 2716 cf::NDI_UNIQUE | cf::NDI_RED);
2701 2717
2702 warn "ERROR in enter_exit: $@"; 2718 warn "ERROR in enter_exit: $@";
… …
2768 id => "infobox", 2784 id => "infobox",
2769 title => "Body Parts", 2785 title => "Body Parts",
2770 reply => undef, 2786 reply => undef,
2771 tooltip => "Shows which body parts you posess and are available", 2787 tooltip => "Shows which body parts you posess and are available",
2772 }, 2788 },
2789 "c/statistics" => {
2790 id => "infobox",
2791 title => "Statistics",
2792 reply => undef,
2793 tooltip => "Shows your primary statistics",
2794 },
2795 "c/skills" => {
2796 id => "infobox",
2797 title => "Skills",
2798 reply => undef,
2799 tooltip => "Shows your experience per skill and item power",
2800 },
2801 "c/shopitems" => {
2802 id => "infobox",
2803 title => "Shop Items",
2804 reply => undef,
2805 tooltip => "Shows the items currently for sale in this shop",
2806 },
2807 "c/resistances" => {
2808 id => "infobox",
2809 title => "Resistances",
2810 reply => undef,
2811 tooltip => "Shows your resistances",
2812 },
2813 "c/pets" => {
2814 id => "infobox",
2815 title => "Pets",
2816 reply => undef,
2817 tooltip => "Shows information abotu your pets/a specific pet",
2818 },
2819 "c/perceiveself" => {
2820 id => "infobox",
2821 title => "Perceive Self",
2822 reply => undef,
2823 tooltip => "You gained detailed knowledge about yourself",
2824 },
2773 "c/uptime" => { 2825 "c/uptime" => {
2774 id => "infobox", 2826 id => "infobox",
2775 title => "Uptime", 2827 title => "Uptime",
2776 reply => undef, 2828 reply => undef,
2777 tooltip => "How long the server has been running since last restart", 2829 tooltip => "How long the server has been running since last restart",
… …
2786 id => "party", 2838 id => "party",
2787 title => "Party", 2839 title => "Party",
2788 reply => "gsay ", 2840 reply => "gsay ",
2789 tooltip => "Messages and chat related to your party", 2841 tooltip => "Messages and chat related to your party",
2790 }, 2842 },
2843 "c/death" => {
2844 id => "death",
2845 title => "Death",
2846 reply => undef,
2847 tooltip => "Reason for and more info about your most recent death",
2848 },
2849 "c/say" => $SAY_CHANNEL,
2850 "c/chat" => $CHAT_CHANNEL,
2791); 2851);
2792 2852
2793sub cf::client::send_msg { 2853sub cf::client::send_msg {
2794 my ($self, $channel, $msg, $color, @extra) = @_; 2854 my ($self, $channel, $msg, $color, @extra) = @_;
2795 2855
2796 $msg = $self->pl->expand_cfpod ($msg); 2856 $msg = $self->pl->expand_cfpod ($msg)
2857 unless $color & cf::NDI_VERBATIM;
2797 2858
2798 $color &= cf::NDI_CLIENT_MASK; # just in case... 2859 $color &= cf::NDI_CLIENT_MASK; # just in case...
2799 2860
2800 # check predefined channels, for the benefit of C 2861 # check predefined channels, for the benefit of C
2801 if ($CHANNEL{$channel}) { 2862 if ($CHANNEL{$channel}) {
2802 $channel = $CHANNEL{$channel}; 2863 $channel = $CHANNEL{$channel};
2803 2864
2804 $self->ext_msg (channel_info => $channel) 2865 $self->ext_msg (channel_info => $channel);
2805 if $self->can_msg;
2806
2807 $channel = $channel->{id}; 2866 $channel = $channel->{id};
2808 2867
2809 } elsif (ref $channel) { 2868 } elsif (ref $channel) {
2810 # send meta info to client, if not yet sent 2869 # send meta info to client, if not yet sent
2811 unless (exists $self->{channel}{$channel->{id}}) { 2870 unless (exists $self->{channel}{$channel->{id}}) {
2812 $self->{channel}{$channel->{id}} = $channel; 2871 $self->{channel}{$channel->{id}} = $channel;
2813 $self->ext_msg (channel_info => $channel) 2872 $self->ext_msg (channel_info => $channel);
2814 if $self->can_msg;
2815 } 2873 }
2816 2874
2817 $channel = $channel->{id}; 2875 $channel = $channel->{id};
2818 } 2876 }
2819 2877
2820 return unless @extra || length $msg; 2878 return unless @extra || length $msg;
2821 2879
2822 if ($self->can_msg) {
2823 # default colour, mask it out 2880 # default colour, mask it out
2824 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2881 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2825 if $color & cf::NDI_DEF; 2882 if $color & cf::NDI_DEF;
2826 2883
2827 my $pkt = "msg " 2884 my $pkt = "msg "
2828 . $self->{json_coder}->encode ( 2885 . $self->{json_coder}->encode (
2829 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2886 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2830 ); 2887 );
2831 2888
2832 # try lzf for large packets 2889 # try lzf for large packets
2833 $pkt = "lzf " . Compress::LZF::compress $pkt 2890 $pkt = "lzf " . Compress::LZF::compress $pkt
2834 if 1024 <= length $pkt and $self->{can_lzf}; 2891 if 1024 <= length $pkt and $self->{can_lzf};
2835 2892
2836 # split very large packets 2893 # split very large packets
2837 if (8192 < length $pkt and $self->{can_lzf}) { 2894 if (8192 < length $pkt and $self->{can_lzf}) {
2838 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt; 2895 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2839 $pkt = "frag"; 2896 $pkt = "frag";
2840 } 2897 }
2841 2898
2842 $self->send_packet ($pkt); 2899 $self->send_packet ($pkt);
2843 } else {
2844 if ($color >= 0) {
2845 # replace some tags by gcfclient-compatible ones
2846 for ($msg) {
2847 1 while
2848 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2849 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2850 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2851 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2852 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2853 }
2854
2855 $color &= cf::NDI_COLOR_MASK;
2856
2857 utf8::encode $msg;
2858
2859 if (0 && $msg =~ /\[/) {
2860 # COMMAND/INFO
2861 $self->send_packet ("drawextinfo $color 10 8 $msg")
2862 } else {
2863 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2864 $self->send_packet ("drawinfo $color $msg")
2865 }
2866 }
2867 }
2868} 2900}
2869 2901
2870=item $client->ext_msg ($type, @msg) 2902=item $client->ext_msg ($type, @msg)
2871 2903
2872Sends an ext event to the client. 2904Sends an ext event to the client.
… …
3047The following functions and methods are available within a safe environment: 3079The following functions and methods are available within a safe environment:
3048 3080
3049 cf::object 3081 cf::object
3050 contr pay_amount pay_player map x y force_find force_add destroy 3082 contr pay_amount pay_player map x y force_find force_add destroy
3051 insert remove name archname title slaying race decrease split 3083 insert remove name archname title slaying race decrease split
3084 value
3052 3085
3053 cf::object::player 3086 cf::object::player
3054 player 3087 player
3055 3088
3056 cf::player 3089 cf::player
… …
3062=cut 3095=cut
3063 3096
3064for ( 3097for (
3065 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3098 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3066 insert remove inv nrof name archname title slaying race 3099 insert remove inv nrof name archname title slaying race
3067 decrease split destroy change_exp)], 3100 decrease split destroy change_exp value msg lore send_msg)],
3068 ["cf::object::player" => qw(player)], 3101 ["cf::object::player" => qw(player)],
3069 ["cf::player" => qw(peaceful)], 3102 ["cf::player" => qw(peaceful send_msg)],
3070 ["cf::map" => qw(trigger)], 3103 ["cf::map" => qw(trigger)],
3071) { 3104) {
3072 no strict 'refs'; 3105 no strict 'refs';
3073 my ($pkg, @funs) = @$_; 3106 my ($pkg, @funs) = @$_;
3074 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3107 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3091 my ($code, %vars) = @_; 3124 my ($code, %vars) = @_;
3092 3125
3093 my $qcode = $code; 3126 my $qcode = $code;
3094 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3127 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3095 $qcode =~ s/\n/\\n/g; 3128 $qcode =~ s/\n/\\n/g;
3129
3130 %vars = (_dummy => 0) unless %vars;
3096 3131
3097 local $_; 3132 local $_;
3098 local @safe::cf::_safe_eval_args = values %vars; 3133 local @safe::cf::_safe_eval_args = values %vars;
3099 3134
3100 my $eval = 3135 my $eval =
… …
3330 reload_treasures; 3365 reload_treasures;
3331 3366
3332 warn "finished reloading resource files\n"; 3367 warn "finished reloading resource files\n";
3333} 3368}
3334 3369
3335sub init {
3336 my $guard = freeze_mainloop;
3337
3338 evthread_start IO::AIO::poll_fileno;
3339
3340 reload_resources;
3341}
3342
3343sub reload_config { 3370sub reload_config {
3344 open my $fh, "<:utf8", "$CONFDIR/config" 3371 open my $fh, "<:utf8", "$CONFDIR/config"
3345 or return; 3372 or return;
3346 3373
3347 local $/; 3374 local $/;
… …
3378 3405
3379 seek $fh, 0, 0; 3406 seek $fh, 0, 0;
3380 print $fh $$; 3407 print $fh $$;
3381} 3408}
3382 3409
3410sub main_loop {
3411 warn "EV::loop starting\n";
3412 if (1) {
3413 EV::loop;
3414 }
3415 warn "EV::loop returned\n";
3416 goto &main_loop unless $REALLY_UNLOOP;
3417}
3418
3383sub main { 3419sub main {
3384 atomic; 3420 cf::init_globals; # initialise logging
3421
3422 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3423 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3424 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3425 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3426
3427 cf::init_experience;
3428 cf::init_anim;
3429 cf::init_attackmess;
3430 cf::init_dynamic;
3431
3432 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3385 3433
3386 # we must not ever block the main coroutine 3434 # we must not ever block the main coroutine
3387 local $Coro::idle = sub { 3435 local $Coro::idle = sub {
3388 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3436 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3389 (async { 3437 (async {
3390 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3438 $Coro::current->{desc} = "IDLE BUG HANDLER";
3391 EV::loop EV::LOOP_ONESHOT; 3439 EV::loop EV::LOOP_ONESHOT;
3392 })->prio (Coro::PRIO_MAX); 3440 })->prio (Coro::PRIO_MAX);
3393 }; 3441 };
3394 3442
3395 { 3443 evthread_start IO::AIO::poll_fileno;
3396 my $guard = freeze_mainloop; 3444
3445 cf::sync_job {
3446 reload_resources;
3397 reload_config; 3447 reload_config;
3398 db_init; 3448 db_init;
3449
3450 cf::load_settings;
3451 cf::load_materials;
3452 cf::init_uuid;
3453 cf::init_signals;
3454 cf::init_commands;
3455 cf::init_skills;
3456
3457 cf::init_beforeplay;
3458
3459 atomic;
3460
3399 load_extensions; 3461 load_extensions;
3400 3462
3401 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3402 }
3403
3404 utime time, time, $RUNTIMEFILE; 3463 utime time, time, $RUNTIMEFILE;
3405 3464
3406 # no (long-running) fork's whatsoever before this point(!) 3465 # no (long-running) fork's whatsoever before this point(!)
3466 use POSIX ();
3407 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3467 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3408 3468
3409 EV::loop; 3469 (pop @POST_INIT)->(0) while @POST_INIT;
3470 };
3471
3472 main_loop;
3410} 3473}
3411 3474
3412############################################################################# 3475#############################################################################
3413# initialisation and cleanup 3476# initialisation and cleanup
3414 3477
… …
3470 my $uuid = "$LOCALDIR/uuid"; 3533 my $uuid = "$LOCALDIR/uuid";
3471 3534
3472 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3535 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3473 or return; 3536 or return;
3474 3537
3475 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3538 my $value = uuid_seq uuid_cur;
3539
3540 unless ($value) {
3541 warn "cowardly refusing to write zero uuid value!\n";
3542 return;
3543 }
3544
3545 my $value = uuid_str $value + $uuid_skip;
3476 $uuid_skip = 0; 3546 $uuid_skip = 0;
3477 3547
3478 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3548 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3479 and return; 3549 and return;
3480 3550
… …
3502} 3572}
3503 3573
3504sub emergency_save() { 3574sub emergency_save() {
3505 my $freeze_guard = cf::freeze_mainloop; 3575 my $freeze_guard = cf::freeze_mainloop;
3506 3576
3507 warn "enter emergency perl save\n"; 3577 warn "emergency_perl_save: enter\n";
3508 3578
3509 cf::sync_job { 3579 cf::sync_job {
3580 # this is a trade-off: we want to be very quick here, so
3581 # save all maps without fsync, and later call a global sync
3582 # (which in turn might be very very slow)
3583 local $USE_FSYNC = 0;
3584
3510 # use a peculiar iteration method to avoid tripping on perl 3585 # use a peculiar iteration method to avoid tripping on perl
3511 # refcount bugs in for. also avoids problems with players 3586 # refcount bugs in for. also avoids problems with players
3512 # and maps saved/destroyed asynchronously. 3587 # and maps saved/destroyed asynchronously.
3513 warn "begin emergency player save\n"; 3588 warn "emergency_perl_save: begin player save\n";
3514 for my $login (keys %cf::PLAYER) { 3589 for my $login (keys %cf::PLAYER) {
3515 my $pl = $cf::PLAYER{$login} or next; 3590 my $pl = $cf::PLAYER{$login} or next;
3516 $pl->valid or next; 3591 $pl->valid or next;
3517 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3592 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3518 $pl->save; 3593 $pl->save;
3519 } 3594 }
3520 warn "end emergency player save\n"; 3595 warn "emergency_perl_save: end player save\n";
3521 3596
3522 warn "begin emergency map save\n"; 3597 warn "emergency_perl_save: begin map save\n";
3523 for my $path (keys %cf::MAP) { 3598 for my $path (keys %cf::MAP) {
3524 my $map = $cf::MAP{$path} or next; 3599 my $map = $cf::MAP{$path} or next;
3525 $map->valid or next; 3600 $map->valid or next;
3526 $map->save; 3601 $map->save;
3527 } 3602 }
3528 warn "end emergency map save\n"; 3603 warn "emergency_perl_save: end map save\n";
3529 3604
3530 warn "begin emergency database checkpoint\n"; 3605 warn "emergency_perl_save: begin database checkpoint\n";
3531 BDB::db_env_txn_checkpoint $DB_ENV; 3606 BDB::db_env_txn_checkpoint $DB_ENV;
3532 warn "end emergency database checkpoint\n"; 3607 warn "emergency_perl_save: end database checkpoint\n";
3533 3608
3534 warn "begin write uuid\n"; 3609 warn "emergency_perl_save: begin write uuid\n";
3535 write_uuid_sync 1; 3610 write_uuid_sync 1;
3536 warn "end write uuid\n"; 3611 warn "emergency_perl_save: end write uuid\n";
3537 }; 3612 };
3538 3613
3614 warn "emergency_perl_save: starting sync()\n";
3615 IO::AIO::aio_sync sub {
3616 warn "emergency_perl_save: finished sync()\n";
3617 };
3618
3539 warn "leave emergency perl save\n"; 3619 warn "emergency_perl_save: leave\n";
3540} 3620}
3541 3621
3542sub post_cleanup { 3622sub post_cleanup {
3543 my ($make_core) = @_; 3623 my ($make_core) = @_;
3544 3624
… …
3570 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3650 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3571 for my $name (keys %$leaf_symtab) { 3651 for my $name (keys %$leaf_symtab) {
3572 _gv_clear *{"$pkg$name"}; 3652 _gv_clear *{"$pkg$name"};
3573# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3653# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3574 } 3654 }
3575 warn "cleared package #$pkg\n";#d# 3655 warn "cleared package $pkg\n";#d#
3576} 3656}
3577
3578our $RELOAD; # how many times to reload
3579 3657
3580sub do_reload_perl() { 3658sub do_reload_perl() {
3581 # can/must only be called in main 3659 # can/must only be called in main
3582 if ($Coro::current != $Coro::main) { 3660 if ($Coro::current != $Coro::main) {
3583 warn "can only reload from main coroutine"; 3661 warn "can only reload from main coroutine";
3584 return; 3662 return;
3585 } 3663 }
3586 3664
3587 return if $RELOAD++; 3665 return if $RELOAD++;
3666
3667 my $t1 = EV::time;
3588 3668
3589 while ($RELOAD) { 3669 while ($RELOAD) {
3590 warn "reloading..."; 3670 warn "reloading...";
3591 3671
3592 warn "entering sync_job"; 3672 warn "entering sync_job";
… …
3653 clear_package "safe::$_" 3733 clear_package "safe::$_"
3654 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3734 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3655 3735
3656 warn "unloading cf.pm \"a bit\""; 3736 warn "unloading cf.pm \"a bit\"";
3657 delete $INC{"cf.pm"}; 3737 delete $INC{"cf.pm"};
3658 delete $INC{"cf/pod.pm"}; 3738 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3659 3739
3660 # don't, removes xs symbols, too, 3740 # don't, removes xs symbols, too,
3661 # and global variables created in xs 3741 # and global variables created in xs
3662 #clear_package __PACKAGE__; 3742 #clear_package __PACKAGE__;
3663 3743
… …
3671 cf::reload_config; 3751 cf::reload_config;
3672 3752
3673 warn "loading extensions"; 3753 warn "loading extensions";
3674 cf::load_extensions; 3754 cf::load_extensions;
3675 3755
3756 if ($REATTACH_ON_RELOAD) {
3676 warn "reattaching attachments to objects/players"; 3757 warn "reattaching attachments to objects/players";
3677 _global_reattach; # objects, sockets 3758 _global_reattach; # objects, sockets
3678 warn "reattaching attachments to maps"; 3759 warn "reattaching attachments to maps";
3679 reattach $_ for values %MAP; 3760 reattach $_ for values %MAP;
3680 warn "reattaching attachments to players"; 3761 warn "reattaching attachments to players";
3681 reattach $_ for values %PLAYER; 3762 reattach $_ for values %PLAYER;
3763 }
3764
3765 warn "running post_init jobs";
3766 (pop @POST_INIT)->(1) while @POST_INIT;
3682 3767
3683 warn "leaving sync_job"; 3768 warn "leaving sync_job";
3684 3769
3685 1 3770 1
3686 } or do { 3771 } or do {
… …
3689 }; 3774 };
3690 3775
3691 warn "reloaded"; 3776 warn "reloaded";
3692 --$RELOAD; 3777 --$RELOAD;
3693 } 3778 }
3779
3780 $t1 = EV::time - $t1;
3781 warn "reload completed in ${t1}s\n";
3694}; 3782};
3695 3783
3696our $RELOAD_WATCHER; # used only during reload 3784our $RELOAD_WATCHER; # used only during reload
3697 3785
3698sub reload_perl() { 3786sub reload_perl() {
3699 # doing reload synchronously and two reloads happen back-to-back, 3787 # doing reload synchronously and two reloads happen back-to-back,
3700 # coro crashes during coro_state_free->destroy here. 3788 # coro crashes during coro_state_free->destroy here.
3701 3789
3790 $RELOAD_WATCHER ||= cf::async {
3791 Coro::AIO::aio_wait cache_extensions;
3792
3702 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3793 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3703 do_reload_perl; 3794 do_reload_perl;
3704 undef $RELOAD_WATCHER; 3795 undef $RELOAD_WATCHER;
3796 };
3705 }; 3797 };
3706} 3798}
3707 3799
3708register_command "reload" => sub { 3800register_command "reload" => sub {
3709 my ($who, $arg) = @_; 3801 my ($who, $arg) = @_;
… …
3868 LOG llevInfo, "[ABT] [suppressed]\n"; 3960 LOG llevInfo, "[ABT] [suppressed]\n";
3869 } 3961 }
3870} 3962}
3871 3963
3872# load additional modules 3964# load additional modules
3873use cf::pod; 3965require "cf/$_.pm" for @EXTRA_MODULES;
3874 3966
3875END { cf::emergency_save } 3967END { cf::emergency_save }
3876 3968
38771 39691
3878 3970

Diff Legend

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