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.314 by root, Mon Jul 23 16:53:15 2007 UTC vs.
Revision 1.346 by root, Tue Aug 28 19:38:40 2007 UTC

… …
10use Event; 10use Event;
11use Opcode; 11use Opcode;
12use Safe; 12use Safe;
13use Safe::Hole; 13use Safe::Hole;
14 14
15use Coro 3.61 (); 15use Coro 3.64 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
24 25
25use JSON::XS 1.4 (); 26use JSON::XS ();
26use BDB (); 27use BDB ();
27use Data::Dumper; 28use Data::Dumper;
28use Digest::MD5; 29use Digest::MD5;
29use Fcntl; 30use Fcntl;
30use YAML::Syck (); 31use YAML::Syck ();
… …
322 }; 323 };
323 $TICK_WATCHER->stop; 324 $TICK_WATCHER->stop;
324 $guard 325 $guard
325} 326}
326 327
327=item cf::get_slot $time[, $priority] 328=item cf::get_slot $time[, $priority[, $name]]
328 329
329Allocate $time seconds of blocking CPU time at priority C<$priority>: 330Allocate $time seconds of blocking CPU time at priority C<$priority>:
330This call blocks and returns only when you have at least C<$time> seconds 331This call blocks and returns only when you have at least C<$time> seconds
331of cpu time till the next tick. The slot is only valid till the next cede. 332of cpu time till the next tick. The slot is only valid till the next cede.
333
334The optional C<$name> can be used to identify the job to run. It might be
335used for statistical purposes and should identify the same time-class.
332 336
333Useful for short background jobs. 337Useful for short background jobs.
334 338
335=cut 339=cut
336 340
… …
363 Coro::schedule; 367 Coro::schedule;
364 } 368 }
365 } 369 }
366}; 370};
367 371
368sub get_slot($;$) { 372sub get_slot($;$$) {
369 my ($time, $pri) = @_; 373 my ($time, $pri, $name) = @_;
370 374
375 $time = $TICK * .6 if $time > $TICK * .6;
376 my $sig = new Coro::Signal;
377
371 push @SLOT_QUEUE, [$time, $pri, my $sig = new Coro::Signal]; 378 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
372 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 379 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
373 $SLOT_QUEUE->ready; 380 $SLOT_QUEUE->ready;
374 $sig->wait; 381 $sig->wait;
375} 382}
376 383
… …
466Coro::Storable. May, of course, block. Note that the executed sub may 473Coro::Storable. May, of course, block. Note that the executed sub may
467never block itself or use any form of Event handling. 474never block itself or use any form of Event handling.
468 475
469=cut 476=cut
470 477
471sub _store_scalar {
472 open my $fh, ">", \my $buf
473 or die "fork_call: cannot open fh-to-buf in child : $!";
474 Storable::store_fd $_[0], $fh;
475 close $fh;
476
477 $buf
478}
479
480sub fork_call(&@) { 478sub fork_call(&@) {
481 my ($cb, @args) = @_; 479 my ($cb, @args) = @_;
482 480
483# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 481 # we seemingly have to make a local copy of the whole thing,
484# or die "socketpair: $!"; 482 # otherwise perl prematurely frees the stuff :/
485 pipe my $fh1, my $fh2 483 # TODO: investigate and fix (liekly this will be rather laborious)
486 or die "pipe: $!";
487 484
488 if (my $pid = fork) { 485 my @res = Coro::Util::fork_eval {
489 close $fh2;
490
491 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
492 warn "pst<$res>" unless $res =~ /^pst/;
493 $res = Coro::Storable::thaw $res;
494
495 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
496
497 Carp::confess $$res unless "ARRAY" eq ref $res;
498
499 return wantarray ? @$res : $res->[-1];
500 } else {
501 reset_signals; 486 reset_signals;
502 local $SIG{__WARN__}; 487 &$cb
503 local $SIG{__DIE__}; 488 }, @args;
504 # just in case, this hack effectively disables event
505 # in the child. cleaner and slower would be canceling all watchers,
506 # but this works for the time being.
507 local $Coro::idle;
508 $Coro::current->prio (Coro::PRIO_MAX);
509 489
510 eval { 490 wantarray ? @res : $res[-1]
511 close $fh1;
512
513 my @res = eval { $cb->(@args) };
514
515 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
516 close $fh2;
517 };
518
519 warn $@ if $@;
520 _exit 0;
521 }
522} 491}
523 492
524=item $value = cf::db_get $family => $key 493=item $value = cf::db_get $family => $key
525 494
526Returns a single value from the environment database. 495Returns a single value from the environment database.
… …
606 if (1) { 575 if (1) {
607 $md5 = 576 $md5 =
608 join "\x00", 577 join "\x00",
609 $processversion, 578 $processversion,
610 map { 579 map {
611 Coro::cede; 580 cf::cede_to_tick;
612 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 581 ($src->[$_], Digest::MD5::md5_hex $data[$_])
613 } 0.. $#$src; 582 } 0.. $#$src;
614 583
615 584
616 my $dbmd5 = db_get cache => "$id/md5"; 585 my $dbmd5 = db_get cache => "$id/md5";
… …
1175 my ($pl, $buf) = @_; 1144 my ($pl, $buf) = @_;
1176 1145
1177 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1146 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1178 1147
1179 if (ref $msg) { 1148 if (ref $msg) {
1149 my ($type, $reply, @payload) =
1150 "ARRAY" eq ref $msg
1151 ? @$msg
1152 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1153
1154 my @reply;
1155
1180 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1156 if (my $cb = $EXTCMD{$type}) {
1181 if (my %reply = $cb->($pl, $msg)) { 1157 @reply = $cb->($pl, @payload);
1182 $pl->ext_reply ($msg->{msgid}, %reply);
1183 }
1184 } 1158 }
1159
1160 $pl->ext_reply ($reply, @reply)
1161 if $reply;
1162
1185 } else { 1163 } else {
1186 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1164 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1187 } 1165 }
1188 1166
1189 cf::override; 1167 cf::override;
… …
1344 1322
1345 aio_mkdir playerdir $pl, 0770; 1323 aio_mkdir playerdir $pl, 0770;
1346 $pl->{last_save} = $cf::RUNTIME; 1324 $pl->{last_save} = $cf::RUNTIME;
1347 1325
1348 $pl->save_pl ($path); 1326 $pl->save_pl ($path);
1349 Coro::cede; 1327 cf::cede_to_tick;
1350} 1328}
1351 1329
1352sub new($) { 1330sub new($) {
1353 my ($login) = @_; 1331 my ($login) = @_;
1354 1332
… …
1358 $self->{deny_save} = 1; 1336 $self->{deny_save} = 1;
1359 1337
1360 $cf::PLAYER{$login} = $self; 1338 $cf::PLAYER{$login} = $self;
1361 1339
1362 $self 1340 $self
1341}
1342
1343=item $player->send_msg ($channel, $msg, $color, [extra...])
1344
1345=cut
1346
1347sub send_msg {
1348 my $ns = shift->ns
1349 or return;
1350 $ns->send_msg (@_);
1363} 1351}
1364 1352
1365=item $pl->quit_character 1353=item $pl->quit_character
1366 1354
1367Nukes the player without looking back. If logged in, the connection will 1355Nukes the player without looking back. If logged in, the connection will
… …
1511sub hintmode { 1499sub hintmode {
1512 $_[0]{hintmode} = $_[1] if @_ > 1; 1500 $_[0]{hintmode} = $_[1] if @_ > 1;
1513 $_[0]{hintmode} 1501 $_[0]{hintmode}
1514} 1502}
1515 1503
1516=item $player->ext_reply ($msgid, %msg) 1504=item $player->ext_reply ($msgid, @msg)
1517 1505
1518Sends an ext reply to the player. 1506Sends an ext reply to the player.
1519 1507
1520=cut 1508=cut
1521 1509
1522sub ext_reply($$%) { 1510sub ext_reply($$@) {
1523 my ($self, $id, %msg) = @_; 1511 my ($self, $id, @msg) = @_;
1524 1512
1525 $msg{msgid} = $id; 1513 $self->ns->ext_reply ($id, @msg)
1526 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1527} 1514}
1528 1515
1529=item $player->ext_event ($type, %msg) 1516=item $player->ext_msg ($type, @msg)
1530 1517
1531Sends an ext event to the client. 1518Sends an ext event to the client.
1532 1519
1533=cut 1520=cut
1534 1521
1535sub ext_event($$%) { 1522sub ext_msg($$@) {
1536 my ($self, $type, %msg) = @_; 1523 my ($self, $type, @msg) = @_;
1537 1524
1538 $self->ns->ext_event ($type, %msg); 1525 $self->ns->ext_msg ($type, @msg);
1539} 1526}
1540 1527
1541=head3 cf::region 1528=head3 cf::region
1542 1529
1543=over 4 1530=over 4
… …
1862 local $self->{deny_reset} = 1; # loading can take a long time 1849 local $self->{deny_reset} = 1; # loading can take a long time
1863 1850
1864 my $path = $self->{path}; 1851 my $path = $self->{path};
1865 1852
1866 { 1853 {
1854 my $guard1 = cf::lock_acquire "map_data:$path";
1867 my $guard = cf::lock_acquire "map_load:$path"; 1855 my $guard2 = cf::lock_acquire "map_load:$path";
1868 1856
1869 return if $self->in_memory != cf::MAP_SWAPPED; 1857 return if $self->in_memory != cf::MAP_SWAPPED;
1870 1858
1871 $self->in_memory (cf::MAP_LOADING); 1859 $self->in_memory (cf::MAP_LOADING);
1872 1860
1873 $self->alloc; 1861 $self->alloc;
1874 1862
1875 $self->pre_load; 1863 $self->pre_load;
1876 Coro::cede; 1864 cf::cede_to_tick;
1877 1865
1878 $self->_load_objects ($self->{load_path}, 1) 1866 $self->_load_objects ($self->{load_path}, 1)
1879 or return; 1867 or return;
1880 1868
1881 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1869 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
… …
1887 $self->clear_unique_items; 1875 $self->clear_unique_items;
1888 $self->_load_objects ($uniq, 0); 1876 $self->_load_objects ($uniq, 0);
1889 } 1877 }
1890 } 1878 }
1891 1879
1892 Coro::cede; 1880 cf::cede_to_tick;
1893 # now do the right thing for maps 1881 # now do the right thing for maps
1894 $self->link_multipart_objects; 1882 $self->link_multipart_objects;
1895 $self->difficulty ($self->estimate_difficulty) 1883 $self->difficulty ($self->estimate_difficulty)
1896 unless $self->difficulty; 1884 unless $self->difficulty;
1897 Coro::cede; 1885 cf::cede_to_tick;
1898 1886
1899 unless ($self->{deny_activate}) { 1887 unless ($self->{deny_activate}) {
1900 $self->decay_objects; 1888 $self->decay_objects;
1901 $self->fix_auto_apply; 1889 $self->fix_auto_apply;
1902 $self->update_buttons; 1890 $self->update_buttons;
1903 Coro::cede; 1891 cf::cede_to_tick;
1904 $self->set_darkness_map; 1892 $self->set_darkness_map;
1905 Coro::cede; 1893 cf::cede_to_tick;
1906 $self->activate; 1894 $self->activate;
1907 } 1895 }
1896
1897 $self->{last_save} = $cf::RUNTIME;
1898 $self->last_access ($cf::RUNTIME);
1908 1899
1909 $self->in_memory (cf::MAP_IN_MEMORY); 1900 $self->in_memory (cf::MAP_IN_MEMORY);
1910 } 1901 }
1911 1902
1912 $self->post_load; 1903 $self->post_load;
… …
1923 1914
1924 $self 1915 $self
1925} 1916}
1926 1917
1927# find and load all maps in the 3x3 area around a map 1918# find and load all maps in the 3x3 area around a map
1928sub load_diag { 1919sub load_neighbours {
1929 my ($map) = @_; 1920 my ($map) = @_;
1930 1921
1931 my @diag; # diagonal neighbours 1922 my @neigh; # diagonal neighbours
1932 1923
1933 for (0 .. 3) { 1924 for (0 .. 3) {
1934 my $neigh = $map->tile_path ($_) 1925 my $neigh = $map->tile_path ($_)
1935 or next; 1926 or next;
1936 $neigh = find $neigh, $map 1927 $neigh = find $neigh, $map
1937 or next; 1928 or next;
1938 $neigh->load; 1929 $neigh->load;
1939 1930
1931 push @neigh,
1940 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1932 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1941 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1933 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1942 } 1934 }
1943 1935
1944 for (@diag) { 1936 for (grep defined $_->[0], @neigh) {
1937 my ($path, $origin) = @$_;
1945 my $neigh = find @$_ 1938 my $neigh = find $path, $origin
1946 or next; 1939 or next;
1947 $neigh->load; 1940 $neigh->load;
1948 } 1941 }
1949} 1942}
1950 1943
… …
1955} 1948}
1956 1949
1957sub do_load_sync { 1950sub do_load_sync {
1958 my ($map) = @_; 1951 my ($map) = @_;
1959 1952
1953 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
1954 if $Coro::current == $Coro::main;
1955
1960 cf::sync_job { $map->load }; 1956 cf::sync_job { $map->load };
1961} 1957}
1962 1958
1963our %MAP_PREFETCH; 1959our %MAP_PREFETCH;
1964our $MAP_PREFETCHER = undef; 1960our $MAP_PREFETCHER = undef;
1965 1961
1966sub find_async { 1962sub find_async {
1967 my ($path, $origin) = @_; 1963 my ($path, $origin, $load) = @_;
1968 1964
1969 $path = normalise $path, $origin && $origin->{path}; 1965 $path = normalise $path, $origin && $origin->{path};
1970 1966
1971 if (my $map = $cf::MAP{$path}) { 1967 if (my $map = $cf::MAP{$path}) {
1972 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1968 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1973 } 1969 }
1974 1970
1975 undef $MAP_PREFETCH{$path}; 1971 $MAP_PREFETCH{$path} |= $load;
1972
1976 $MAP_PREFETCHER ||= cf::async { 1973 $MAP_PREFETCHER ||= cf::async {
1977 while (%MAP_PREFETCH) { 1974 while (%MAP_PREFETCH) {
1978 for my $path (keys %MAP_PREFETCH) { 1975 while (my ($k, $v) = each %MAP_PREFETCH) {
1979 if (my $map = find $path) { 1976 if (my $map = find $k) {
1980 $map->load; 1977 $map->load if $v;
1981 } 1978 }
1982 1979
1983 delete $MAP_PREFETCH{$path}; 1980 delete $MAP_PREFETCH{$k};
1984 } 1981 }
1985 } 1982 }
1986 undef $MAP_PREFETCHER; 1983 undef $MAP_PREFETCHER;
1987 }; 1984 };
1988 $MAP_PREFETCHER->prio (6); 1985 $MAP_PREFETCHER->prio (6);
… …
1991} 1988}
1992 1989
1993sub save { 1990sub save {
1994 my ($self) = @_; 1991 my ($self) = @_;
1995 1992
1996 my $lock = cf::lock_acquire "map_data:" . $self->path; 1993 my $lock = cf::lock_acquire "map_data:$self->{path}";
1997 1994
1998 $self->{last_save} = $cf::RUNTIME; 1995 $self->{last_save} = $cf::RUNTIME;
1999 1996
2000 return unless $self->dirty; 1997 return unless $self->dirty;
2001 1998
… …
2024 my ($self) = @_; 2021 my ($self) = @_;
2025 2022
2026 # save first because save cedes 2023 # save first because save cedes
2027 $self->save; 2024 $self->save;
2028 2025
2029 my $lock = cf::lock_acquire "map_data:" . $self->path; 2026 my $lock = cf::lock_acquire "map_data:$self->{path}";
2030 2027
2031 return if $self->players; 2028 return if $self->players;
2032 return if $self->in_memory != cf::MAP_IN_MEMORY; 2029 return if $self->in_memory != cf::MAP_IN_MEMORY;
2033 return if $self->{deny_save}; 2030 return if $self->{deny_save};
2034 2031
… …
2213 2210
2214 } else { 2211 } else {
2215 my $pl = $self->contr; 2212 my $pl = $self->contr;
2216 2213
2217 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2214 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2218 my $diag = $pl->{npc_dialog}; 2215 my $dialog = $pl->{npc_dialog};
2219 $diag->{pl}->ext_reply ( 2216 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2220 $diag->{id},
2221 msgtype => "reply",
2222 msg => $diag->{pl}->expand_cfpod ($msg),
2223 add_topics => []
2224 );
2225 2217
2226 } else { 2218 } else {
2227 $msg = $npc->name . " says: $msg" if $npc; 2219 $msg = $npc->name . " says: $msg" if $npc;
2228 $self->message ($msg, $flags); 2220 $self->message ($msg, $flags);
2229 } 2221 }
2230 } 2222 }
2223}
2224
2225=item $object->send_msg ($channel, $msg, $color, [extra...])
2226
2227=cut
2228
2229sub cf::object::send_msg {
2230 my $pl = shift->contr
2231 or return;
2232 $pl->send_msg (@_);
2231} 2233}
2232 2234
2233=item $player_object->may ("access") 2235=item $player_object->may ("access")
2234 2236
2235Returns wether the given player is authorized to access resource "access" 2237Returns wether the given player is authorized to access resource "access"
… …
2314 # use -1 or undef as default coordinates, not 0, 0 2316 # use -1 or undef as default coordinates, not 0, 0
2315 ($x, $y) = ($map->enter_x, $map->enter_y) 2317 ($x, $y) = ($map->enter_x, $map->enter_y)
2316 if $x <=0 && $y <= 0; 2318 if $x <=0 && $y <= 0;
2317 2319
2318 $map->load; 2320 $map->load;
2319 $map->load_diag; 2321 $map->load_neighbours;
2320 2322
2321 return unless $self->contr->active; 2323 return unless $self->contr->active;
2322 $self->activate_recursive; 2324 $self->activate_recursive;
2323 2325
2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2326 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
… …
2500sub cf::client::send_msg { 2502sub cf::client::send_msg {
2501 my ($self, $channel, $msg, $color, @extra) = @_; 2503 my ($self, $channel, $msg, $color, @extra) = @_;
2502 2504
2503 $msg = $self->pl->expand_cfpod ($msg); 2505 $msg = $self->pl->expand_cfpod ($msg);
2504 2506
2505 $color &= ~cf::NDI_UNIQUE; # just in case... 2507 $color &= cf::NDI_CLIENT_MASK; # just in case...
2506 2508
2507 if (ref $channel) { 2509 if (ref $channel) {
2508 # send meta info to client, if not yet sent 2510 # send meta info to client, if not yet sent
2509 unless (exists $self->{channel}{$channel->{id}}) { 2511 unless (exists $self->{channel}{$channel->{id}}) {
2510 $self->{channel}{$channel->{id}} = $channel; 2512 $self->{channel}{$channel->{id}} = $channel;
2511 $self->ext_event (channel_info => %$channel); 2513 $self->ext_msg (channel_info => $channel);
2512 } 2514 }
2513 2515
2514 $channel = $channel->{id}; 2516 $channel = $channel->{id};
2515 } 2517 }
2516 2518
2517 return unless @extra || length $msg; 2519 return unless @extra || length $msg;
2518 2520
2519 if ($self->can_msg) { 2521 if ($self->can_msg) {
2522 # default colour, mask it out
2523 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2524 if $color & cf::NDI_DEF;
2525
2520 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra])); 2526 $self->send_packet ("msg " . $self->{json_coder}->encode (
2527 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2521 } else { 2528 } else {
2522 # replace some tags by gcfclient-compatible ones
2523 for ($msg) {
2524 1 while
2525 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2526 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2527 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2528 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2529 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2530 }
2531
2532 if ($color >= 0) { 2529 if ($color >= 0) {
2530 # replace some tags by gcfclient-compatible ones
2531 for ($msg) {
2532 1 while
2533 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2534 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2535 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2536 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2537 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2538 }
2539
2540 $color &= cf::NDI_COLOR_MASK;
2541
2542 utf8::encode $msg;
2543
2533 if (0 && $msg =~ /\[/) { 2544 if (0 && $msg =~ /\[/) {
2545 # COMMAND/INFO
2534 $self->send_packet ("drawextinfo $color 4 0 $msg") 2546 $self->send_packet ("drawextinfo $color 10 8 $msg")
2535 } else { 2547 } else {
2536 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2548 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2537 $self->send_packet ("drawinfo $color $msg") 2549 $self->send_packet ("drawinfo $color $msg")
2538 } 2550 }
2539 } 2551 }
2540 } 2552 }
2541} 2553}
2542 2554
2543=item $client->ext_event ($type, %msg) 2555=item $client->ext_msg ($type, @msg)
2544 2556
2545Sends an ext event to the client. 2557Sends an ext event to the client.
2546 2558
2547=cut 2559=cut
2548 2560
2549sub cf::client::ext_event($$%) { 2561sub cf::client::ext_msg($$@) {
2550 my ($self, $type, %msg) = @_; 2562 my ($self, $type, @msg) = @_;
2551 2563
2552 return unless $self->extcmd; 2564 if ($self->extcmd == 2) {
2553 2565 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2566 } elsif ($self->extcmd == 1) { # TODO: remove
2554 $msg{msgtype} = "event_$type"; 2567 push @msg, msgtype => "event_$type";
2555 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2568 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2569 }
2570}
2571
2572=item $client->ext_reply ($msgid, @msg)
2573
2574Sends an ext reply to the client.
2575
2576=cut
2577
2578sub cf::client::ext_reply($$@) {
2579 my ($self, $id, @msg) = @_;
2580
2581 if ($self->extcmd == 2) {
2582 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2583 } elsif ($self->extcmd == 1) {
2584 #TODO: version 1, remove
2585 unshift @msg, msgtype => "reply", msgid => $id;
2586 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2587 }
2556} 2588}
2557 2589
2558=item $success = $client->query ($flags, "text", \&cb) 2590=item $success = $client->query ($flags, "text", \&cb)
2559 2591
2560Queues a query to the client, calling the given callback with 2592Queues a query to the client, calling the given callback with
… …
2615 my ($ns, $buf) = @_; 2647 my ($ns, $buf) = @_;
2616 2648
2617 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 2649 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618 2650
2619 if (ref $msg) { 2651 if (ref $msg) {
2652 my ($type, $reply, @payload) =
2653 "ARRAY" eq ref $msg
2654 ? @$msg
2655 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2656
2657 my @reply;
2658
2620 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 2659 if (my $cb = $EXTICMD{$type}) {
2621 if (my %reply = $cb->($ns, $msg)) { 2660 @reply = $cb->($ns, @payload);
2622 $reply{msgid} = $msg->{msgid};
2623 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2624 }
2625 } 2661 }
2662
2663 $ns->ext_reply ($reply, @reply)
2664 if $reply;
2665
2626 } else { 2666 } else {
2627 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 2667 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2628 } 2668 }
2629 2669
2630 cf::override; 2670 cf::override;
… …
2677our $safe = new Safe "safe"; 2717our $safe = new Safe "safe";
2678our $safe_hole = new Safe::Hole; 2718our $safe_hole = new Safe::Hole;
2679 2719
2680$SIG{FPE} = 'IGNORE'; 2720$SIG{FPE} = 'IGNORE';
2681 2721
2682$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2722$safe->permit_only (Opcode::opset qw(
2723 :base_core :base_mem :base_orig :base_math
2724 grepstart grepwhile mapstart mapwhile
2725 sort time
2726));
2683 2727
2684# here we export the classes and methods available to script code 2728# here we export the classes and methods available to script code
2685 2729
2686=pod 2730=pod
2687 2731
2688The following functions and methods are available within a safe environment: 2732The following functions and methods are available within a safe environment:
2689 2733
2690 cf::object 2734 cf::object
2691 contr pay_amount pay_player map x y force_find force_add 2735 contr pay_amount pay_player map x y force_find force_add
2692 insert remove 2736 insert remove name archname title slaying race decrease_ob_nr
2693 2737
2694 cf::object::player 2738 cf::object::player
2695 player 2739 player
2696 2740
2697 cf::player 2741 cf::player
… …
2702 2746
2703=cut 2747=cut
2704 2748
2705for ( 2749for (
2706 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 2750 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2751 insert remove inv name archname title slaying race
2707 insert remove)], 2752 decrease_ob_nr)],
2708 ["cf::object::player" => qw(player)], 2753 ["cf::object::player" => qw(player)],
2709 ["cf::player" => qw(peaceful)], 2754 ["cf::player" => qw(peaceful)],
2710 ["cf::map" => qw(trigger)], 2755 ["cf::map" => qw(trigger)],
2711) { 2756) {
2712 no strict 'refs'; 2757 no strict 'refs';
… …
2788# the server's init and main functions 2833# the server's init and main functions
2789 2834
2790sub load_facedata($) { 2835sub load_facedata($) {
2791 my ($path) = @_; 2836 my ($path) = @_;
2792 2837
2838 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2839
2793 warn "loading facedata from $path\n"; 2840 warn "loading facedata from $path\n";
2794 2841
2795 my $facedata; 2842 my $facedata;
2796 0 < aio_load $path, $facedata 2843 0 < aio_load $path, $facedata
2797 or die "$path: $!"; 2844 or die "$path: $!";
2798 2845
2799 $facedata = Coro::Storable::thaw $facedata; 2846 $facedata = Coro::Storable::thaw $facedata;
2800 2847
2801 $facedata->{version} == 2 2848 $facedata->{version} == 2
2802 or cf::cleanup "$path: version mismatch, cannot proceed."; 2849 or cf::cleanup "$path: version mismatch, cannot proceed.";
2850
2851 # patch in the exptable
2852 $facedata->{resource}{"res/exp_table"} = {
2853 type => FT_RSRC,
2854 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2855 };
2856 cf::cede_to_tick;
2803 2857
2804 { 2858 {
2805 my $faces = $facedata->{faceinfo}; 2859 my $faces = $facedata->{faceinfo};
2806 2860
2807 while (my ($face, $info) = each %$faces) { 2861 while (my ($face, $info) = each %$faces) {
2808 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2862 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2809 cf::face::set_visibility $idx, $info->{visibility}; 2863 cf::face::set_visibility $idx, $info->{visibility};
2810 cf::face::set_magicmap $idx, $info->{magicmap}; 2864 cf::face::set_magicmap $idx, $info->{magicmap};
2811 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2865 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2812 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2866 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2813 2867
2814 cf::cede_to_tick; 2868 cf::cede_to_tick;
2815 } 2869 }
2816 2870
2817 while (my ($face, $info) = each %$faces) { 2871 while (my ($face, $info) = each %$faces) {
… …
2842 2896
2843 { 2897 {
2844 # TODO: for gcfclient pleasure, we should give resources 2898 # TODO: for gcfclient pleasure, we should give resources
2845 # that gcfclient doesn't grok a >10000 face index. 2899 # that gcfclient doesn't grok a >10000 face index.
2846 my $res = $facedata->{resource}; 2900 my $res = $facedata->{resource};
2847 my $enc = JSON::XS->new->utf8->canonical; 2901
2902 my $soundconf = delete $res->{"res/sound.conf"};
2848 2903
2849 while (my ($name, $info) = each %$res) { 2904 while (my ($name, $info) = each %$res) {
2850 my $meta = $enc->encode ({
2851 name => $name,
2852 type => $info->{type},
2853 copyright => $info->{copyright}, #TODO#
2854 });
2855
2856 my $idx = (cf::face::find $name) || cf::face::alloc $name; 2905 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2906 my $data;
2857 2907
2858 if ($name =~ /\.jpg$/) { 2908 if ($info->{type} & 1) {
2859 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack 2909 # prepend meta info
2860 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack 2910
2911 my $meta = $enc->encode ({
2912 name => $name,
2913 %{ $info->{meta} || {} },
2914 });
2915
2916 $data = pack "(w/a*)*", $meta, $info->{data};
2861 } else { 2917 } else {
2862 my $data = pack "(w/a*)*", $meta, $info->{data}; 2918 $data = $info->{data};
2863 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864
2865 cf::face::set_type $idx, 1;
2866 cf::face::set_data $idx, 0, $data, $chk;
2867 } 2919 }
2868 2920
2921 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2922 cf::face::set_type $idx, $info->{type};
2923
2869 cf::cede_to_tick; 2924 cf::cede_to_tick;
2870 } 2925 }
2926
2927 if ($soundconf) {
2928 $soundconf = $enc->decode (delete $soundconf->{data});
2929
2930 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2931 my $sound = $soundconf->{compat}[$_]
2932 or next;
2933
2934 my $face = cf::face::find "sound/$sound->[1]";
2935 cf::sound::set $sound->[0] => $face;
2936 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2937 }
2938
2939 while (my ($k, $v) = each %{$soundconf->{event}}) {
2940 my $face = cf::face::find "sound/$v";
2941 cf::sound::set $k => $face;
2942 }
2943 }
2871 } 2944 }
2872 2945
2873 1 2946 1
2874} 2947}
2948
2949register_exticmd fx_want => sub {
2950 my ($ns, $want) = @_;
2951
2952 while (my ($k, $v) = each %$want) {
2953 $ns->fx_want ($k, $v);
2954 }
2955};
2875 2956
2876sub reload_regions { 2957sub reload_regions {
2877 load_resource_file "$MAPDIR/regions" 2958 load_resource_file "$MAPDIR/regions"
2878 or die "unable to load regions file\n"; 2959 or die "unable to load regions file\n";
2879 2960
… …
2917 2998
2918sub init { 2999sub init {
2919 reload_resources; 3000 reload_resources;
2920} 3001}
2921 3002
2922sub cfg_load { 3003sub reload_config {
2923 open my $fh, "<:utf8", "$CONFDIR/config" 3004 open my $fh, "<:utf8", "$CONFDIR/config"
2924 or return; 3005 or return;
2925 3006
2926 local $/; 3007 local $/;
2927 *CFG = YAML::Syck::Load <$fh>; 3008 *CFG = YAML::Syck::Load <$fh>;
… …
2947 (async { 3028 (async {
2948 Event::one_event; 3029 Event::one_event;
2949 })->prio (Coro::PRIO_MAX); 3030 })->prio (Coro::PRIO_MAX);
2950 }; 3031 };
2951 3032
2952 cfg_load; 3033 reload_config;
2953 db_init; 3034 db_init;
2954 load_extensions; 3035 load_extensions;
2955 3036
2956 $TICK_WATCHER->start; 3037 $TICK_WATCHER->start;
2957 Event::loop; 3038 Event::loop;
… …
3150 warn "reloading cf.pm"; 3231 warn "reloading cf.pm";
3151 require cf; 3232 require cf;
3152 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3233 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3153 3234
3154 warn "loading config and database again"; 3235 warn "loading config and database again";
3155 cf::cfg_load; 3236 cf::reload_config;
3156 3237
3157 warn "loading extensions"; 3238 warn "loading extensions";
3158 cf::load_extensions; 3239 cf::load_extensions;
3159 3240
3160 warn "reattaching attachments to objects/players"; 3241 warn "reattaching attachments to objects/players";

Diff Legend

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