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.145 by root, Sun Jan 7 21:54:59 2007 UTC vs.
Revision 1.156 by root, Tue Jan 9 22:07:08 2007 UTC

… …
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.32 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 35
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
37our %EXTCMD = (); 38our %EXTCMD = ();
38 39
… …
53our %MAP; # all maps 54our %MAP; # all maps
54our $LINK_MAP; # the special {link} map 55our $LINK_MAP; # the special {link} map
55our $RANDOM_MAPS = cf::localdir . "/random"; 56our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; # coroutines bound to extensions 57our %EXT_CORO; # coroutines bound to extensions
57 58
59our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
60our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
61
58binmode STDOUT; 62binmode STDOUT;
59binmode STDERR; 63binmode STDERR;
60 64
61# read virtual server time, if available 65# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") { 66unless ($RUNTIME || !-e cf::localdir . "/runtime") {
… …
106=item %cf::CFG 110=item %cf::CFG
107 111
108Configuration for the server, loaded from C</etc/crossfire/config>, or 112Configuration for the server, loaded from C</etc/crossfire/config>, or
109from wherever your confdir points to. 113from wherever your confdir points to.
110 114
115=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
116
117These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
118or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
119processing has been done. Call C<< ->wait >> on them to maximise the
120window of cpu time available, or simply to synchronise to the server tick.
121
111=back 122=back
112 123
113=cut 124=cut
114 125
115BEGIN { 126BEGIN {
… …
118 utf8::encode $msg; 129 utf8::encode $msg;
119 130
120 $msg .= "\n" 131 $msg .= "\n"
121 unless $msg =~ /\n$/; 132 unless $msg =~ /\n$/;
122 133
123 LOG llevError, "cfperl: $msg"; 134 LOG llevError, $msg;
124 }; 135 };
125} 136}
126 137
127@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 138@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
128@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 139@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
… …
154 165
155=head2 UTILITY FUNCTIONS 166=head2 UTILITY FUNCTIONS
156 167
157=over 4 168=over 4
158 169
170=item dumpval $ref
171
159=cut 172=cut
173
174sub dumpval {
175 eval {
176 local $SIG{__DIE__};
177 my $d;
178 if (1) {
179 $d = new Data::Dumper([$_[0]], ["*var"]);
180 $d->Terse(1);
181 $d->Indent(2);
182 $d->Quotekeys(0);
183 $d->Useqq(1);
184 #$d->Bless(...);
185 $d->Seen($_[1]) if @_ > 1;
186 $d = $d->Dump();
187 }
188 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
189 $d
190 } || "[unable to dump $_[0]: '$@']";
191}
160 192
161use JSON::Syck (); # TODO# replace by JSON::PC once working 193use JSON::Syck (); # TODO# replace by JSON::PC once working
162 194
163=item $ref = cf::from_json $json 195=item $ref = cf::from_json $json
164 196
… …
334=cut 366=cut
335 367
336############################################################################# 368#############################################################################
337 369
338package cf::path; 370package cf::path;
371
372# used to convert map paths into valid unix filenames by repalcing / by ∕
373our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
339 374
340sub new { 375sub new {
341 my ($class, $path, $base) = @_; 376 my ($class, $path, $base) = @_;
342 377
343 $path = $path->as_string if ref $path; 378 $path = $path->as_string if ref $path;
… …
407# } 442# }
408} 443}
409 444
410# escape the /'s in the path 445# escape the /'s in the path
411sub _escaped_path { 446sub _escaped_path {
412 # ∕ is U+2215
413 (my $path = $_[0]{path}) =~ s/\//∕/g; 447 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
414 $path 448 $path
415} 449}
416 450
417# the original (read-only) location 451# the original (read-only) location
418sub load_path { 452sub load_path {
… …
1045}; 1079};
1046 1080
1047cf::map->attach (prio => -10000, package => cf::mapsupport::); 1081cf::map->attach (prio => -10000, package => cf::mapsupport::);
1048 1082
1049############################################################################# 1083#############################################################################
1050# load/save perl data associated with player->ob objects
1051
1052sub all_objects(@) {
1053 @_, map all_objects ($_->inv), @_
1054}
1055
1056# TODO: compatibility cruft, remove when no longer needed
1057cf::player->attach (
1058 on_load => sub {
1059 my ($pl, $path) = @_;
1060
1061 for my $o (all_objects $pl->ob) {
1062 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1063 $o->set_ob_key_value ("_perl_data");
1064
1065 %$o = %{ Storable::thaw pack "H*", $value };
1066 }
1067 }
1068 },
1069);
1070
1071#############################################################################
1072 1084
1073=head2 CORE EXTENSIONS 1085=head2 CORE EXTENSIONS
1074 1086
1075Functions and methods that extend core crossfire objects. 1087Functions and methods that extend core crossfire objects.
1076 1088
1077=cut 1089=cut
1078 1090
1079package cf::player; 1091package cf::player;
1092
1093use Coro::AIO;
1080 1094
1081=head3 cf::player 1095=head3 cf::player
1082 1096
1083=over 4 1097=over 4
1084 1098
… …
1119 return $cf::PLAYER{$_[0]} || do { 1133 return $cf::PLAYER{$_[0]} || do {
1120 my $login = $_[0]; 1134 my $login = $_[0];
1121 1135
1122 my $guard = cf::lock_acquire "user_find:$login"; 1136 my $guard = cf::lock_acquire "user_find:$login";
1123 1137
1124 $cf::PLAYER{$login} ||= (load_pl path $login or return); 1138 $cf::PLAYER{$_[0]} || do {
1139 my $pl = load_pl path $login
1140 or return;
1141 $cf::PLAYER{$login} = $pl
1142 }
1125 }; 1143 }
1126} 1144}
1127 1145
1128sub save($) { 1146sub save($) {
1129 my ($pl) = @_; 1147 my ($pl) = @_;
1130 1148
… …
1132 1150
1133 my $path = path $pl; 1151 my $path = path $pl;
1134 my $guard = cf::lock_acquire "user_save:$path"; 1152 my $guard = cf::lock_acquire "user_save:$path";
1135 1153
1136 return if $pl->{deny_save}; 1154 return if $pl->{deny_save};
1155
1156 aio_mkdir playerdir $pl, 0770;
1137 $pl->{last_save} = $cf::RUNTIME; 1157 $pl->{last_save} = $cf::RUNTIME;
1138 1158
1139 Coro::cede;
1140 $pl->save_pl ($path); 1159 $pl->save_pl ($path);
1141 Coro::cede; 1160 Coro::cede;
1142} 1161}
1143 1162
1144sub new($) { 1163sub new($) {
… …
1151 1170
1152 $cf::PLAYER{$login} = $self; 1171 $cf::PLAYER{$login} = $self;
1153 1172
1154 $self 1173 $self
1155} 1174}
1175
1176=item $pl->quit_character
1177
1178Nukes the player without looking back. If logged in, the connection will
1179be destroyed. May block for a long time.
1180
1181=cut
1156 1182
1157sub quit_character { 1183sub quit_character {
1158 my ($pl) = @_; 1184 my ($pl) = @_;
1159 1185
1160 $pl->{deny_save} = 1; 1186 $pl->{deny_save} = 1;
… …
1165 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1191 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1166 $pl->ns->destroy if $pl->ns; 1192 $pl->ns->destroy if $pl->ns;
1167 1193
1168 my $path = playerdir $pl; 1194 my $path = playerdir $pl;
1169 my $temp = "$path~$cf::RUNTIME~deleting~"; 1195 my $temp = "$path~$cf::RUNTIME~deleting~";
1170 IO::AIO::aio_rename $path, $temp, sub { 1196 aio_rename $path, $temp;
1171 delete $cf::PLAYER{$pl->ob->name}; 1197 delete $cf::PLAYER{$pl->ob->name};
1172 $pl->destroy; 1198 $pl->destroy;
1173
1174 IO::AIO::aio_rmtree $temp; 1199 IO::AIO::aio_rmtree $temp;
1200}
1201
1202=item cf::player::list_logins
1203
1204Returns am arrayref of all valid playernames in the system, can take a
1205while and may block, so not sync_job-capable, ever.
1206
1207=cut
1208
1209sub list_logins {
1210 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1211 or return [];
1212
1213 my @logins;
1214
1215 for my $login (@$dirs) {
1216 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1217 aio_read $fh, 0, 512, my $buf, 0 or next;
1218 $buf !~ /^password -------------$/m or next; # official not-valid tag
1219
1220 utf8::decode $login;
1221 push @logins, $login;
1175 }; 1222 }
1223
1224 \@logins
1225}
1226
1227=item $player->maps
1228
1229Returns an arrayref of cf::path's of all maps that are private for this
1230player. May block.
1231
1232=cut
1233
1234sub maps($) {
1235 my ($pl) = @_;
1236
1237 my $files = aio_readdir playerdir $pl
1238 or return;
1239
1240 my @paths;
1241
1242 for (@$files) {
1243 utf8::decode $_;
1244 next if /\.(?:pl|pst)$/;
1245 next unless /^$PATH_SEP/;
1246
1247 s/$PATH_SEP/\//g;
1248 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1249 }
1250
1251 \@paths
1176} 1252}
1177 1253
1178=item $player->ext_reply ($msgid, $msgtype, %msg) 1254=item $player->ext_reply ($msgid, $msgtype, %msg)
1179 1255
1180Sends an ext reply to the player. 1256Sends an ext reply to the player.
… …
1500 } 1576 }
1501 1577
1502 $map 1578 $map
1503} 1579}
1504 1580
1505sub emergency_save {
1506 my $freeze_guard = cf::freeze_mainloop;
1507
1508 warn "enter emergency perl save\n";
1509
1510 cf::sync_job {
1511 warn "begin emergency player save\n";
1512 $_->save for values %cf::PLAYER;
1513 warn "end emergency player save\n";
1514
1515 warn "begin emergency map save\n";
1516 $_->save for values %cf::MAP;
1517 warn "end emergency map save\n";
1518 };
1519
1520 warn "leave emergency perl save\n";
1521}
1522
1523package cf; 1581package cf;
1524 1582
1525=back 1583=back
1526 1584
1585=head3 cf::object
1586
1587=cut
1588
1589package cf::object;
1590
1591=over 4
1592
1593=item $ob->inv_recursive
1594
1595Returns the inventory of the object _and_ their inventories, recursively.
1596
1597=cut
1598
1599sub inv_recursive_;
1600sub inv_recursive_ {
1601 map { $_, inv_recursive_ $_->inv } @_
1602}
1603
1604sub inv_recursive {
1605 inv_recursive_ inv $_[0]
1606}
1607
1608package cf;
1609
1610=back
1527 1611
1528=head3 cf::object::player 1612=head3 cf::object::player
1529 1613
1530=over 4 1614=over 4
1531 1615
… …
1668=cut 1752=cut
1669 1753
1670sub cf::object::player::goto { 1754sub cf::object::player::goto {
1671 my ($self, $path, $x, $y) = @_; 1755 my ($self, $path, $x, $y) = @_;
1672 1756
1757 $path = new cf::path $path;
1758 $path ne "/" or Carp::cluck ("oy");#d#
1759
1673 $self->enter_link; 1760 $self->enter_link;
1674 1761
1675 (async { 1762 (async {
1676 $path = new cf::path $path;
1677
1678 my $map = cf::map::find $path->as_string; 1763 my $map = cf::map::find $path->as_string;
1679 $map = $map->customise_for ($self) if $map; 1764 $map = $map->customise_for ($self) if $map;
1680 1765
1681# warn "entering ", $map->path, " at ($x, $y)\n" 1766# warn "entering ", $map->path, " at ($x, $y)\n"
1682# if $map; 1767# if $map;
1683 1768
1684 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1769 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1685 1770
1686 $self->leave_link ($map, $x, $y); 1771 $self->leave_link ($map, $x, $y);
1687 })->prio (1); 1772 })->prio (1);
1688} 1773}
1689 1774
… …
2097 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 2182 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2098 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 2183 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2099 2184
2100 if (exists $CFG{mlockall}) { 2185 if (exists $CFG{mlockall}) {
2101 eval { 2186 eval {
2102 $CFG{mlockall} ? &mlockall : &munlockall 2187 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2103 and die "WARNING: m(un)lockall failed: $!\n"; 2188 and die "WARNING: m(un)lockall failed: $!\n";
2104 }; 2189 };
2105 warn $@ if $@; 2190 warn $@ if $@;
2106 } 2191 }
2107} 2192}
… …
2118 load_extensions; 2203 load_extensions;
2119 Event::loop; 2204 Event::loop;
2120} 2205}
2121 2206
2122############################################################################# 2207#############################################################################
2123# initialisation 2208# initialisation and cleanup
2209
2210# install some emergency cleanup handlers
2211BEGIN {
2212 for my $signal (qw(INT HUP TERM)) {
2213 Event->signal (
2214 data => WF_AUTOCANCEL,
2215 signal => $signal,
2216 cb => sub {
2217 cf::cleanup "SIG$signal";
2218 },
2219 );
2220 }
2221}
2222
2223sub emergency_save() {
2224 my $freeze_guard = cf::freeze_mainloop;
2225
2226 warn "enter emergency perl save\n";
2227
2228 cf::sync_job {
2229 # use a peculiar iteration method to avoid tripping on perl
2230 # refcount bugs in for. also avoids problems with players
2231 # and maps saved/Destroyed asynchronously.
2232 warn "begin emergency player save\n";
2233 for my $login (keys %cf::PLAYER) {
2234 my $pl = $cf::PLAYER{$login} or next;
2235 $pl->valid or next;
2236 $pl->save;
2237 }
2238 warn "end emergency player save\n";
2239
2240 warn "begin emergency map save\n";
2241 for my $path (keys %cf::MAP) {
2242 my $map = $cf::MAP{$path} or next;
2243 $map->valid or next;
2244 $map->save;
2245 }
2246 warn "end emergency map save\n";
2247 };
2248
2249 warn "leave emergency perl save\n";
2250}
2124 2251
2125sub reload() { 2252sub reload() {
2126 # can/must only be called in main 2253 # can/must only be called in main
2127 if ($Coro::current != $Coro::main) { 2254 if ($Coro::current != $Coro::main) {
2128 warn "can only reload from main coroutine\n"; 2255 warn "can only reload from main coroutine\n";
… …
2279 data => WF_AUTOCANCEL, 2406 data => WF_AUTOCANCEL,
2280 cb => sub { 2407 cb => sub {
2281 cf::server_tick; # one server iteration 2408 cf::server_tick; # one server iteration
2282 $RUNTIME += $TICK; 2409 $RUNTIME += $TICK;
2283 $NEXT_TICK += $TICK; 2410 $NEXT_TICK += $TICK;
2411
2412 $WAIT_FOR_TICK->broadcast;
2413 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2284 2414
2285 # if we are delayed by four ticks or more, skip them all 2415 # if we are delayed by four ticks or more, skip them all
2286 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2416 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2287 2417
2288 $TICK_WATCHER->at ($NEXT_TICK); 2418 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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