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.39 by root, Fri Aug 25 13:24:50 2006 UTC vs.
Revision 1.105 by root, Sun Dec 31 17:17:23 2006 UTC

1package cf; 1package cf;
2
3use utf8;
4use strict;
2 5
3use Symbol; 6use Symbol;
4use List::Util; 7use List::Util;
5use Storable; 8use Storable;
6use Opcode; 9use Opcode;
7use Safe; 10use Safe;
8use Safe::Hole; 11use Safe::Hole;
9 12
13use Coro 3.3;
14use Coro::Event;
15use Coro::Timer;
16use Coro::Signal;
17use Coro::Semaphore;
18use Coro::AIO;
19
20use Fcntl;
21use IO::AIO 2.31 ();
22use YAML::Syck ();
10use Time::HiRes; 23use Time::HiRes;
11use Event; 24
12$Event::Eval = 1; # no idea why this is required, but it is 25use Event; $Event::Eval = 1; # no idea why this is required, but it is
13 26
14use strict; 27# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
28$YAML::Syck::ImplicitUnicode = 1;
15 29
30$Coro::main->prio (2); # run main coroutine ("the server") with very high priority
31
32sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
33
16our %COMMAND = (); 34our %COMMAND = ();
35our %COMMAND_TIME = ();
36our %EXTCMD = ();
37
17our @EVENT; 38our @EVENT;
18our @PLUGIN_EVENT; 39our $LIBDIR = datadir . "/ext";
19our %PROP_TYPE;
20our %PROP_IDX;
21our $LIBDIR = maps_directory "perl";
22 40
23our $TICK = MAX_TIME * 1e-6; 41our $TICK = MAX_TIME * 1e-6;
24our $TICK_WATCHER; 42our $TICK_WATCHER;
25our $NEXT_TICK; 43our $NEXT_TICK;
44our $NOW;
45
46our %CFG;
47
48our $UPTIME; $UPTIME ||= time;
49our $RUNTIME;
50
51our %MAP; # all maps
52our $LINK_MAP; # the special {link} map
53our $FREEZE;
54
55binmode STDOUT;
56binmode STDERR;
57
58# read virtual server time, if available
59unless ($RUNTIME || !-e cf::localdir . "/runtime") {
60 open my $fh, "<", cf::localdir . "/runtime"
61 or die "unable to read runtime file: $!";
62 $RUNTIME = <$fh> + 0.;
63}
64
65mkdir cf::localdir;
66mkdir cf::localdir . "/" . cf::playerdir;
67mkdir cf::localdir . "/" . cf::tmpdir;
68mkdir cf::localdir . "/" . cf::uniquedir;
69
70our %EXT_CORO;
71
72#############################################################################
73
74=head2 GLOBAL VARIABLES
75
76=over 4
77
78=item $cf::UPTIME
79
80The timestamp of the server start (so not actually an uptime).
81
82=item $cf::RUNTIME
83
84The time this server has run, starts at 0 and is increased by $cf::TICK on
85every server tick.
86
87=item $cf::LIBDIR
88
89The perl library directory, where extensions and cf-specific modules can
90be found. It will be added to C<@INC> automatically.
91
92=item $cf::NOW
93
94The time of the last (current) server tick.
95
96=item $cf::TICK
97
98The interval between server ticks, in seconds.
99
100=item %cf::CFG
101
102Configuration for the server, loaded from C</etc/crossfire/config>, or
103from wherever your confdir points to.
104
105=back
106
107=cut
26 108
27BEGIN { 109BEGIN {
28 @PLUGIN_EVENT = map lc, @PLUGIN_EVENT;
29
30 *CORE::GLOBAL::warn = sub { 110 *CORE::GLOBAL::warn = sub {
31 my $msg = join "", @_; 111 my $msg = join "", @_;
112 utf8::encode $msg;
113
32 $msg .= "\n" 114 $msg .= "\n"
33 unless $msg =~ /\n$/; 115 unless $msg =~ /\n$/;
34 116
35 print STDERR "cfperl: $msg";
36 LOG llevError, "cfperl: $msg"; 117 LOG llevError, "cfperl: $msg";
37 }; 118 };
38} 119}
39 120
40my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply! 121@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
122@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
123@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
124@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
125@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
126@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
41 127
42# generate property mutators 128# we bless all objects into (empty) derived classes to force a method lookup
43sub prop_gen { 129# within the Safe compartment.
44 my ($prefix, $class) = @_; 130for my $pkg (qw(
45 131 cf::global cf::attachable
132 cf::object cf::object::player
133 cf::client cf::player
134 cf::arch cf::living
135 cf::map cf::party cf::region
136)) {
46 no strict 'refs'; 137 no strict 'refs';
47
48 for my $prop (keys %PROP_TYPE) {
49 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
50 my $sub = lc $1;
51
52 my $type = $PROP_TYPE{$prop};
53 my $idx = $PROP_IDX {$prop};
54
55 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
56 $_[0]->get_property ($type, $idx)
57 };
58
59 *{"$class\::set_$sub"} = sub {
60 $_[0]->set_property ($type, $idx, $_[1]);
61 } unless $ignore_set{$prop};
62 }
63}
64
65# auto-generate most of the API
66
67prop_gen OBJECT_PROP => "cf::object";
68# CFAPI_OBJECT_ANIMATION?
69prop_gen PLAYER_PROP => "cf::object::player";
70
71prop_gen MAP_PROP => "cf::map";
72prop_gen ARCH_PROP => "cf::arch";
73
74# guessed hierarchies
75
76@ext::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
77@ext::cf::object::map::ISA = @cf::object::map::ISA = 'cf::object';
78
79# we bless all objects into derived classes to force a method lookup
80# within the Safe compartment.
81for my $pkg (qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region cf::arch)) {
82 no strict 'refs';
83 @{"ext::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 138 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
84} 139}
85 140
86$Event::DIED = sub { 141$Event::DIED = sub {
87 warn "error in event callback: @_"; 142 warn "error in event callback: @_";
88}; 143};
89 144
90my %ext_pkg; 145my %ext_pkg;
91my @exts; 146my @exts;
92my @hook; 147my @hook;
93my %command; 148
94my %extcmd; 149=head2 UTILITY FUNCTIONS
150
151=over 4
152
153=cut
154
155use JSON::Syck (); # TODO# replace by JSON::PC once working
156
157=item $ref = cf::from_json $json
158
159Converts a JSON string into the corresponding perl data structure.
160
161=cut
162
163sub from_json($) {
164 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
165 JSON::Syck::Load $_[0]
166}
167
168=item $json = cf::to_json $ref
169
170Converts a perl data structure into its JSON representation.
171
172=cut
173
174sub to_json($) {
175 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
176 JSON::Syck::Dump $_[0]
177}
178
179# main coro must never ever "block" except in Event
180# sync_job ensures this by running the job in a coroutine
181# and waiting in Event while the server is otherwise frozen
182sub sync_job(&) {
183 my ($job) = @_;
184
185 my $busy = 1;
186 my @res;
187
188 local $FREEZE = 1;
189
190 my $coro = Coro::async {
191 @res = eval { $job->() };
192 warn $@ if $@;
193 undef $busy;
194 };
195
196 if ($Coro::current == $Coro::main) {
197 $coro->prio (Coro::PRIO_MAX);
198 while ($busy) {
199 Coro::cede_notself;
200 Event::one_event unless Coro::nready;
201 }
202 } else {
203 $coro->join;
204 }
205
206 wantarray ? @res : $res[0]
207}
208
209=item $coro = cf::coro { BLOCK }
210
211Creates and returns a new coro. This coro is automcatially being canceled
212when the extension calling this is being unloaded.
213
214=cut
215
216sub coro(&) {
217 my $cb = shift;
218
219 my $coro; $coro = async {
220 eval {
221 $cb->();
222 };
223 warn $@ if $@;
224 };
225
226 $coro->on_destroy (sub {
227 delete $EXT_CORO{$coro+0};
228 });
229 $EXT_CORO{$coro+0} = $coro;
230
231 $coro
232}
233
234=back
235
236=cut
95 237
96############################################################################# 238#############################################################################
97# "new" plug-in system
98 239
99=item cf::object::attach ... # NYI 240=head2 ATTACHABLE OBJECTS
100 241
101=item cf::attach_global ... # NYI 242Many objects in crossfire are so-called attachable objects. That means you can
243attach callbacks/event handlers (a collection of which is called an "attachment")
244to it. All such attachable objects support the following methods.
102 245
103=item cf::attach_to_type ... # NYI 246In the following description, CLASS can be any of C<global>, C<object>
247C<player>, C<client> or C<map> (i.e. the attachable objects in
248crossfire+).
104 249
105=item cf::attach_to_objects ... # NYI 250=over 4
106 251
107=item cf::attach_to_players ... # NYI 252=item $attachable->attach ($attachment, key => $value...)
108 253
109=item cf::attach_to_maps ... # NYI 254=item $attachable->detach ($attachment)
110 255
111 prio => $number, # higehr is earlier 256Attach/detach a pre-registered attachment to a specific object and give it
112 on_xxx => \&cb, 257the specified key/value pairs as arguments.
258
259Example, attach a minesweeper attachment to the given object, making it a
26010x10 minesweeper game:
261
262 $obj->attach (minesweeper => width => 10, height => 10);
263
264=item $bool = $attachable->attached ($name)
265
266Checks wether the named attachment is currently attached to the object.
267
268=item cf::CLASS->attach ...
269
270=item cf::CLASS->detach ...
271
272Define an anonymous attachment and attach it to all objects of the given
273CLASS. See the next function for an explanation of its arguments.
274
275You can attach to global events by using the C<cf::global> class.
276
277Example, log all player logins:
278
279 cf::player->attach (
280 on_login => sub {
281 my ($pl) = @_;
282 ...
283 },
284 );
285
286Example, attach to the jeweler skill:
287
288 cf::object->attach (
289 type => cf::SKILL,
290 subtype => cf::SK_JEWELER,
291 on_use_skill => sub {
292 my ($sk, $ob, $part, $dir, $msg) = @_;
293 ...
294 },
295 );
296
297=item cf::CLASS::attachment $name, ...
298
299Register an attachment by C<$name> through which attachable objects of the
300given CLASS can refer to this attachment.
301
302Some classes such as crossfire maps and objects can specify attachments
303that are attached at load/instantiate time, thus the need for a name.
304
305These calls expect any number of the following handler/hook descriptions:
306
307=over 4
308
309=item prio => $number
310
311Set the priority for all following handlers/hooks (unless overwritten
312by another C<prio> setting). Lower priority handlers get executed
313earlier. The default priority is C<0>, and many built-in handlers are
314registered at priority C<-1000>, so lower priorities should not be used
315unless you know what you are doing.
316
317=item type => $type
318
319(Only for C<< cf::object->attach >> calls), limits the attachment to the
320given type of objects only (the additional parameter C<subtype> can be
321used to further limit to the given subtype).
322
323=item on_I<event> => \&cb
324
325Call the given code reference whenever the named event happens (event is
326something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
327handlers are recognised generally depends on the type of object these
328handlers attach to).
329
330See F<include/eventinc.h> for the full list of events supported, and their
331class.
332
113 package => package::, 333=item package => package::
114 334
115=cut 335Look for sub functions of the name C<< on_I<event> >> in the given
336package and register them. Only handlers for eevents supported by the
337object/class are recognised.
116 338
117our %CB_CLASS = (); # registry for class-based events 339=back
340
341Example, define an attachment called "sockpuppet" that calls the given
342event handler when a monster attacks:
343
344 cf::object::attachment sockpuppet =>
345 on_skill_attack => sub {
346 my ($self, $victim) = @_;
347 ...
348 }
349 }
350
351=item $attachable->valid
352
353Just because you have a perl object does not mean that the corresponding
354C-level object still exists. If you try to access an object that has no
355valid C counterpart anymore you get an exception at runtime. This method
356can be used to test for existence of the C object part without causing an
357exception.
358
359=cut
360
361# the following variables are defined in .xs and must not be re-created
118our @CB_GLOBAL = (); # registry for all global events 362our @CB_GLOBAL = (); # registry for all global events
363our @CB_ATTACHABLE = (); # registry for all attachables
364our @CB_OBJECT = (); # all objects (should not be used except in emergency)
365our @CB_PLAYER = ();
366our @CB_CLIENT = ();
119our @CB_TYPE = (); # registry for type (cf-object class) based events 367our @CB_TYPE = (); # registry for type (cf-object class) based events
368our @CB_MAP = ();
120 369
370my %attachment;
371
121sub _attach_cb($\%$$$) { 372sub _attach_cb($$$$) {
122 my ($registry, $undo, $event, $prio, $cb) = @_; 373 my ($registry, $event, $prio, $cb) = @_;
123 374
124 use sort 'stable'; 375 use sort 'stable';
125 376
126 $cb = [$prio, $cb]; 377 $cb = [$prio, $cb];
127 378
128 @{$registry->[$event]} = sort 379 @{$registry->[$event]} = sort
129 { $a->[0] cmp $b->[0] } 380 { $a->[0] cmp $b->[0] }
130 @{$registry->[$event] || []}, $cb; 381 @{$registry->[$event] || []}, $cb;
131
132 push @{$undo->{cb}}, [$event, $cb];
133} 382}
383
384# hack
385my %attachable_klass = map +($_ => 1), KLASS_OBJECT, KLASS_CLIENT, KLASS_PLAYER, KLASS_MAP;
134 386
135# attach handles attaching event callbacks 387# attach handles attaching event callbacks
136# the only thing the caller has to do is pass the correct 388# the only thing the caller has to do is pass the correct
137# registry (== where the callback attaches to). 389# registry (== where the callback attaches to).
138sub _attach(\@$\@) { 390sub _attach {
139 my ($registry, $klass, $arg) = @_; 391 my ($registry, $klass, @arg) = @_;
140 392
393 my $object_type;
141 my $prio = 0; 394 my $prio = 0;
142
143 my %undo = (
144 registry => $registry,
145 cb => [],
146 );
147
148 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT; 395 my %cb_id = map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == $klass, 0 .. $#EVENT;
149 396
397 #TODO: get rid of this hack
398 if ($attachable_klass{$klass}) {
399 %cb_id = (%cb_id, map +("on_" . lc $EVENT[$_][0], $_) , grep $EVENT[$_][1] == KLASS_ATTACHABLE, 0 .. $#EVENT);
400 }
401
150 while (@$arg) { 402 while (@arg) {
151 my $type = shift @$arg; 403 my $type = shift @arg;
152 404
153 if ($type eq "prio") { 405 if ($type eq "prio") {
154 $prio = shift @$arg; 406 $prio = shift @arg;
407
408 } elsif ($type eq "type") {
409 $object_type = shift @arg;
410 $registry = $CB_TYPE[$object_type] ||= [];
411
412 } elsif ($type eq "subtype") {
413 defined $object_type or Carp::croak "subtype specified without type";
414 my $object_subtype = shift @arg;
415 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= [];
155 416
156 } elsif ($type eq "package") { 417 } elsif ($type eq "package") {
157 my $pkg = shift @$arg; 418 my $pkg = shift @arg;
158 419
159 while (my ($name, $id) = each %cb_id) { 420 while (my ($name, $id) = each %cb_id) {
160 if (my $cb = $pkg->can ($name)) { 421 if (my $cb = $pkg->can ($name)) {
161 _attach_cb $registry, %undo, $id, $prio, $cb; 422 _attach_cb $registry, $id, $prio, $cb;
162 } 423 }
163 } 424 }
164 425
165 } elsif (exists $cb_id{$type}) { 426 } elsif (exists $cb_id{$type}) {
166 _attach_cb $registry, %undo, $cb_id{$type}, $prio, shift @$arg; 427 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
167 428
168 } elsif (ref $type) { 429 } elsif (ref $type) {
169 warn "attaching objects not supported, ignoring.\n"; 430 warn "attaching objects not supported, ignoring.\n";
170 431
171 } else { 432 } else {
172 shift @$arg; 433 shift @arg;
173 warn "attach argument '$type' not supported, ignoring.\n"; 434 warn "attach argument '$type' not supported, ignoring.\n";
174 } 435 }
175 } 436 }
176
177 \%undo
178} 437}
179 438
180sub cf::object::attach { 439sub _object_attach {
181 die; 440 my ($obj, $name, %arg) = @_;
182}
183 441
184sub attach_global { 442 return if exists $obj->{_attachment}{$name};
185 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
186}
187 443
188sub attach_type { 444 if (my $attach = $attachment{$name}) {
189 my $type = shift; 445 my $registry = $obj->registry;
190 _attach @{$CB_TYPE[$type]}, KLASS_MAP, @_
191}
192 446
193sub attach_to_objects { 447 for (@$attach) {
194 _attach @{$CB_CLASS{cf::object::wrap::}}, KLASS_OBJECT, @_ 448 my ($klass, @attach) = @$_;
195} 449 _attach $registry, $klass, @attach;
450 }
196 451
197sub attach_to_players { 452 $obj->{$name} = \%arg;
198 _attach @{$CB_CLASS{cf::player::wrap::}}, KLASS_PLAYER, @_ 453 } else {
199} 454 warn "object uses attachment '$name' that is not available, postponing.\n";
455 }
200 456
201sub attach_to_maps { 457 $obj->{_attachment}{$name} = undef;
202 _attach @{$CB_CLASS{cf::map::wrap::}}, KLASS_MAP, @_ 458}
459
460sub cf::attachable::attach {
461 if (ref $_[0]) {
462 _object_attach @_;
463 } else {
464 _attach shift->_attach_registry, @_;
465 }
466};
467
468# all those should be optimised
469sub cf::attachable::detach {
470 my ($obj, $name) = @_;
471
472 if (ref $obj) {
473 delete $obj->{_attachment}{$name};
474 reattach ($obj);
475 } else {
476 Carp::croak "cannot, currently, detach class attachments";
477 }
478};
479
480sub cf::attachable::attached {
481 my ($obj, $name) = @_;
482
483 exists $obj->{_attachment}{$name}
484}
485
486for my $klass (qw(ATTACHABLE GLOBAL OBJECT PLAYER CLIENT MAP)) {
487 eval "#line " . __LINE__ . " 'cf.pm'
488 sub cf::\L$klass\E::_attach_registry {
489 (\\\@CB_$klass, KLASS_$klass)
490 }
491
492 sub cf::\L$klass\E::attachment {
493 my \$name = shift;
494
495 \$attachment{\$name} = [[KLASS_$klass, \@_]];
496 }
497 ";
498 die if $@;
203} 499}
204 500
205our $override; 501our $override;
502our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
206 503
207sub override() { 504sub override {
208 $override = 1 505 $override = 1;
506 @invoke_results = ();
209} 507}
210 508
211sub invoke { 509sub do_invoke {
212 my $event = shift; 510 my $event = shift;
511 my $callbacks = shift;
213 512
214 my @cb; 513 @invoke_results = ();
215
216 if (my $ref = ref $_[0]) {
217 # 1. object-specific (NYI)
218 # 2. class-specific
219 push @cb, @{$CB_CLASS{$ref}[$event] || []};
220 }
221
222 # global
223 push @cb, @{$CB_GLOBAL[$event] || []};
224
225# warn "invoke id $EVENT[$event][0], args <@_> <=> @cb\n";#d#
226 514
227 local $override; 515 local $override;
228 516
229 for (@cb) { 517 for (@$callbacks) {
230 eval { &{$_->[1]} }; 518 eval { &{$_->[1]} };
231 519
232 if ($@) { 520 if ($@) {
233 warn "$@"; 521 warn "$@";
234 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 522 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
235 override; 523 override;
236 } 524 }
237 525
238 return 1 if $override; 526 return 1 if $override;
239 } 527 }
240 528
241 0 529 0
242} 530}
243 531
532=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...)
533
534=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
535
536Generate an object-specific event with the given arguments.
537
538This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
539removed in future versions), and there is no public API to access override
540results (if you must, access C<@cf::invoke_results> directly).
541
542=back
543
544=cut
545
244############################################################################# 546#############################################################################
245# old plug-in events 547# object support
246 548
247sub inject_event { 549sub reattach {
248 my $extension = shift; 550 # basically do the same as instantiate, without calling instantiate
249 my $event_code = shift; 551 my ($obj) = @_;
250 552
251 my $cb = $hook[$event_code]{$extension} 553 my $registry = $obj->registry;
554
555 @$registry = ();
556
557 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
558
559 for my $name (keys %{ $obj->{_attachment} || {} }) {
560 if (my $attach = $attachment{$name}) {
561 for (@$attach) {
562 my ($klass, @attach) = @$_;
563 _attach $registry, $klass, @attach;
564 }
565 } else {
566 warn "object uses attachment '$name' that is not available, postponing.\n";
567 }
568 }
569}
570
571cf::attachable->attach (
572 prio => -1000000,
573 on_instantiate => sub {
574 my ($obj, $data) = @_;
575
576 $data = from_json $data;
577
578 for (@$data) {
579 my ($name, $args) = @$_;
580
581 $obj->attach ($name, %{$args || {} });
582 }
583 },
584 on_reattach => \&reattach,
585 on_clone => sub {
586 my ($src, $dst) = @_;
587
588 @{$dst->registry} = @{$src->registry};
589
590 %$dst = %$src;
591
592 %{$dst->{_attachment}} = %{$src->{_attachment}}
593 if exists $src->{_attachment};
594 },
595);
596
597sub object_freezer_save {
598 my ($filename, $rdata, $objs) = @_;
599
600 sync_job {
601 if (length $$rdata) {
602 warn sprintf "saving %s (%d,%d)\n",
603 $filename, length $$rdata, scalar @$objs;
604
605 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
606 chmod SAVE_MODE, $fh;
607 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
608 aio_fsync $fh;
609 close $fh;
610
611 if (@$objs) {
612 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
613 chmod SAVE_MODE, $fh;
614 my $data = Storable::nfreeze { version => 1, objs => $objs };
615 aio_write $fh, 0, (length $data), $data, 0;
616 aio_fsync $fh;
617 close $fh;
618 aio_rename "$filename.pst~", "$filename.pst";
619 }
620 } else {
621 aio_unlink "$filename.pst";
622 }
623
624 aio_rename "$filename~", $filename;
625 } else {
626 warn "FATAL: $filename~: $!\n";
627 }
628 } else {
629 aio_unlink $filename;
630 aio_unlink "$filename.pst";
631 }
632 }
633}
634
635sub object_freezer_as_string {
636 my ($rdata, $objs) = @_;
637
638 use Data::Dumper;
639
640 $$rdata . Dumper $objs
641}
642
643sub object_thawer_load {
644 my ($filename) = @_;
645
646 my ($data, $av);
647
648 (aio_load $filename, $data) >= 0
252 or return; 649 or return;
253 650
254 &$cb 651 unless (aio_stat "$filename.pst") {
255} 652 (aio_load "$filename.pst", $av) >= 0
256
257sub inject_global_event {
258 my $event = shift;
259
260 my $cb = $hook[$event]
261 or return; 653 or return;
262 654 $av = eval { (Storable::thaw <$av>)->{objs} };
263 List::Util::max map &$_, values %$cb
264}
265
266sub inject_command {
267 my ($name, $obj, $params) = @_;
268
269 for my $cmd (@{ $command{$name} }) {
270 $cmd->[1]->($obj, $params);
271 } 655 }
272 656
273 -1 657 return ($data, $av);
274} 658}
659
660#############################################################################
661# command handling &c
662
663=item cf::register_command $name => \&callback($ob,$args);
664
665Register a callback for execution when the client sends the user command
666$name.
667
668=cut
275 669
276sub register_command { 670sub register_command {
277 my ($name, $time, $cb) = @_; 671 my ($name, $cb) = @_;
278 672
279 my $caller = caller; 673 my $caller = caller;
280 #warn "registering command '$name/$time' to '$caller'"; 674 #warn "registering command '$name/$time' to '$caller'";
281 675
282 push @{ $command{$name} }, [$time, $cb, $caller]; 676 push @{ $COMMAND{$name} }, [$caller, $cb];
283 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
284} 677}
678
679=item cf::register_extcmd $name => \&callback($pl,$packet);
680
681Register a callbackf ro execution when the client sends an extcmd packet.
682
683If the callback returns something, it is sent back as if reply was being
684called.
685
686=cut
285 687
286sub register_extcmd { 688sub register_extcmd {
287 my ($name, $cb) = @_; 689 my ($name, $cb) = @_;
288 690
289 my $caller = caller; 691 my $caller = caller;
290 #warn "registering extcmd '$name' to '$caller'"; 692 #warn "registering extcmd '$name' to '$caller'";
291 693
292 $extcmd{$name} = [$cb, $caller]; 694 $EXTCMD{$name} = [$cb, $caller];
293} 695}
696
697cf::player->attach (
698 on_command => sub {
699 my ($pl, $name, $params) = @_;
700
701 my $cb = $COMMAND{$name}
702 or return;
703
704 for my $cmd (@$cb) {
705 $cmd->[1]->($pl->ob, $params);
706 }
707
708 cf::override;
709 },
710 on_extcmd => sub {
711 my ($pl, $buf) = @_;
712
713 my $msg = eval { from_json $buf };
714
715 if (ref $msg) {
716 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
717 if (my %reply = $cb->[0]->($pl, $msg)) {
718 $pl->ext_reply ($msg->{msgid}, %reply);
719 }
720 }
721 } else {
722 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
723 }
724
725 cf::override;
726 },
727);
294 728
295sub register { 729sub register {
296 my ($base, $pkg) = @_; 730 my ($base, $pkg) = @_;
297 731
298 for my $idx (0 .. $#PLUGIN_EVENT) { 732 #TODO
299 if (my $ref = $pkg->can ("on_$PLUGIN_EVENT[$idx]")) {
300 #warn "registering $PLUGIN_EVENT[$idx] hook to '$pkg'\n";
301 $hook[$idx]{$base} = $ref;
302 }
303 }
304} 733}
305 734
306sub load_extension { 735sub load_extension {
307 my ($path) = @_; 736 my ($path) = @_;
308 737
309 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 738 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
310 my $base = $1; 739 my $base = $1;
311 my $pkg = $1; 740 my $pkg = $1;
312 $pkg =~ s/[^[:word:]]/_/g; 741 $pkg =~ s/[^[:word:]]/_/g;
313 $pkg = "cf::ext::$pkg"; 742 $pkg = "ext::$pkg";
314 743
315 warn "loading '$path' into '$pkg'\n"; 744 warn "loading '$path' into '$pkg'\n";
316 745
317 open my $fh, "<:utf8", $path 746 open my $fh, "<:utf8", $path
318 or die "$path: $!"; 747 or die "$path: $!";
… …
322 . "#line 1 \"$path\"\n{\n" 751 . "#line 1 \"$path\"\n{\n"
323 . (do { local $/; <$fh> }) 752 . (do { local $/; <$fh> })
324 . "\n};\n1"; 753 . "\n};\n1";
325 754
326 eval $source 755 eval $source
327 or die "$path: $@"; 756 or die $@ ? "$path: $@\n"
757 : "extension disabled.\n";
328 758
329 push @exts, $pkg; 759 push @exts, $pkg;
330 $ext_pkg{$base} = $pkg; 760 $ext_pkg{$base} = $pkg;
331 761
332# no strict 'refs'; 762# no strict 'refs';
… …
339 my ($pkg) = @_; 769 my ($pkg) = @_;
340 770
341 warn "removing extension $pkg\n"; 771 warn "removing extension $pkg\n";
342 772
343 # remove hooks 773 # remove hooks
774 #TODO
344 for my $idx (0 .. $#PLUGIN_EVENT) { 775# for my $idx (0 .. $#PLUGIN_EVENT) {
345 delete $hook[$idx]{$pkg}; 776# delete $hook[$idx]{$pkg};
346 } 777# }
347 778
348 # remove commands 779 # remove commands
349 for my $name (keys %command) { 780 for my $name (keys %COMMAND) {
350 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 781 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
351 782
352 if (@cb) { 783 if (@cb) {
353 $command{$name} = \@cb; 784 $COMMAND{$name} = \@cb;
354 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
355 } else { 785 } else {
356 delete $command{$name};
357 delete $COMMAND{"$name\000"}; 786 delete $COMMAND{$name};
358 } 787 }
359 } 788 }
360 789
361 # remove extcmds 790 # remove extcmds
362 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 791 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
363 delete $extcmd{$name}; 792 delete $EXTCMD{$name};
364 } 793 }
365 794
366 if (my $cb = $pkg->can ("on_unload")) { 795 if (my $cb = $pkg->can ("unload")) {
367 eval { 796 eval {
368 $cb->($pkg); 797 $cb->($pkg);
369 1 798 1
370 } or warn "$pkg unloaded, but with errors: $@"; 799 } or warn "$pkg unloaded, but with errors: $@";
371 } 800 }
372 801
373 Symbol::delete_package $pkg; 802 Symbol::delete_package $pkg;
374} 803}
375 804
376sub load_extensions { 805sub load_extensions {
377 my $LIBDIR = maps_directory "perl";
378
379 for my $ext (<$LIBDIR/*.ext>) { 806 for my $ext (<$LIBDIR/*.ext>) {
380 next unless -r $ext; 807 next unless -r $ext;
381 eval { 808 eval {
382 load_extension $ext; 809 load_extension $ext;
383 1 810 1
384 } or warn "$ext not loaded: $@"; 811 } or warn "$ext not loaded: $@";
385 } 812 }
386} 813}
387 814
388sub _perl_reload(&) {
389 my ($msg) = @_;
390
391 $msg->("reloading...");
392
393 eval {
394 # 1. cancel all watchers
395 $_->cancel for Event::all_watchers;
396
397 # 2. unload all extensions
398 for (@exts) {
399 $msg->("unloading <$_>");
400 unload_extension $_;
401 }
402
403 # 3. unload all modules loaded from $LIBDIR
404 while (my ($k, $v) = each %INC) {
405 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
406
407 $msg->("removing <$k>");
408 delete $INC{$k};
409
410 $k =~ s/\.pm$//;
411 $k =~ s/\//::/g;
412
413 if (my $cb = $k->can ("unload_module")) {
414 $cb->();
415 }
416
417 Symbol::delete_package $k;
418 }
419
420 # 4. get rid of ext::, as good as possible
421 Symbol::delete_package "ext::$_"
422 for qw(cf::object cf::object::map cf::object::player cf::player cf::map cf::party cf::region);
423
424 # 5. remove register_script_function callbacks
425 # TODO
426
427 # 6. unload cf.pm "a bit"
428 delete $INC{"cf.pm"};
429
430 # don't, removes xs symbols, too
431 #Symbol::delete_package __PACKAGE__;
432
433 # 7. reload cf.pm
434 $msg->("reloading cf.pm");
435 require cf;
436 };
437 $msg->($@) if $@;
438
439 $msg->("reloaded");
440};
441
442sub perl_reload() {
443 _perl_reload {
444 warn $_[0];
445 print "$_[0]\n";
446 };
447}
448
449register_command "perl-reload", 0, sub {
450 my ($who, $arg) = @_;
451
452 if ($who->flag (FLAG_WIZ)) {
453 _perl_reload {
454 warn $_[0];
455 $who->message ($_[0]);
456 };
457 }
458};
459
460#############################################################################
461# utility functions
462
463use JSON::Syck (); # TODO# replace by JSON::PC once working
464
465sub from_json($) {
466 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
467 JSON::Syck::Load $_[0]
468}
469
470sub to_json($) {
471 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
472 JSON::Syck::Dump $_[0]
473}
474
475#############################################################################
476# extcmd framework, basically convert ext <msg>
477# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
478
479sub on_extcmd {
480 my ($pl, $buf) = @_;
481
482 my $msg = eval { from_json $buf };
483
484 if (ref $msg) {
485 if (my $cb = $extcmd{$msg->{msgtype}}) {
486 if (my %reply = $cb->[0]->($pl, $msg)) {
487 $pl->ext_reply ($msg->{msgid}, %reply);
488 }
489 }
490 } else {
491 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
492 }
493
494 1
495}
496
497############################################################################# 815#############################################################################
498# load/save/clean perl data associated with a map 816# load/save/clean perl data associated with a map
499 817
500*cf::mapsupport::on_clean = sub { 818*cf::mapsupport::on_clean = sub {
501 my ($map) = @_; 819 my ($map) = @_;
502 820
503 my $path = $map->tmpname; 821 my $path = $map->tmpname;
504 defined $path or return; 822 defined $path or return;
505 823
506 unlink "$path.cfperl"; 824 unlink "$path.pst";
507}; 825};
508 826
509*cf::mapsupport::on_swapin =
510*cf::mapsupport::on_load = sub {
511 my ($map) = @_;
512
513 my $path = $map->tmpname;
514 $path = $map->path unless defined $path;
515
516 open my $fh, "<:raw", "$path.cfperl"
517 or return; # no perl data
518
519 my $data = Storable::thaw do { local $/; <$fh> };
520
521 $data->{version} <= 1
522 or return; # too new
523
524 $map->_set_obs ($data->{obs});
525};
526
527*cf::mapsupport::on_swapout = sub {
528 my ($map) = @_;
529
530 my $path = $map->tmpname;
531 $path = $map->path unless defined $path;
532
533 my $obs = $map->_get_obs;
534
535 if (defined $obs) {
536 open my $fh, ">:raw", "$path.cfperl"
537 or die "$path.cfperl: $!";
538
539 stat $path;
540
541 print $fh Storable::nfreeze {
542 size => (stat _)[7],
543 time => (stat _)[9],
544 version => 1,
545 obs => $obs,
546 };
547
548 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
549 } else {
550 unlink "$path.cfperl";
551 }
552};
553
554attach_to_maps prio => -10000, package => cf::mapsupport::; 827cf::map->attach (prio => -10000, package => cf::mapsupport::);
555 828
556############################################################################# 829#############################################################################
557# load/save perl data associated with player->ob objects 830# load/save perl data associated with player->ob objects
558 831
559sub all_objects(@) { 832sub all_objects(@) {
560 @_, map all_objects ($_->inv), @_ 833 @_, map all_objects ($_->inv), @_
561} 834}
562 835
563attach_to_players 836# TODO: compatibility cruft, remove when no longer needed
837cf::player->attach (
564 on_load => sub { 838 on_load => sub {
565 my ($pl, $path) = @_; 839 my ($pl, $path) = @_;
566 840
567 for my $o (all_objects $pl->ob) { 841 for my $o (all_objects $pl->ob) {
568 if (my $value = $o->get_ob_key_value ("_perl_data")) { 842 if (my $value = $o->get_ob_key_value ("_perl_data")) {
… …
570 844
571 %$o = %{ Storable::thaw pack "H*", $value }; 845 %$o = %{ Storable::thaw pack "H*", $value };
572 } 846 }
573 } 847 }
574 }, 848 },
575 on_save => sub { 849);
576 my ($pl, $path) = @_;
577
578 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
579 for grep %$_, all_objects $pl->ob;
580 },
581;
582 850
583############################################################################# 851#############################################################################
584# core extensions - in perl 852
853=head2 CORE EXTENSIONS
854
855Functions and methods that extend core crossfire objects.
856
857=head3 cf::player
858
859=over 4
585 860
586=item cf::player::exists $login 861=item cf::player::exists $login
587 862
588Returns true when the given account exists. 863Returns true when the given account exists.
589 864
… …
592sub cf::player::exists($) { 867sub cf::player::exists($) {
593 cf::player::find $_[0] 868 cf::player::find $_[0]
594 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 869 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
595} 870}
596 871
872=item $player->ext_reply ($msgid, $msgtype, %msg)
873
874Sends an ext reply to the player.
875
876=cut
877
878sub cf::player::ext_reply($$$%) {
879 my ($self, $id, %msg) = @_;
880
881 $msg{msgid} = $id;
882
883 $self->send ("ext " . to_json \%msg);
884}
885
886=back
887
888=head3 cf::object::player
889
890=over 4
891
597=item $player->reply ($npc, $msg[, $flags]) 892=item $player_object->reply ($npc, $msg[, $flags])
598 893
599Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 894Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
600can be C<undef>. Does the right thing when the player is currently in a 895can be C<undef>. Does the right thing when the player is currently in a
601dialogue with the given NPC character. 896dialogue with the given NPC character.
602 897
603=cut 898=cut
604 899
605# rough implementation of a future "reply" method that works 900# rough implementation of a future "reply" method that works
606# with dialog boxes. 901# with dialog boxes.
902#TODO: the first argument must go, split into a $npc->reply_to ( method
607sub cf::object::player::reply($$$;$) { 903sub cf::object::player::reply($$$;$) {
608 my ($self, $npc, $msg, $flags) = @_; 904 my ($self, $npc, $msg, $flags) = @_;
609 905
610 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 906 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
611 907
… …
615 $msg = $npc->name . " says: $msg" if $npc; 911 $msg = $npc->name . " says: $msg" if $npc;
616 $self->message ($msg, $flags); 912 $self->message ($msg, $flags);
617 } 913 }
618} 914}
619 915
620=item $player->ext_reply ($msgid, $msgtype, %msg) 916=item $player_object->may ("access")
621 917
622Sends an ext reply to the player. 918Returns wether the given player is authorized to access resource "access"
919(e.g. "command_wizcast").
623 920
624=cut 921=cut
625 922
626sub cf::player::ext_reply($$$%) { 923sub cf::object::player::may {
924 my ($self, $access) = @_;
925
926 $self->flag (cf::FLAG_WIZ) ||
927 (ref $cf::CFG{"may_$access"}
928 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
929 : $cf::CFG{"may_$access"})
930}
931
932=head3 cf::client
933
934=over 4
935
936=item $client->send_drawinfo ($text, $flags)
937
938Sends a drawinfo packet to the client. Circumvents output buffering so
939should not be used under normal circumstances.
940
941=cut
942
943sub cf::client::send_drawinfo {
944 my ($self, $text, $flags) = @_;
945
946 utf8::encode $text;
947 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text);
948}
949
950
951=item $success = $client->query ($flags, "text", \&cb)
952
953Queues a query to the client, calling the given callback with
954the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
955C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
956
957Queries can fail, so check the return code. Or don't, as queries will become
958reliable at some point in the future.
959
960=cut
961
962sub cf::client::query {
963 my ($self, $flags, $text, $cb) = @_;
964
965 return unless $self->state == ST_PLAYING
966 || $self->state == ST_SETUP
967 || $self->state == ST_CUSTOM;
968
969 $self->state (ST_CUSTOM);
970
971 utf8::encode $text;
972 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
973
974 $self->send_packet ($self->{query_queue}[0][0])
975 if @{ $self->{query_queue} } == 1;
976}
977
978cf::client->attach (
979 on_reply => sub {
980 my ($ns, $msg) = @_;
981
982 # this weird shuffling is so that direct followup queries
983 # get handled first
984 my $queue = delete $ns->{query_queue};
985
986 (shift @$queue)->[1]->($msg);
987
988 push @{ $ns->{query_queue} }, @$queue;
989
990 if (@{ $ns->{query_queue} } == @$queue) {
991 if (@$queue) {
992 $ns->send_packet ($ns->{query_queue}[0][0]);
993 } else {
994 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
995 }
996 }
997 },
998);
999
1000=item $client->coro (\&cb)
1001
1002Create a new coroutine, running the specified callback. The coroutine will
1003be automatically cancelled when the client gets destroyed (e.g. on logout,
1004or loss of connection).
1005
1006=cut
1007
1008sub cf::client::coro {
627 my ($self, $id, %msg) = @_; 1009 my ($self, $cb) = @_;
628 1010
629 $msg{msgid} = $id; 1011 my $coro; $coro = async {
1012 eval {
1013 $cb->();
1014 };
1015 warn $@ if $@;
1016 };
630 1017
631 $self->send ("ext " . to_json \%msg); 1018 $coro->on_destroy (sub {
632} 1019 delete $self->{_coro}{$coro+0};
1020 });
633 1021
634############################################################################# 1022 $self->{_coro}{$coro+0} = $coro;
635# map scripting support
636 1023
1024 $coro
1025}
1026
1027cf::client->attach (
1028 on_destroy => sub {
1029 my ($ns) = @_;
1030
1031 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
1032 },
1033);
1034
1035=back
1036
1037
1038=head2 SAFE SCRIPTING
1039
1040Functions that provide a safe environment to compile and execute
1041snippets of perl code without them endangering the safety of the server
1042itself. Looping constructs, I/O operators and other built-in functionality
1043is not available in the safe scripting environment, and the number of
1044functions and methods that can be called is greatly reduced.
1045
1046=cut
1047
637our $safe = new Safe "ext"; 1048our $safe = new Safe "safe";
638our $safe_hole = new Safe::Hole; 1049our $safe_hole = new Safe::Hole;
639 1050
640$SIG{FPE} = 'IGNORE'; 1051$SIG{FPE} = 'IGNORE';
641 1052
642$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 1053$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
643 1054
644# here we export the classes and methods available to script code 1055# here we export the classes and methods available to script code
645 1056
1057=pod
1058
1059The following fucntions and emthods are available within a safe environment:
1060
1061 cf::object contr pay_amount pay_player map
1062 cf::object::player player
1063 cf::player peaceful
1064 cf::map trigger
1065
1066=cut
1067
646for ( 1068for (
647 ["cf::object" => qw(contr pay_amount pay_player)], 1069 ["cf::object" => qw(contr pay_amount pay_player map)],
648 ["cf::object::player" => qw(player)], 1070 ["cf::object::player" => qw(player)],
649 ["cf::player" => qw(peaceful)], 1071 ["cf::player" => qw(peaceful)],
1072 ["cf::map" => qw(trigger)],
650) { 1073) {
651 no strict 'refs'; 1074 no strict 'refs';
652 my ($pkg, @funs) = @$_; 1075 my ($pkg, @funs) = @$_;
653 *{"ext::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 1076 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
654 for @funs; 1077 for @funs;
655} 1078}
1079
1080=over 4
1081
1082=item @retval = safe_eval $code, [var => value, ...]
1083
1084Compiled and executes the given perl code snippet. additional var/value
1085pairs result in temporary local (my) scalar variables of the given name
1086that are available in the code snippet. Example:
1087
1088 my $five = safe_eval '$first + $second', first => 1, second => 4;
1089
1090=cut
656 1091
657sub safe_eval($;@) { 1092sub safe_eval($;@) {
658 my ($code, %vars) = @_; 1093 my ($code, %vars) = @_;
659 1094
660 my $qcode = $code; 1095 my $qcode = $code;
661 $qcode =~ s/"/‟/g; # not allowed in #line filenames 1096 $qcode =~ s/"/‟/g; # not allowed in #line filenames
662 $qcode =~ s/\n/\\n/g; 1097 $qcode =~ s/\n/\\n/g;
663 1098
664 local $_; 1099 local $_;
665 local @ext::cf::_safe_eval_args = values %vars; 1100 local @safe::cf::_safe_eval_args = values %vars;
666 1101
667 $code = 1102 my $eval =
668 "do {\n" 1103 "do {\n"
669 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 1104 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
670 . "#line 0 \"{$qcode}\"\n" 1105 . "#line 0 \"{$qcode}\"\n"
671 . $code 1106 . $code
672 . "\n}" 1107 . "\n}"
673 ; 1108 ;
674 1109
675 sub_generation_inc; 1110 sub_generation_inc;
676 my @res = wantarray ? $safe->reval ($code) : scalar $safe->reval ($code); 1111 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
677 sub_generation_inc; 1112 sub_generation_inc;
678 1113
1114 if ($@) {
1115 warn "$@";
1116 warn "while executing safe code '$code'\n";
1117 warn "with arguments " . (join " ", %vars) . "\n";
1118 }
1119
679 wantarray ? @res : $res[0] 1120 wantarray ? @res : $res[0]
680} 1121}
1122
1123=item cf::register_script_function $function => $cb
1124
1125Register a function that can be called from within map/npc scripts. The
1126function should be reasonably secure and should be put into a package name
1127like the extension.
1128
1129Example: register a function that gets called whenever a map script calls
1130C<rent::overview>, as used by the C<rent> extension.
1131
1132 cf::register_script_function "rent::overview" => sub {
1133 ...
1134 };
1135
1136=cut
681 1137
682sub register_script_function { 1138sub register_script_function {
683 my ($fun, $cb) = @_; 1139 my ($fun, $cb) = @_;
684 1140
685 no strict 'refs'; 1141 no strict 'refs';
686 *{"ext::$fun"} = $safe_hole->wrap ($cb); 1142 *{"safe::$fun"} = $safe_hole->wrap ($cb);
1143}
1144
1145=back
1146
1147=cut
1148
1149#############################################################################
1150
1151=head2 EXTENSION DATABASE SUPPORT
1152
1153Crossfire maintains a very simple database for extension use. It can
1154currently store anything that can be serialised using Storable, which
1155excludes objects.
1156
1157The parameter C<$family> should best start with the name of the extension
1158using it, it should be unique.
1159
1160=over 4
1161
1162=item $hashref = cf::db_get $family
1163
1164Return a hashref for use by the extension C<$family>, which can be
1165modified. After modifications, you have to call C<cf::db_dirty> or
1166C<cf::db_sync>.
1167
1168=item $value = cf::db_get $family => $key
1169
1170Returns a single value from the database
1171
1172=item cf::db_put $family => $hashref
1173
1174Stores the given family hashref into the database. Updates are delayed, if
1175you want the data to be synced to disk immediately, use C<cf::db_sync>.
1176
1177=item cf::db_put $family => $key => $value
1178
1179Stores the given C<$value> in the family hash. Updates are delayed, if you
1180want the data to be synced to disk immediately, use C<cf::db_sync>.
1181
1182=item cf::db_dirty
1183
1184Marks the database as dirty, to be updated at a later time.
1185
1186=item cf::db_sync
1187
1188Immediately write the database to disk I<if it is dirty>.
1189
1190=cut
1191
1192our $DB;
1193
1194{
1195 my $path = cf::localdir . "/database.pst";
1196
1197 sub db_load() {
1198 warn "loading database $path\n";#d# remove later
1199 $DB = stat $path ? Storable::retrieve $path : { };
1200 }
1201
1202 my $pid;
1203
1204 sub db_save() {
1205 warn "saving database $path\n";#d# remove later
1206 waitpid $pid, 0 if $pid;
1207 if (0 == ($pid = fork)) {
1208 $DB->{_meta}{version} = 1;
1209 Storable::nstore $DB, "$path~";
1210 rename "$path~", $path;
1211 cf::_exit 0 if defined $pid;
1212 }
1213 }
1214
1215 my $dirty;
1216
1217 sub db_sync() {
1218 db_save if $dirty;
1219 undef $dirty;
1220 }
1221
1222 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1223 db_sync;
1224 });
1225
1226 sub db_dirty() {
1227 $dirty = 1;
1228 $idle->start;
1229 }
1230
1231 sub db_get($;$) {
1232 @_ >= 2
1233 ? $DB->{$_[0]}{$_[1]}
1234 : ($DB->{$_[0]} ||= { })
1235 }
1236
1237 sub db_put($$;$) {
1238 if (@_ >= 3) {
1239 $DB->{$_[0]}{$_[1]} = $_[2];
1240 } else {
1241 $DB->{$_[0]} = $_[1];
1242 }
1243 db_dirty;
1244 }
1245
1246 cf::global->attach (
1247 prio => 10000,
1248 on_cleanup => sub {
1249 db_sync;
1250 },
1251 );
687} 1252}
688 1253
689############################################################################# 1254#############################################################################
690# the server's main() 1255# the server's main()
691 1256
1257sub cfg_load {
1258 open my $fh, "<:utf8", cf::confdir . "/config"
1259 or return;
1260
1261 local $/;
1262 *CFG = YAML::Syck::Load <$fh>;
1263}
1264
692sub main { 1265sub main {
1266 cfg_load;
1267 db_load;
1268 load_extensions;
693 Event::loop; 1269 Event::loop;
694} 1270}
695 1271
696############################################################################# 1272#############################################################################
697# initialisation 1273# initialisation
698 1274
1275sub _perl_reload() {
1276 warn "reloading...";
1277
1278 eval {
1279 local $FREEZE = 1;
1280
1281 cf::emergency_save;
1282
1283 # cancel all watchers
1284 for (Event::all_watchers) {
1285 $_->cancel if $_->data & WF_AUTOCANCEL;
1286 }
1287
1288 # cancel all extension coros
1289 $_->cancel for values %EXT_CORO;
1290 %EXT_CORO = ();
1291
1292 # unload all extensions
1293 for (@exts) {
1294 warn "unloading <$_>";
1295 unload_extension $_;
1296 }
1297
1298 # unload all modules loaded from $LIBDIR
1299 while (my ($k, $v) = each %INC) {
1300 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1301
1302 warn "removing <$k>";
1303 delete $INC{$k};
1304
1305 $k =~ s/\.pm$//;
1306 $k =~ s/\//::/g;
1307
1308 if (my $cb = $k->can ("unload_module")) {
1309 $cb->();
1310 }
1311
1312 Symbol::delete_package $k;
1313 }
1314
1315 # sync database to disk
1316 cf::db_sync;
1317 IO::AIO::flush;
1318
1319 # get rid of safe::, as good as possible
1320 Symbol::delete_package "safe::$_"
1321 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
1322
1323 # remove register_script_function callbacks
1324 # TODO
1325
1326 # unload cf.pm "a bit"
1327 delete $INC{"cf.pm"};
1328
1329 # don't, removes xs symbols, too,
1330 # and global variables created in xs
1331 #Symbol::delete_package __PACKAGE__;
1332
1333 # reload cf.pm
1334 warn "reloading cf.pm";
1335 require cf;
1336 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1337
1338 # load config and database again
1339 cf::cfg_load;
1340 cf::db_load;
1341
1342 # load extensions
1343 warn "load extensions";
1344 cf::load_extensions;
1345
1346 # reattach attachments to objects
1347 warn "reattach";
1348 _global_reattach;
1349 };
1350 warn $@ if $@;
1351
1352 warn "reloaded";
1353};
1354
1355sub perl_reload() {
1356 _perl_reload;
1357}
1358
699register "<global>", __PACKAGE__; 1359register "<global>", __PACKAGE__;
700 1360
1361register_command "perl-reload" => sub {
1362 my ($who, $arg) = @_;
1363
1364 if ($who->flag (FLAG_WIZ)) {
1365 $who->message ("reloading...");
1366 _perl_reload;
1367 }
1368};
1369
701unshift @INC, $LIBDIR; 1370unshift @INC, $LIBDIR;
702 1371
703load_extensions;
704
705$TICK_WATCHER = Event->timer ( 1372$TICK_WATCHER = Event->timer (
1373 reentrant => 0,
706 prio => 1, 1374 prio => 0,
707 at => $NEXT_TICK || 1, 1375 at => $NEXT_TICK || $TICK,
1376 data => WF_AUTOCANCEL,
708 cb => sub { 1377 cb => sub {
1378 unless ($FREEZE) {
709 cf::server_tick; # one server iteration 1379 cf::server_tick; # one server iteration
1380 $RUNTIME += $TICK;
1381 }
710 1382
711 my $NOW = Event::time;
712 $NEXT_TICK += $TICK; 1383 $NEXT_TICK += $TICK;
713 1384
714 # if we are delayed by four ticks, skip them all 1385 # if we are delayed by four ticks or more, skip them all
715 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1386 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
716 1387
717 $TICK_WATCHER->at ($NEXT_TICK); 1388 $TICK_WATCHER->at ($NEXT_TICK);
718 $TICK_WATCHER->start; 1389 $TICK_WATCHER->start;
719 }, 1390 },
720); 1391);
721 1392
1393IO::AIO::max_poll_time $TICK * 0.2;
1394
1395Event->io (fd => IO::AIO::poll_fileno,
1396 poll => 'r',
1397 prio => 5,
1398 data => WF_AUTOCANCEL,
1399 cb => \&IO::AIO::poll_cb);
1400
1401# we must not ever block the main coroutine
1402$Coro::idle = sub {
1403 #Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#
1404 warn "FATAL: Coro::idle was called, major BUG\n";
1405 (Coro::unblock_sub {
1406 Event::one_event;
1407 })->();
1408};
1409
7221 14101
723 1411

Diff Legend

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