ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.97 by root, Fri Dec 22 06:03:20 2006 UTC vs.
Revision 1.110 by root, Mon Jan 1 11:21:55 2007 UTC

8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro; 13use Coro 3.3;
14use Coro::Event; 14use Coro::Event;
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18
19use IO::AIO; 18use Coro::AIO;
19
20use Digest::MD5;
21use Fcntl;
22use IO::AIO 2.31 ();
20use YAML::Syck (); 23use YAML::Syck ();
21use Time::HiRes; 24use Time::HiRes;
22 25
23use Event; $Event::Eval = 1; # no idea why this is required, but it is 26use Event; $Event::Eval = 1; # no idea why this is required, but it is
24 27
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1; 29$YAML::Syck::ImplicitUnicode = 1;
27 30
28$Coro::main->prio (Coro::PRIO_MIN); 31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
29 32
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 34
32our %COMMAND = (); 35our %COMMAND = ();
33our %COMMAND_TIME = (); 36our %COMMAND_TIME = ();
34our %EXTCMD = (); 37our %EXTCMD = ();
35 38
36_init_vars;
37
38our @EVENT; 39our @EVENT;
39our $LIBDIR = datadir . "/ext"; 40our $LIBDIR = datadir . "/ext";
40 41
41our $TICK = MAX_TIME * 1e-6; 42our $TICK = MAX_TIME * 1e-6;
42our $TICK_WATCHER; 43our $TICK_WATCHER;
43our $NEXT_TICK; 44our $NEXT_TICK;
45our $NOW;
44 46
45our %CFG; 47our %CFG;
46 48
47our $UPTIME; $UPTIME ||= time; 49our $UPTIME; $UPTIME ||= time;
50our $RUNTIME;
51
52our %MAP; # all maps
53our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO;
57
58binmode STDOUT;
59binmode STDERR;
60
61# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime"
64 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.;
66}
67
68mkdir cf::localdir;
69mkdir cf::localdir . "/" . cf::playerdir;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73
74# a special map that is always available
75our $LINK_MAP;
76
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
48 78
49############################################################################# 79#############################################################################
50 80
51=head2 GLOBAL VARIABLES 81=head2 GLOBAL VARIABLES
52 82
53=over 4 83=over 4
54 84
55=item $cf::UPTIME 85=item $cf::UPTIME
56 86
57The timestamp of the server start (so not actually an uptime). 87The timestamp of the server start (so not actually an uptime).
88
89=item $cf::RUNTIME
90
91The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick.
58 93
59=item $cf::LIBDIR 94=item $cf::LIBDIR
60 95
61The perl library directory, where extensions and cf-specific modules can 96The perl library directory, where extensions and cf-specific modules can
62be found. It will be added to C<@INC> automatically. 97be found. It will be added to C<@INC> automatically.
98
99=item $cf::NOW
100
101The time of the last (current) server tick.
63 102
64=item $cf::TICK 103=item $cf::TICK
65 104
66The interval between server ticks, in seconds. 105The interval between server ticks, in seconds.
67 106
75=cut 114=cut
76 115
77BEGIN { 116BEGIN {
78 *CORE::GLOBAL::warn = sub { 117 *CORE::GLOBAL::warn = sub {
79 my $msg = join "", @_; 118 my $msg = join "", @_;
119 utf8::encode $msg;
120
80 $msg .= "\n" 121 $msg .= "\n"
81 unless $msg =~ /\n$/; 122 unless $msg =~ /\n$/;
82 123
83 print STDERR "cfperl: $msg";
84 LOG llevError, "cfperl: $msg"; 124 LOG llevError, "cfperl: $msg";
85 }; 125 };
86} 126}
87 127
88@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
93@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 133@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
94 134
95# we bless all objects into (empty) derived classes to force a method lookup 135# we bless all objects into (empty) derived classes to force a method lookup
96# within the Safe compartment. 136# within the Safe compartment.
97for my $pkg (qw( 137for my $pkg (qw(
98 cf::global 138 cf::global cf::attachable
99 cf::object cf::object::player 139 cf::object cf::object::player
100 cf::client cf::player 140 cf::client cf::player
101 cf::arch cf::living 141 cf::arch cf::living
102 cf::map cf::party cf::region 142 cf::map cf::party cf::region
103)) { 143)) {
141sub to_json($) { 181sub to_json($) {
142 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
143 JSON::Syck::Dump $_[0] 183 JSON::Syck::Dump $_[0]
144} 184}
145 185
186=item cf::sync_job { BLOCK }
187
188The design of crossfire+ requires that the main coro ($Coro::main) is
189always able to handle events or runnable, as crossfire+ is only partly
190reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
191
192If it must be done, put the blocking parts into C<sync_job>. This will run
193the given BLOCK in another coroutine while waiting for the result. The
194server will be frozen during this time, so the block should either finish
195fast or be very important.
196
197=cut
198
199sub sync_job(&) {
200 my ($job) = @_;
201
202 my $busy = 1;
203 my @res;
204
205 my $coro = Coro::async {
206 @res = eval { $job->() };
207 warn $@ if $@;
208 undef $busy;
209 };
210
211 if ($Coro::current == $Coro::main) {
212 # TODO: use suspend/resume instead
213 local $FREEZE = 1;
214 $coro->prio (Coro::PRIO_MAX);
215 while ($busy) {
216 Coro::cede_notself;
217 Event::one_event unless Coro::nready;
218 }
219 } else {
220 $coro->join;
221 }
222
223 wantarray ? @res : $res[0]
224}
225
226=item $coro = cf::coro { BLOCK }
227
228Creates and returns a new coro. This coro is automcatially being canceled
229when the extension calling this is being unloaded.
230
231=cut
232
233sub coro(&) {
234 my $cb = shift;
235
236 my $coro; $coro = async {
237 eval {
238 $cb->();
239 };
240 warn $@ if $@;
241 };
242
243 $coro->on_destroy (sub {
244 delete $EXT_CORO{$coro+0};
245 });
246 $EXT_CORO{$coro+0} = $coro;
247
248 $coro
249}
250
251sub write_runtime {
252 my $runtime = cf::localdir . "/runtime";
253
254 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
255 or return;
256
257 my $value = $cf::RUNTIME;
258 (aio_write $fh, 0, (length $value), $value, 0) <= 0
259 and return;
260
261 aio_fsync $fh
262 and return;
263
264 close $fh
265 or return;
266
267 aio_rename "$runtime~", $runtime
268 and return;
269
270 1
271}
272
146=back 273=back
147 274
148=cut 275=cut
276
277#############################################################################
278
279package cf::path;
280
281sub new {
282 my ($class, $path, $base) = @_;
283
284 $path = $path->as_string if ref $path;
285
286 my $self = bless { }, $class;
287
288 if ($path =~ s{^\?random/}{}) {
289 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
290 $self->{random} = cf::from_json $data;
291 } else {
292 if ($path =~ s{^~([^/]+)?}{}) {
293 $self->{user_rel} = 1;
294
295 if (defined $1) {
296 $self->{user} = $1;
297 } elsif ($base =~ m{^~([^/]+)/}) {
298 $self->{user} = $1;
299 } else {
300 warn "cannot resolve user-relative path without user <$path,$base>\n";
301 }
302 } elsif ($path =~ /^\//) {
303 # already absolute
304 } else {
305 $base =~ s{[^/]+/?$}{};
306 return $class->new ("$base/$path");
307 }
308
309 for ($path) {
310 redo if s{/\.?/}{/};
311 redo if s{/[^/]+/\.\./}{/};
312 }
313 }
314
315 $self->{path} = $path;
316
317 $self
318}
319
320# the name / primary key / in-game path
321sub as_string {
322 my ($self) = @_;
323
324 $self->{user_rel} ? "~$self->{user}$self->{path}"
325 : $self->{random} ? "?random/$self->{path}"
326 : $self->{path}
327}
328
329# the displayed name, this is a one way mapping
330sub visible_name {
331 my ($self) = @_;
332
333# if (my $rmp = $self->{random}) {
334# # todo: be more intelligent about this
335# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
336# } else {
337 $self->as_string
338# }
339}
340
341# escape the /'s in the path
342sub _escaped_path {
343 # ∕ is U+2215
344 (my $path = $_[0]{path}) =~ s/\//∕/g;
345 $path
346}
347
348# the original (read-only) location
349sub load_path {
350 my ($self) = @_;
351
352 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
353}
354
355# the temporary/swap location
356sub save_path {
357 my ($self) = @_;
358
359 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
360 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
361 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
362}
363
364# the unique path, might be eq to save_path
365sub uniq_path {
366 my ($self) = @_;
367
368 $self->{user_rel} || $self->{random}
369 ? undef
370 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
371}
372
373# return random map parameters, or undef
374sub random_map_params {
375 my ($self) = @_;
376
377 $self->{random}
378}
379
380# this is somewhat ugly, but style maps do need special treatment
381sub is_style_map {
382 $_[0]{path} =~ m{^/styles/}
383}
384
385package cf;
149 386
150############################################################################# 387#############################################################################
151 388
152=head2 ATTACHABLE OBJECTS 389=head2 ATTACHABLE OBJECTS
153 390
269exception. 506exception.
270 507
271=cut 508=cut
272 509
273# the following variables are defined in .xs and must not be re-created 510# the following variables are defined in .xs and must not be re-created
274our @CB_GLOBAL = (); # registry for all global events 511our @CB_GLOBAL = (); # registry for all global events
512our @CB_ATTACHABLE = (); # registry for all attachables
275our @CB_OBJECT = (); # all objects (should not be used except in emergency) 513our @CB_OBJECT = (); # all objects (should not be used except in emergency)
276our @CB_PLAYER = (); 514our @CB_PLAYER = ();
277our @CB_CLIENT = (); 515our @CB_CLIENT = ();
278our @CB_TYPE = (); # registry for type (cf-object class) based events 516our @CB_TYPE = (); # registry for type (cf-object class) based events
279our @CB_MAP = (); 517our @CB_MAP = ();
280 518
281my %attachment; 519my %attachment;
282 520
283sub _attach_cb($$$$) { 521sub _attach_cb($$$$) {
284 my ($registry, $event, $prio, $cb) = @_; 522 my ($registry, $event, $prio, $cb) = @_;
289 527
290 @{$registry->[$event]} = sort 528 @{$registry->[$event]} = sort
291 { $a->[0] cmp $b->[0] } 529 { $a->[0] cmp $b->[0] }
292 @{$registry->[$event] || []}, $cb; 530 @{$registry->[$event] || []}, $cb;
293} 531}
532
533# hack
534my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
294 535
295# attach handles attaching event callbacks 536# attach handles attaching event callbacks
296# the only thing the caller has to do is pass the correct 537# the only thing the caller has to do is pass the correct
297# registry (== where the callback attaches to). 538# registry (== where the callback attaches to).
298sub _attach { 539sub _attach {
300 541
301 my $object_type; 542 my $object_type;
302 my $prio = 0; 543 my $prio = 0;
303 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 544 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
304 545
546 #TODO: get rid of this hack
547 if ($attachable_klass{$klass}) {
548 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
549 }
550
305 while (@arg) { 551 while (@arg) {
306 my $type = shift @arg; 552 my $type = shift @arg;
307 553
308 if ($type eq "prio") { 554 if ($type eq "prio") {
309 $prio = shift @arg; 555 $prio = shift @arg;
384 my ($obj, $name) = @_; 630 my ($obj, $name) = @_;
385 631
386 exists $obj->{_attachment}{$name} 632 exists $obj->{_attachment}{$name}
387} 633}
388 634
389for my $klass (qw(GLOBAL OBJECT PLAYER CLIENT MAP)) { 635for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
390 eval "#line " . __LINE__ . " 'cf.pm' 636 eval "#line " . __LINE__ . " 'cf.pm'
391 sub cf::\L$klass\E::_attach_registry { 637 sub cf::\L$klass\E::_attach_registry {
392 (\\\@CB_$klass, KLASS_$klass) 638 (\\\@CB_$klass, KLASS_$klass)
393 } 639 }
394 640
447=cut 693=cut
448 694
449############################################################################# 695#############################################################################
450# object support 696# object support
451 697
452sub instantiate {
453 my ($obj, $data) = @_;
454
455 $data = from_json $data;
456
457 for (@$data) {
458 my ($name, $args) = @$_;
459
460 $obj->attach ($name, %{$args || {} });
461 }
462}
463
464# basically do the same as instantiate, without calling instantiate
465sub reattach { 698sub reattach {
699 # basically do the same as instantiate, without calling instantiate
466 my ($obj) = @_; 700 my ($obj) = @_;
701
467 my $registry = $obj->registry; 702 my $registry = $obj->registry;
468 703
469 @$registry = (); 704 @$registry = ();
470 705
471 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} }; 706 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
480 warn "object uses attachment '$name' that is not available, postponing.\n"; 715 warn "object uses attachment '$name' that is not available, postponing.\n";
481 } 716 }
482 } 717 }
483} 718}
484 719
485sub object_freezer_save { 720cf::attachable->attach (
486 my ($filename, $rdata, $objs) = @_;
487
488 if (length $$rdata) {
489 warn sprintf "saving %s (%d,%d)\n",
490 $filename, length $$rdata, scalar @$objs;
491
492 if (open my $fh, ">:raw", "$filename~") {
493 chmod SAVE_MODE, $fh;
494 syswrite $fh, $$rdata;
495 close $fh;
496
497 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
498 chmod SAVE_MODE, $fh;
499 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
500 close $fh;
501 rename "$filename.pst~", "$filename.pst";
502 } else {
503 unlink "$filename.pst";
504 }
505
506 rename "$filename~", $filename;
507 } else {
508 warn "FATAL: $filename~: $!\n";
509 }
510 } else {
511 unlink $filename;
512 unlink "$filename.pst";
513 }
514}
515
516sub object_freezer_as_string {
517 my ($rdata, $objs) = @_;
518
519 use Data::Dumper;
520
521 $$rdata . Dumper $objs
522}
523
524sub object_thawer_load {
525 my ($filename) = @_;
526
527 local $/;
528
529 my $av;
530
531 #TODO: use sysread etc.
532 if (open my $data, "<:raw:perlio", $filename) {
533 $data = <$data>;
534 if (open my $pst, "<:raw:perlio", "$filename.pst") {
535 $av = eval { (Storable::thaw <$pst>)->{objs} };
536 }
537 return ($data, $av);
538 }
539
540 ()
541}
542
543cf::object->attach (
544 prio => -1000000, 721 prio => -1000000,
722 on_instantiate => sub {
723 my ($obj, $data) = @_;
724
725 $data = from_json $data;
726
727 for (@$data) {
728 my ($name, $args) = @$_;
729
730 $obj->attach ($name, %{$args || {} });
731 }
732 },
733 on_reattach => \&reattach,
545 on_clone => sub { 734 on_clone => sub {
546 my ($src, $dst) = @_; 735 my ($src, $dst) = @_;
547 736
548 @{$dst->registry} = @{$src->registry}; 737 @{$dst->registry} = @{$src->registry};
549 738
551 740
552 %{$dst->{_attachment}} = %{$src->{_attachment}} 741 %{$dst->{_attachment}} = %{$src->{_attachment}}
553 if exists $src->{_attachment}; 742 if exists $src->{_attachment};
554 }, 743 },
555); 744);
745
746sub object_freezer_save {
747 my ($filename, $rdata, $objs) = @_;
748
749 sync_job {
750 if (length $$rdata) {
751 warn sprintf "saving %s (%d,%d)\n",
752 $filename, length $$rdata, scalar @$objs;
753
754 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
755 chmod SAVE_MODE, $fh;
756 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
757 aio_fsync $fh;
758 close $fh;
759
760 if (@$objs) {
761 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
762 chmod SAVE_MODE, $fh;
763 my $data = Storable::nfreeze { version => 1, objs => $objs };
764 aio_write $fh, 0, (length $data), $data, 0;
765 aio_fsync $fh;
766 close $fh;
767 aio_rename "$filename.pst~", "$filename.pst";
768 }
769 } else {
770 aio_unlink "$filename.pst";
771 }
772
773 aio_rename "$filename~", $filename;
774 } else {
775 warn "FATAL: $filename~: $!\n";
776 }
777 } else {
778 aio_unlink $filename;
779 aio_unlink "$filename.pst";
780 }
781 }
782}
783
784sub object_freezer_as_string {
785 my ($rdata, $objs) = @_;
786
787 use Data::Dumper;
788
789 $$rdata . Dumper $objs
790}
791
792sub object_thawer_load {
793 my ($filename) = @_;
794
795 my ($data, $av);
796
797 (aio_load $filename, $data) >= 0
798 or return;
799
800 unless (aio_stat "$filename.pst") {
801 (aio_load "$filename.pst", $av) >= 0
802 or return;
803 $av = eval { (Storable::thaw <$av>)->{objs} };
804 }
805
806 return ($data, $av);
807}
556 808
557############################################################################# 809#############################################################################
558# command handling &c 810# command handling &c
559 811
560=item cf::register_command $name => \&callback($ob,$args); 812=item cf::register_command $name => \&callback($ob,$args);
780 $self->send ("ext " . to_json \%msg); 1032 $self->send ("ext " . to_json \%msg);
781} 1033}
782 1034
783=back 1035=back
784 1036
1037
1038=head3 cf::map
1039
1040=over 4
1041
1042=cut
1043
1044package cf::map;
1045
1046use Fcntl;
1047use Coro::AIO;
1048
1049our $MAX_RESET = 7200;
1050our $DEFAULT_RESET = 3600;
1051$MAX_RESET = 10;#d#
1052$DEFAULT_RESET = 10;#d#
1053
1054sub generate_random_map {
1055 my ($path, $rmp) = @_;
1056
1057 # mit "rum" bekleckern, nicht
1058 cf::map::_create_random_map
1059 $path,
1060 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1061 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1062 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1063 $rmp->{exit_on_final_map},
1064 $rmp->{xsize}, $rmp->{ysize},
1065 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1066 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1067 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1068 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1069 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1070 (cf::region::find $rmp->{region})
1071}
1072
1073# and all this just because we cannot iterate over
1074# all maps in C++...
1075sub change_all_map_light {
1076 my ($change) = @_;
1077
1078 $_->change_map_light ($change) for values %cf::MAP;
1079}
1080
1081sub try_load_header($) {
1082 my ($path) = @_;
1083
1084 utf8::encode $path;
1085 aio_open $path, O_RDONLY, 0
1086 or return;
1087
1088 my $map = cf::map::new
1089 or return;
1090
1091 $map->load_header ($path)
1092 or return;
1093
1094 $map->{load_path} = $path;
1095 use Data::Dumper; warn Dumper $map;#d#
1096
1097 $map
1098}
1099
1100sub find_map {
1101 my ($path, $origin) = @_;
1102
1103 #warn "find_map<$path,$origin>\n";#d#
1104
1105 $path = ref $path ? $path : new cf::path $path, $origin && $origin->path;
1106 my $key = $path->as_string;
1107
1108 $cf::MAP{$key} || do {
1109 # do it the slow way
1110 my $map = try_load_header $path->save_path;
1111
1112 if ($map) {
1113 # safety
1114 $map->{instantiate_time} = $cf::RUNTIME
1115 if $map->{instantiate_time} > $cf::RUNTIME;
1116 } else {
1117 if (my $rmp = $path->random_map_params) {
1118 $map = generate_random_map $key, $rmp;
1119 } else {
1120 $map = try_load_header $path->load_path;
1121 }
1122
1123 $map or return;
1124
1125 $map->{instantiate_time} = $cf::RUNTIME;
1126 $map->instantiate;
1127
1128 # per-player maps become, after loading, normal maps
1129 $map->per_player (0) if $path->{user_rel};
1130 }
1131
1132 $map->path ($key);
1133 $map->{path} = $path;
1134 $map->last_access ($cf::RUNTIME);
1135
1136 $map->reset if $map->should_reset;
1137
1138 $cf::MAP{$key} = $map
1139 }
1140}
1141
1142sub load {
1143 my ($self) = @_;
1144
1145 return if $self->in_memory != cf::MAP_SWAPPED;
1146
1147 $self->in_memory (cf::MAP_LOADING);
1148
1149 my $path = $self->{path};
1150
1151 $self->alloc;
1152 $self->load_objects ($self->{load_path}, 1)
1153 or return;
1154
1155 if (my $uniq = $path->uniq_path) {
1156 utf8::encode $uniq;
1157 if (aio_open $uniq, O_RDONLY, 0) {
1158 $self->clear_unique_items;
1159 $self->load_objects ($uniq, 0);
1160 }
1161 }
1162
1163 # now do the right thing for maps
1164 $self->link_multipart_objects;
1165
1166 if ($self->{path}->is_style_map) {
1167 $self->{deny_save} = 1;
1168 $self->{deny_reset} = 1;
1169 } else {
1170 $self->fix_auto_apply;
1171 $self->decay_objects;
1172 $self->update_buttons;
1173 $self->set_darkness_map;
1174 $self->difficulty ($self->estimate_difficulty)
1175 unless $self->difficulty;
1176 $self->activate;
1177 }
1178
1179 $self->in_memory (cf::MAP_IN_MEMORY);
1180}
1181
1182sub load_map_sync {
1183 my ($path, $origin) = @_;
1184
1185 #warn "load_map_sync<$path, $origin>\n";#d#
1186
1187 cf::sync_job {
1188 my $map = cf::map::find_map $path, $origin
1189 or return;
1190 $map->load;
1191 $map
1192 }
1193}
1194
1195sub save {
1196 my ($self) = @_;
1197
1198 my $save = $self->{path}->save_path; utf8::encode $save;
1199 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1200
1201 $self->{last_save} = $cf::RUNTIME;
1202
1203 return unless $self->dirty;
1204
1205 $self->{load_path} = $save;
1206
1207 return if $self->{deny_save};
1208
1209 warn "saving map ", $self->path;
1210
1211 if ($uniq) {
1212 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1213 $self->save_objects ($uniq, cf::IO_UNIQUES);
1214 } else {
1215 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1216 }
1217}
1218
1219sub swap_out {
1220 my ($self) = @_;
1221
1222 return if $self->players;
1223 return if $self->in_memory != cf::MAP_IN_MEMORY;
1224 return if $self->{deny_save};
1225
1226 $self->save;
1227 $self->clear;
1228 $self->in_memory (cf::MAP_SWAPPED);
1229}
1230
1231sub should_reset {
1232 my ($map) = @_;
1233
1234 # TODO: safety, remove and allow resettable per-player maps
1235 return if $map->{path}{user_rel};#d#
1236 return if $map->{deny_reset};
1237 #return unless $map->reset_timeout;
1238
1239 my $time = $map->fixed_resettime ? $map->{instantiate_time} : $map->last_access;
1240
1241 $time + ($map->reset_timeout || $DEFAULT_RESET) < $cf::RUNTIME
1242}
1243
1244sub reset {
1245 my ($self) = @_;
1246
1247 return if $self->players;
1248 return if $self->{path}{user_rel};#d#
1249
1250 warn "resetting map ", $self->path;#d#
1251
1252 utf8::encode (my $save = $self->{path}->save_path);
1253 aioreq_pri 3; IO::AIO::aio_unlink $save;
1254 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1255
1256 $_->clear_links_to ($self) for values %cf::MAP;
1257
1258 $self->clear;
1259 $self->in_memory (cf::MAP_SWAPPED);
1260 utf8::encode ($self->{load_path} = $self->{path}->load_path);
1261}
1262
1263sub customise_for {
1264 my ($map, $ob) = @_;
1265
1266 if ($map->per_player) {
1267 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
1268 }
1269
1270 $map
1271}
1272
1273sub emergency_save {
1274 local $cf::FREEZE = 1;
1275
1276 warn "enter emergency map save\n";
1277
1278 cf::sync_job {
1279 warn "begin emergency map save\n";
1280 $_->save for values %cf::MAP;
1281 };
1282
1283 warn "end emergency map save\n";
1284}
1285
1286package cf;
1287
1288=back
1289
1290
785=head3 cf::object::player 1291=head3 cf::object::player
786 1292
787=over 4 1293=over 4
788 1294
789=item $player_object->reply ($npc, $msg[, $flags]) 1295=item $player_object->reply ($npc, $msg[, $flags])
824 (ref $cf::CFG{"may_$access"} 1330 (ref $cf::CFG{"may_$access"}
825 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1331 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
826 : $cf::CFG{"may_$access"}) 1332 : $cf::CFG{"may_$access"})
827} 1333}
828 1334
1335sub cf::object::player::enter_link {
1336 my ($self) = @_;
1337
1338 return if $self->map == $LINK_MAP;
1339
1340 $self->{_link_pos} = [$self->map->{path}, $self->x, $self->y]
1341 if $self->map;
1342
1343 $self->enter_map ($LINK_MAP, 20, 20);
1344 $self->deactivate_recursive;
1345}
1346
1347sub cf::object::player::leave_link {
1348 my ($self, $map, $x, $y) = @_;
1349
1350 my $link_pos = delete $self->{_link_pos};
1351
1352 unless ($map) {
1353 $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1354
1355 # restore original map position
1356 ($map, $x, $y) = @{ $link_pos || [] };
1357 $map = cf::map::find_map $map;
1358
1359 unless ($map) {
1360 ($map, $x, $y) = @$EMERGENCY_POSITION;
1361 $map = cf::map::find_map $map
1362 or die "FATAL: cannot load emergency map\n";
1363 }
1364 }
1365
1366 ($x, $y) = (-1, -1)
1367 unless (defined $x) && (defined $y);
1368
1369 # use -1 or undef as default coordinates, not 0, 0
1370 ($x, $y) = ($map->enter_x, $map->enter_y)
1371 if $x <=0 && $y <= 0;
1372
1373 $map->load;
1374
1375 $self->activate_recursive;
1376 $self->enter_map ($map, $x, $y);
1377}
1378
1379=item $player_object->goto_map ($map, $x, $y)
1380
1381=cut
1382
1383sub cf::object::player::goto_map {
1384 my ($self, $path, $x, $y) = @_;
1385
1386 $self->enter_link;
1387
1388 (Coro::async {
1389 $path = new cf::path $path;
1390
1391 my $map = cf::map::find_map $path->as_string;
1392 $map = $map->customise_for ($self) if $map;
1393
1394 warn "entering ", $map->path, " at ($x, $y)\n"
1395 if $map;
1396
1397 $self->leave_link ($map, $x, $y);
1398 })->prio (1);
1399}
1400
1401=item $player_object->enter_exit ($exit_object)
1402
1403=cut
1404
1405sub parse_random_map_params {
1406 my ($spec) = @_;
1407
1408 my $rmp = { # defaults
1409 xsize => 10,
1410 ysize => 10,
1411 };
1412
1413 for (split /\n/, $spec) {
1414 my ($k, $v) = split /\s+/, $_, 2;
1415
1416 $rmp->{lc $k} = $v if (length $k) && (length $v);
1417 }
1418
1419 $rmp
1420}
1421
1422sub prepare_random_map {
1423 my ($exit) = @_;
1424
1425 # all this does is basically replace the /! path by
1426 # a new random map path (?random/...) with a seed
1427 # that depends on the exit object
1428
1429 my $rmp = parse_random_map_params $exit->msg;
1430
1431 if ($exit->map) {
1432 $rmp->{region} = $exit->map->region_name;
1433 $rmp->{origin_map} = $exit->map->path;
1434 $rmp->{origin_x} = $exit->x;
1435 $rmp->{origin_y} = $exit->y;
1436 }
1437
1438 $rmp->{random_seed} ||= $exit->random_seed;
1439
1440 my $data = cf::to_json $rmp;
1441 my $md5 = Digest::MD5::md5_hex $data;
1442
1443 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) {
1444 aio_write $fh, 0, (length $data), $data, 0;
1445
1446 $exit->slaying ("?random/$md5");
1447 $exit->msg (undef);
1448 }
1449}
1450
1451sub cf::object::player::enter_exit {
1452 my ($self, $exit) = @_;
1453
1454 return unless $self->type == cf::PLAYER;
1455
1456 $self->enter_link;
1457
1458 (Coro::async {
1459 unless (eval {
1460
1461 prepare_random_map $exit
1462 if $exit->slaying eq "/!";
1463
1464 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1465 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1466
1467 1;
1468 }) {
1469 $self->message ("Something went wrong deep within the crossfire server. "
1470 . "I'll try to bring you back to the map you were before. "
1471 . "Please report this to the dungeon master",
1472 cf::NDI_UNIQUE | cf::NDI_RED);
1473
1474 warn "ERROR in enter_exit: $@";
1475 $self->leave_link;
1476 }
1477 })->prio (1);
1478}
1479
829=head3 cf::client 1480=head3 cf::client
830 1481
831=over 4 1482=over 4
832 1483
833=item $client->send_drawinfo ($text, $flags) 1484=item $client->send_drawinfo ($text, $flags)
886 1537
887 if (@{ $ns->{query_queue} } == @$queue) { 1538 if (@{ $ns->{query_queue} } == @$queue) {
888 if (@$queue) { 1539 if (@$queue) {
889 $ns->send_packet ($ns->{query_queue}[0][0]); 1540 $ns->send_packet ($ns->{query_queue}[0][0]);
890 } else { 1541 } else {
891 $ns->state (ST_PLAYING); 1542 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
892 } 1543 }
893 } 1544 }
894 }, 1545 },
895); 1546);
896 1547
908 my $coro; $coro = async { 1559 my $coro; $coro = async {
909 eval { 1560 eval {
910 $cb->(); 1561 $cb->();
911 }; 1562 };
912 warn $@ if $@; 1563 warn $@ if $@;
1564 };
1565
1566 $coro->on_destroy (sub {
913 delete $self->{_coro}{$coro+0}; 1567 delete $self->{_coro}{$coro+0};
914 }; 1568 });
915 1569
916 $self->{_coro}{$coro+0} = $coro; 1570 $self->{_coro}{$coro+0} = $coro;
1571
1572 $coro
917} 1573}
918 1574
919cf::client->attach ( 1575cf::client->attach (
920 on_destroy => sub { 1576 on_destroy => sub {
921 my ($ns) = @_; 1577 my ($ns) = @_;
1153 local $/; 1809 local $/;
1154 *CFG = YAML::Syck::Load <$fh>; 1810 *CFG = YAML::Syck::Load <$fh>;
1155} 1811}
1156 1812
1157sub main { 1813sub main {
1814 # we must not ever block the main coroutine
1815 local $Coro::idle = sub {
1816 Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1817 (Coro::unblock_sub {
1818 Event::one_event;
1819 })->();
1820 };
1821
1158 cfg_load; 1822 cfg_load;
1159 db_load; 1823 db_load;
1160 load_extensions; 1824 load_extensions;
1161 Event::loop; 1825 Event::loop;
1162} 1826}
1163 1827
1164############################################################################# 1828#############################################################################
1165# initialisation 1829# initialisation
1166 1830
1167sub _perl_reload(&) { 1831sub perl_reload() {
1168 my ($msg) = @_; 1832 # can/must only be called in main
1833 if ($Coro::current != $Coro::main) {
1834 warn "can only reload from main coroutine\n";
1835 return;
1836 }
1169 1837
1170 $msg->("reloading..."); 1838 warn "reloading...";
1839
1840 local $FREEZE = 1;
1841 cf::emergency_save;
1171 1842
1172 eval { 1843 eval {
1844 # if anything goes wrong in here, we should simply crash as we already saved
1845
1173 # cancel all watchers 1846 # cancel all watchers
1174 for (Event::all_watchers) { 1847 for (Event::all_watchers) {
1175 $_->cancel if $_->data & WF_AUTOCANCEL; 1848 $_->cancel if $_->data & WF_AUTOCANCEL;
1176 } 1849 }
1177 1850
1851 # cancel all extension coros
1852 $_->cancel for values %EXT_CORO;
1853 %EXT_CORO = ();
1854
1178 # unload all extensions 1855 # unload all extensions
1179 for (@exts) { 1856 for (@exts) {
1180 $msg->("unloading <$_>"); 1857 warn "unloading <$_>";
1181 unload_extension $_; 1858 unload_extension $_;
1182 } 1859 }
1183 1860
1184 # unload all modules loaded from $LIBDIR 1861 # unload all modules loaded from $LIBDIR
1185 while (my ($k, $v) = each %INC) { 1862 while (my ($k, $v) = each %INC) {
1186 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 1863 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1187 1864
1188 $msg->("removing <$k>"); 1865 warn "removing <$k>";
1189 delete $INC{$k}; 1866 delete $INC{$k};
1190 1867
1191 $k =~ s/\.pm$//; 1868 $k =~ s/\.pm$//;
1192 $k =~ s/\//::/g; 1869 $k =~ s/\//::/g;
1193 1870
1198 Symbol::delete_package $k; 1875 Symbol::delete_package $k;
1199 } 1876 }
1200 1877
1201 # sync database to disk 1878 # sync database to disk
1202 cf::db_sync; 1879 cf::db_sync;
1880 IO::AIO::flush;
1203 1881
1204 # get rid of safe::, as good as possible 1882 # get rid of safe::, as good as possible
1205 Symbol::delete_package "safe::$_" 1883 Symbol::delete_package "safe::$_"
1206 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region); 1884 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1207 1885
1208 # remove register_script_function callbacks 1886 # remove register_script_function callbacks
1209 # TODO 1887 # TODO
1210 1888
1211 # unload cf.pm "a bit" 1889 # unload cf.pm "a bit"
1214 # don't, removes xs symbols, too, 1892 # don't, removes xs symbols, too,
1215 # and global variables created in xs 1893 # and global variables created in xs
1216 #Symbol::delete_package __PACKAGE__; 1894 #Symbol::delete_package __PACKAGE__;
1217 1895
1218 # reload cf.pm 1896 # reload cf.pm
1219 $msg->("reloading cf.pm"); 1897 warn "reloading cf.pm";
1220 require cf; 1898 require cf;
1899 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1221 1900
1222 # load config and database again 1901 # load config and database again
1223 cf::cfg_load; 1902 cf::cfg_load;
1224 cf::db_load; 1903 cf::db_load;
1225 1904
1226 # load extensions 1905 # load extensions
1227 $msg->("load extensions"); 1906 warn "load extensions";
1228 cf::load_extensions; 1907 cf::load_extensions;
1229 1908
1230 # reattach attachments to objects 1909 # reattach attachments to objects
1231 $msg->("reattach"); 1910 warn "reattach";
1232 _global_reattach; 1911 _global_reattach;
1233 }; 1912 };
1234 $msg->($@) if $@;
1235 1913
1236 $msg->("reloaded"); 1914 if ($@) {
1915 warn $@;
1916 warn "error while reloading, exiting.";
1917 exit 1;
1918 }
1919
1920 warn "reloaded successfully";
1237}; 1921};
1238 1922
1239sub perl_reload() { 1923#############################################################################
1240 _perl_reload { 1924
1241 warn $_[0]; 1925unless ($LINK_MAP) {
1242 print "$_[0]\n"; 1926 $LINK_MAP = cf::map::new;
1243 }; 1927
1928 $LINK_MAP->width (41);
1929 $LINK_MAP->height (41);
1930 $LINK_MAP->alloc;
1931 $LINK_MAP->path ("{link}");
1932 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1933 $LINK_MAP->in_memory (MAP_IN_MEMORY);
1934
1935 # dirty hack because... archetypes are not yet loaded
1936 Event->timer (
1937 after => 2,
1938 cb => sub {
1939 $_[0]->w->cancel;
1940
1941 # provide some exits "home"
1942 my $exit = cf::object::new "exit";
1943
1944 $exit->slaying ($EMERGENCY_POSITION->[0]);
1945 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
1946 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
1947
1948 $LINK_MAP->insert ($exit->clone, 19, 19);
1949 $LINK_MAP->insert ($exit->clone, 19, 20);
1950 $LINK_MAP->insert ($exit->clone, 19, 21);
1951 $LINK_MAP->insert ($exit->clone, 20, 19);
1952 $LINK_MAP->insert ($exit->clone, 20, 21);
1953 $LINK_MAP->insert ($exit->clone, 21, 19);
1954 $LINK_MAP->insert ($exit->clone, 21, 20);
1955 $LINK_MAP->insert ($exit->clone, 21, 21);
1956
1957 $exit->destroy;
1958 });
1959
1960 $LINK_MAP->{deny_save} = 1;
1961 $LINK_MAP->{deny_reset} = 1;
1962
1963 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1244} 1964}
1245 1965
1246register "<global>", __PACKAGE__; 1966register "<global>", __PACKAGE__;
1247 1967
1248register_command "perl-reload" => sub { 1968register_command "perl-reload" => sub {
1249 my ($who, $arg) = @_; 1969 my ($who, $arg) = @_;
1250 1970
1251 if ($who->flag (FLAG_WIZ)) { 1971 if ($who->flag (FLAG_WIZ)) {
1972 $who->message ("start of reload.");
1252 _perl_reload { 1973 perl_reload;
1253 warn $_[0]; 1974 $who->message ("end of reload.");
1254 $who->message ($_[0]);
1255 };
1256 } 1975 }
1257}; 1976};
1258 1977
1259unshift @INC, $LIBDIR; 1978unshift @INC, $LIBDIR;
1260 1979
1261$TICK_WATCHER = Event->timer ( 1980$TICK_WATCHER = Event->timer (
1981 reentrant => 0,
1262 prio => 0, 1982 prio => 0,
1263 at => $NEXT_TICK || 1, 1983 at => $NEXT_TICK || $TICK,
1264 data => WF_AUTOCANCEL, 1984 data => WF_AUTOCANCEL,
1265 cb => sub { 1985 cb => sub {
1986 unless ($FREEZE) {
1266 cf::server_tick; # one server iteration 1987 cf::server_tick; # one server iteration
1988 $RUNTIME += $TICK;
1989 }
1267 1990
1268 my $NOW = Event::time;
1269 $NEXT_TICK += $TICK; 1991 $NEXT_TICK += $TICK;
1270 1992
1271 # if we are delayed by four ticks or more, skip them all 1993 # if we are delayed by four ticks or more, skip them all
1272 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1994 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1273 1995
1274 $TICK_WATCHER->at ($NEXT_TICK); 1996 $TICK_WATCHER->at ($NEXT_TICK);
1275 $TICK_WATCHER->start; 1997 $TICK_WATCHER->start;
1276 }, 1998 },
1277); 1999);
1278 2000
1279IO::AIO::max_poll_time $TICK * 0.2; 2001IO::AIO::max_poll_time $TICK * 0.2;
1280 2002
2003Event->io (
1281Event->io (fd => IO::AIO::poll_fileno, 2004 fd => IO::AIO::poll_fileno,
1282 poll => 'r', 2005 poll => 'r',
1283 prio => 5, 2006 prio => 5,
1284 data => WF_AUTOCANCEL, 2007 data => WF_AUTOCANCEL,
1285 cb => \&IO::AIO::poll_cb); 2008 cb => \&IO::AIO::poll_cb,
2009);
2010
2011Event->timer (
2012 data => WF_AUTOCANCEL,
2013 after => 0,
2014 interval => 10,
2015 cb => sub {
2016 (Coro::unblock_sub {
2017 write_runtime
2018 or warn "ERROR: unable to write runtime file: $!";
2019 })->();
2020 },
2021);
1286 2022
12871 20231
1288 2024

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines