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

Diff Legend

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