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.45 by root, Sat Aug 26 23:36:32 2006 UTC vs.
Revision 1.88 by root, Fri Dec 15 19:29:18 2006 UTC

5use Storable; 5use Storable;
6use Opcode; 6use Opcode;
7use Safe; 7use Safe;
8use Safe::Hole; 8use Safe::Hole;
9 9
10use IO::AIO ();
11use YAML::Syck ();
10use Time::HiRes; 12use Time::HiRes;
11use Event; 13use Event;
12$Event::Eval = 1; # no idea why this is required, but it is 14$Event::Eval = 1; # no idea why this is required, but it is
13 15
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1;
18
14use strict; 19use strict;
15 20
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
16our %COMMAND = (); 23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
27_init_vars;
28
17our @EVENT; 29our @EVENT;
18our %PROP_TYPE; 30our $LIBDIR = datadir . "/ext";
19our %PROP_IDX;
20our $LIBDIR = maps_directory "perl";
21 31
22our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 33our $TICK_WATCHER;
24our $NEXT_TICK; 34our $NEXT_TICK;
35
36our %CFG;
37
38our $UPTIME; $UPTIME ||= time;
39
40#############################################################################
41
42=head2 GLOBAL VARIABLES
43
44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
49
50=item $cf::LIBDIR
51
52The perl library directory, where extensions and cf-specific modules can
53be found. It will be added to C<@INC> automatically.
54
55=item $cf::TICK
56
57The interval between server ticks, in seconds.
58
59=item %cf::CFG
60
61Configuration for the server, loaded from C</etc/crossfire/config>, or
62from wherever your confdir points to.
63
64=back
65
66=cut
25 67
26BEGIN { 68BEGIN {
27 *CORE::GLOBAL::warn = sub { 69 *CORE::GLOBAL::warn = sub {
28 my $msg = join "", @_; 70 my $msg = join "", @_;
29 $msg .= "\n" 71 $msg .= "\n"
32 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
33 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
34 }; 76 };
35} 77}
36 78
37my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
38
39# generate property mutators
40sub prop_gen {
41 my ($prefix, $class) = @_;
42
43 no strict 'refs';
44
45 for my $prop (keys %PROP_TYPE) {
46 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
47 my $sub = lc $1;
48
49 my $type = $PROP_TYPE{$prop};
50 my $idx = $PROP_IDX {$prop};
51
52 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
53 $_[0]->get_property ($type, $idx)
54 };
55
56 *{"$class\::set_$sub"} = sub {
57 $_[0]->set_property ($type, $idx, $_[1]);
58 } unless $ignore_set{$prop};
59 }
60}
61
62# auto-generate most of the API
63
64prop_gen OBJECT_PROP => "cf::object";
65# CFAPI_OBJECT_ANIMATION?
66prop_gen PLAYER_PROP => "cf::object::player";
67
68prop_gen MAP_PROP => "cf::map";
69prop_gen ARCH_PROP => "cf::arch";
70
71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
72 80
73# we bless all objects into (empty) derived classes to force a method lookup 81# we bless all objects into (empty) derived classes to force a method lookup
74# within the Safe compartment. 82# within the Safe compartment.
75for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch)) { 83for my $pkg (qw(
84 cf::object cf::object::player
85 cf::client_socket cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
76 no strict 'refs'; 89 no strict 'refs';
77 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
78} 91}
79 92
80$Event::DIED = sub { 93$Event::DIED = sub {
82}; 95};
83 96
84my %ext_pkg; 97my %ext_pkg;
85my @exts; 98my @exts;
86my @hook; 99my @hook;
87my %command;
88my %extcmd;
89 100
90############################################################################# 101=head2 UTILITY FUNCTIONS
91# utility functions 102
103=over 4
104
105=cut
92 106
93use JSON::Syck (); # TODO# replace by JSON::PC once working 107use JSON::Syck (); # TODO# replace by JSON::PC once working
108
109=item $ref = cf::from_json $json
110
111Converts a JSON string into the corresponding perl data structure.
112
113=cut
94 114
95sub from_json($) { 115sub from_json($) {
96 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 116 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
97 JSON::Syck::Load $_[0] 117 JSON::Syck::Load $_[0]
98} 118}
99 119
120=item $json = cf::to_json $ref
121
122Converts a perl data structure into its JSON representation.
123
124=cut
125
100sub to_json($) { 126sub to_json($) {
101 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 127 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
102 JSON::Syck::Dump $_[0] 128 JSON::Syck::Dump $_[0]
103} 129}
104 130
131=back
132
133=cut
134
105############################################################################# 135#############################################################################
106# "new" plug-in system
107 136
108=item cf::object::attach ... # NYI 137=head2 EVENTS AND OBJECT ATTACHMENTS
138
139=over 4
140
141=item $object->attach ($attachment, key => $value...)
142
143=item $object->detach ($attachment)
144
145Attach/detach a pre-registered attachment to an object.
146
147=item $player->attach ($attachment, key => $value...)
148
149=item $player->detach ($attachment)
150
151Attach/detach a pre-registered attachment to a player.
152
153=item $map->attach ($attachment, key => $value...)
154
155=item $map->detach ($attachment)
156
157Attach/detach a pre-registered attachment to a map.
158
159=item $bool = $object->attached ($name)
160
161=item $bool = $player->attached ($name)
162
163=item $bool = $map->attached ($name)
164
165Checks wether the named attachment is currently attached to the object.
109 166
110=item cf::attach_global ... 167=item cf::attach_global ...
111 168
169Attach handlers for global events.
170
171This and all following C<attach_*>-functions expect any number of the
172following handler/hook descriptions:
173
174=over 4
175
176=item prio => $number
177
178Set the priority for all following handlers/hooks (unless overwritten
179by another C<prio> setting). Lower priority handlers get executed
180earlier. The default priority is C<0>, and many built-in handlers are
181registered at priority C<-1000>, so lower priorities should not be used
182unless you know what you are doing.
183
184=item on_I<event> => \&cb
185
186Call the given code reference whenever the named event happens (event is
187something like C<instantiate>, C<apply>, C<use_skill> and so on, and which
188handlers are recognised generally depends on the type of object these
189handlers attach to).
190
191See F<include/eventinc.h> for the full list of events supported, and their
192class.
193
194=item package => package::
195
196Look for sub functions of the name C<< on_I<event> >> in the given
197package and register them. Only handlers for eevents supported by the
198object/class are recognised.
199
200=back
201
112=item cf::attach_to_type $object_type, ... 202=item cf::attach_to_type $object_type, $subtype, ...
203
204Attach handlers for a specific object type (e.g. TRANSPORT) and
205subtype. If C<$subtype> is zero or undef, matches all objects of the given
206type.
113 207
114=item cf::attach_to_objects ... 208=item cf::attach_to_objects ...
115 209
210Attach handlers to all objects. Do not use this except for debugging or
211very rare events, as handlers are (obviously) called for I<all> objects in
212the game.
213
116=item cf::attach_to_players ... 214=item cf::attach_to_players ...
117 215
216Attach handlers to all players.
217
118=item cf::attach_to_maps ... 218=item cf::attach_to_maps ...
119 219
220Attach handlers to all maps.
221
120=item cf:register_attachment $name, ... 222=item cf:register_attachment $name, ...
121 223
122 prio => $number, # lower is earlier 224Register an attachment by name through which objects can refer to this
123 on_xxx => \&cb, 225attachment.
124 package => package::, 226
227=item cf:register_player_attachment $name, ...
228
229Register an attachment by name through which players can refer to this
230attachment.
231
232=item cf:register_map_attachment $name, ...
233
234Register an attachment by name through which maps can refer to this
235attachment.
125 236
126=cut 237=cut
127 238
128# the following variables are defined in .xs and must not be re-created 239# the following variables are defined in .xs and must not be re-created
129our @CB_GLOBAL = (); # registry for all global events 240our @CB_GLOBAL = (); # registry for all global events
191 } 302 }
192 303
193 \%undo 304 \%undo
194} 305}
195 306
307sub _attach_attachment {
308 my ($obj, $name, %arg) = @_;
309
310 return if exists $obj->{_attachment}{$name};
311
312 my $res;
313
314 if (my $attach = $attachment{$name}) {
315 my $registry = $obj->registry;
316
317 for (@$attach) {
318 my ($klass, @attach) = @$_;
319 $res = _attach @$registry, $klass, @attach;
320 }
321
322 $obj->{$name} = \%arg;
323 } else {
324 warn "object uses attachment '$name' that is not available, postponing.\n";
325 }
326
327 $obj->{_attachment}{$name} = undef;
328
329 $res->{attachment} = $name;
330 $res
331}
332
196sub cf::object::attach { 333*cf::object::attach =
197 die; 334*cf::player::attach =
198} 335*cf::map::attach = sub {
336 my ($obj, $name, %arg) = @_;
337
338 _attach_attachment $obj, $name, %arg;
339};
340
341# all those should be optimised
342*cf::object::detach =
343*cf::player::detach =
344*cf::map::detach = sub {
345 my ($obj, $name) = @_;
346
347 delete $obj->{_attachment}{$name};
348 reattach ($obj);
349};
350
351*cf::object::attached =
352*cf::player::attached =
353*cf::map::attached = sub {
354 my ($obj, $name) = @_;
355
356 exists $obj->{_attachment}{$name}
357};
199 358
200sub attach_global { 359sub attach_global {
201 _attach @CB_GLOBAL, KLASS_GLOBAL, @_ 360 _attach @CB_GLOBAL, KLASS_GLOBAL, @_
202} 361}
203 362
204sub attach_to_type { 363sub attach_to_type {
205 my $type = shift; 364 my $type = shift;
365 my $subtype = shift;
206 366
207 _attach @{$CB_TYPE[$type]}, KLASS_OBJECT, @_ 367 _attach @{$CB_TYPE[$type + $subtype * NUM_SUBTYPES]}, KLASS_OBJECT, @_
208} 368}
209 369
210sub attach_to_objects { 370sub attach_to_objects {
211 _attach @CB_OBJECT, KLASS_OBJECT, @_ 371 _attach @CB_OBJECT, KLASS_OBJECT, @_
212} 372}
220} 380}
221 381
222sub register_attachment { 382sub register_attachment {
223 my $name = shift; 383 my $name = shift;
224 384
385 $attachment{$name} = [[KLASS_OBJECT, @_]];
386}
387
388sub register_player_attachment {
389 my $name = shift;
390
391 $attachment{$name} = [[KLASS_PLAYER, @_]];
392}
393
394sub register_map_attachment {
395 my $name = shift;
396
225 $attachment{$name} = [@_]; 397 $attachment{$name} = [[KLASS_MAP, @_]];
226} 398}
227 399
228our $override; 400our $override;
229our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 401our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
230 402
244 for (@$callbacks) { 416 for (@$callbacks) {
245 eval { &{$_->[1]} }; 417 eval { &{$_->[1]} };
246 418
247 if ($@) { 419 if ($@) {
248 warn "$@"; 420 warn "$@";
249 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 421 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
250 override; 422 override;
251 } 423 }
252 424
253 return 1 if $override; 425 return 1 if $override;
254 } 426 }
255 427
256 0 428 0
257} 429}
430
431=item $bool = cf::invoke EVENT_GLOBAL_XXX, ...
432
433=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
434
435=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
436
437=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
438
439Generate a global/object/player/map-specific event with the given arguments.
440
441This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
442removed in future versions), and there is no public API to access override
443results (if you must, access C<@cf::invoke_results> directly).
444
445=back
446
447=cut
448
449#############################################################################
450
451=head2 METHODS VALID FOR ALL CORE OBJECTS
452
453=over 4
454
455=item $object->valid, $player->valid, $map->valid
456
457Just because you have a perl object does not mean that the corresponding
458C-level object still exists. If you try to access an object that has no
459valid C counterpart anymore you get an exception at runtime. This method
460can be used to test for existence of the C object part without causing an
461exception.
462
463=back
464
465=cut
466
467*cf::object::valid =
468*cf::player::valid =
469*cf::map::valid = \&cf::_valid;
258 470
259############################################################################# 471#############################################################################
260# object support 472# object support
261 473
262sub instantiate { 474sub instantiate {
263 my ($obj, $data) = @_; 475 my ($obj, $data) = @_;
264 my $registry = $obj->registry;
265 476
266 $data = from_json $data; 477 $data = from_json $data;
267 478
268 for (@$data) { 479 for (@$data) {
269 my ($pri, $name, @args) = @$_; 480 my ($name, $args) = @$_;
270 481
271 if (my $attach = $attachment{$name}) { 482 $obj->attach ($name, %{$args || {} });
272 _attach @$registry, KLASS_OBJECT, @$attach;
273
274 if (my $cb = delete $registry->[EVENT_OBJECT_INSTANTIATE]) {
275 for (@$cb) {
276 eval { $_->[1]->($obj, @args); };
277 if ($@) {
278 warn "$@";
279 warn "... while processing '$name' instantiate with args <@args>\n";
280 }
281 }
282 }
283 } else {
284 warn "object uses attachment $name that is not available, postponing.\n";
285 }
286
287 push @{$obj->{_attachment}}, $name;
288 } 483 }
289} 484}
290 485
291# basically do the same as instantiate, without calling instantiate 486# basically do the same as instantiate, without calling instantiate
292sub reattach { 487sub reattach {
293 my ($obj) = @_; 488 my ($obj) = @_;
294 my $registry = $obj->registry; 489 my $registry = $obj->registry;
295 490
296 warn "reattach<@_, $_>\n"; 491 @$registry = ();
492
493 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
494
495 for my $name (keys %{ $obj->{_attachment} || {} }) {
496 if (my $attach = $attachment{$name}) {
497 for (@$attach) {
498 my ($klass, @attach) = @$_;
499 _attach @$registry, $klass, @attach;
500 }
501 } else {
502 warn "object uses attachment '$name' that is not available, postponing.\n";
503 }
504 }
505}
506
507sub object_freezer_save {
508 my ($filename, $rdata, $objs) = @_;
509
510 if (length $$rdata) {
511 warn sprintf "saving %s (%d,%d)\n",
512 $filename, length $$rdata, scalar @$objs;
513
514 if (open my $fh, ">:raw", "$filename~") {
515 chmod SAVE_MODE, $fh;
516 syswrite $fh, $$rdata;
517 close $fh;
518
519 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
520 chmod SAVE_MODE, $fh;
521 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
522 close $fh;
523 rename "$filename.pst~", "$filename.pst";
524 } else {
525 unlink "$filename.pst";
526 }
527
528 rename "$filename~", $filename;
529 } else {
530 warn "FATAL: $filename~: $!\n";
531 }
532 } else {
533 unlink $filename;
534 unlink "$filename.pst";
535 }
536}
537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
546sub object_thawer_load {
547 my ($filename) = @_;
548
549 local $/;
550
551 my $av;
552
553 #TODO: use sysread etc.
554 if (open my $data, "<:raw:perlio", $filename) {
555 $data = <$data>;
556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
557 $av = eval { (Storable::thaw <$pst>)->{objs} };
558 }
559 return ($data, $av);
560 }
561
562 ()
297} 563}
298 564
299attach_to_objects 565attach_to_objects
300 prio => -1000000, 566 prio => -1000000,
301 on_clone => sub { 567 on_clone => sub {
302 my ($src, $dst) = @_; 568 my ($src, $dst) = @_;
303 569
304 @{$dst->registry} = @{$src->registry}; 570 @{$dst->registry} = @{$src->registry};
305 warn "registry clone ", join ":", @{$src->registry};#d#
306 571
307 %$dst = %$src; 572 %$dst = %$src;
308 573
309 $dst->{_attachment} = [@{ $src->{_attachment} }] 574 %{$dst->{_attachment}} = %{$src->{_attachment}}
310 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
311
312 warn "clone<@_>\n";#d#
313 }, 576 },
314; 577;
315 578
316############################################################################# 579#############################################################################
317# old plug-in events 580# command handling &c
318 581
319sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
320 my $extension = shift;
321 my $event_code = shift;
322 583
323 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
324 or return; 585$name.
325 586
326 &$cb 587=cut
327}
328
329sub inject_global_event {
330 my $event = shift;
331
332 my $cb = $hook[$event]
333 or return;
334
335 List::Util::max map &$_, values %$cb
336}
337
338sub inject_command {
339 my ($name, $obj, $params) = @_;
340
341 for my $cmd (@{ $command{$name} }) {
342 $cmd->[1]->($obj, $params);
343 }
344
345 -1
346}
347 588
348sub register_command { 589sub register_command {
349 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
350 591
351 my $caller = caller; 592 my $caller = caller;
352 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
353 594
354 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
355 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
356} 596}
597
598=item cf::register_extcmd $name => \&callback($pl,$packet);
599
600Register a callbackf ro execution when the client sends an extcmd packet.
601
602If the callback returns something, it is sent back as if reply was being
603called.
604
605=cut
357 606
358sub register_extcmd { 607sub register_extcmd {
359 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
360 609
361 my $caller = caller; 610 my $caller = caller;
362 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
363 612
364 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
365} 614}
615
616attach_to_players
617 on_command => sub {
618 my ($pl, $name, $params) = @_;
619
620 my $cb = $COMMAND{$name}
621 or return;
622
623 for my $cmd (@$cb) {
624 $cmd->[1]->($pl->ob, $params);
625 }
626
627 cf::override;
628 },
629 on_extcmd => sub {
630 my ($pl, $buf) = @_;
631
632 my $msg = eval { from_json $buf };
633
634 if (ref $msg) {
635 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
636 if (my %reply = $cb->[0]->($pl, $msg)) {
637 $pl->ext_reply ($msg->{msgid}, %reply);
638 }
639 }
640 } else {
641 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
642 }
643
644 cf::override;
645 },
646;
366 647
367sub register { 648sub register {
368 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
369 650
370 #TODO 651 #TODO
389 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
390 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
391 . "\n};\n1"; 672 . "\n};\n1";
392 673
393 eval $source 674 eval $source
394 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
395 677
396 push @exts, $pkg; 678 push @exts, $pkg;
397 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
398 680
399# no strict 'refs'; 681# no strict 'refs';
412# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
413# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
414# } 696# }
415 697
416 # remove commands 698 # remove commands
417 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
418 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
419 701
420 if (@cb) { 702 if (@cb) {
421 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
422 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
423 } else { 704 } else {
424 delete $command{$name};
425 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
426 } 706 }
427 } 707 }
428 708
429 # remove extcmds 709 # remove extcmds
430 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
431 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
432 } 712 }
433 713
434 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
435 eval { 715 eval {
436 $cb->($pkg); 716 $cb->($pkg);
440 720
441 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
442} 722}
443 723
444sub load_extensions { 724sub load_extensions {
445 my $LIBDIR = maps_directory "perl";
446
447 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
448 next unless -r $ext; 726 next unless -r $ext;
449 eval { 727 eval {
450 load_extension $ext; 728 load_extension $ext;
451 1 729 1
452 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
453 } 731 }
454} 732}
455 733
456sub _perl_reload(&) {
457 my ($msg) = @_;
458
459 $msg->("reloading...");
460
461 eval {
462 # 1. cancel all watchers
463 $_->cancel for Event::all_watchers;
464
465 # 2. unload all extensions
466 for (@exts) {
467 $msg->("unloading <$_>");
468 unload_extension $_;
469 }
470
471 # 3. unload all modules loaded from $LIBDIR
472 while (my ($k, $v) = each %INC) {
473 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
474
475 $msg->("removing <$k>");
476 delete $INC{$k};
477
478 $k =~ s/\.pm$//;
479 $k =~ s/\//::/g;
480
481 if (my $cb = $k->can ("unload_module")) {
482 $cb->();
483 }
484
485 Symbol::delete_package $k;
486 }
487
488 # 4. get rid of safe::, as good as possible
489 Symbol::delete_package "safe::$_"
490 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
491
492 # 5. remove register_script_function callbacks
493 # TODO
494
495 # 6. unload cf.pm "a bit"
496 delete $INC{"cf.pm"};
497
498 # don't, removes xs symbols, too,
499 # and global variables created in xs
500 #Symbol::delete_package __PACKAGE__;
501
502 # 7. reload cf.pm
503 $msg->("reloading cf.pm");
504 require cf;
505 };
506 $msg->($@) if $@;
507
508 $msg->("reloaded");
509};
510
511sub perl_reload() {
512 _perl_reload {
513 warn $_[0];
514 print "$_[0]\n";
515 };
516}
517
518register_command "perl-reload", 0, sub {
519 my ($who, $arg) = @_;
520
521 if ($who->flag (FLAG_WIZ)) {
522 _perl_reload {
523 warn $_[0];
524 $who->message ($_[0]);
525 };
526 }
527};
528
529#############################################################################
530# extcmd framework, basically convert ext <msg>
531# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
532
533attach_to_players
534 on_extcmd => sub {
535 my ($pl, $buf) = @_;
536
537 my $msg = eval { from_json $buf };
538
539 if (ref $msg) {
540 if (my $cb = $extcmd{$msg->{msgtype}}) {
541 if (my %reply = $cb->[0]->($pl, $msg)) {
542 $pl->ext_reply ($msg->{msgid}, %reply);
543 }
544 }
545 } else {
546 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
547 }
548
549 cf::override;
550 },
551;
552
553############################################################################# 734#############################################################################
554# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
555 736
556*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
557 my ($map) = @_; 738 my ($map) = @_;
558 739
559 my $path = $map->tmpname; 740 my $path = $map->tmpname;
560 defined $path or return; 741 defined $path or return;
561 742
562 unlink "$path.cfperl"; 743 unlink "$path.pst";
563};
564
565*cf::mapsupport::on_swapin =
566*cf::mapsupport::on_load = sub {
567 my ($map) = @_;
568
569 my $path = $map->tmpname;
570 $path = $map->path unless defined $path;
571
572 open my $fh, "<:raw", "$path.cfperl"
573 or return; # no perl data
574
575 my $data = Storable::thaw do { local $/; <$fh> };
576
577 $data->{version} <= 1
578 or return; # too new
579
580 $map->_set_obs ($data->{obs});
581};
582
583*cf::mapsupport::on_swapout = sub {
584 my ($map) = @_;
585
586 my $path = $map->tmpname;
587 $path = $map->path unless defined $path;
588
589 my $obs = $map->_get_obs;
590
591 if (defined $obs) {
592 open my $fh, ">:raw", "$path.cfperl"
593 or die "$path.cfperl: $!";
594
595 stat $path;
596
597 print $fh Storable::nfreeze {
598 size => (stat _)[7],
599 time => (stat _)[9],
600 version => 1,
601 obs => $obs,
602 };
603
604 chmod SAVE_MODE, "$path.cfperl"; # very racy, but cf-compatible *g*
605 } else {
606 unlink "$path.cfperl";
607 }
608}; 744};
609 745
610attach_to_maps prio => -10000, package => cf::mapsupport::; 746attach_to_maps prio => -10000, package => cf::mapsupport::;
611 747
612############################################################################# 748#############################################################################
614 750
615sub all_objects(@) { 751sub all_objects(@) {
616 @_, map all_objects ($_->inv), @_ 752 @_, map all_objects ($_->inv), @_
617} 753}
618 754
755# TODO: compatibility cruft, remove when no longer needed
619attach_to_players 756attach_to_players
620 on_load => sub { 757 on_load => sub {
621 my ($pl, $path) = @_; 758 my ($pl, $path) = @_;
622 759
623 for my $o (all_objects $pl->ob) { 760 for my $o (all_objects $pl->ob) {
626 763
627 %$o = %{ Storable::thaw pack "H*", $value }; 764 %$o = %{ Storable::thaw pack "H*", $value };
628 } 765 }
629 } 766 }
630 }, 767 },
631 on_save => sub {
632 my ($pl, $path) = @_;
633
634 $_->set_ob_key_value (_perl_data => unpack "H*", Storable::nfreeze $_)
635 for grep %$_, all_objects $pl->ob;
636 },
637; 768;
638 769
639############################################################################# 770#############################################################################
640# core extensions - in perl 771
772=head2 CORE EXTENSIONS
773
774Functions and methods that extend core crossfire objects.
775
776=over 4
641 777
642=item cf::player::exists $login 778=item cf::player::exists $login
643 779
644Returns true when the given account exists. 780Returns true when the given account exists.
645 781
648sub cf::player::exists($) { 784sub cf::player::exists($) {
649 cf::player::find $_[0] 785 cf::player::find $_[0]
650 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 786 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
651} 787}
652 788
653=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
654 790
655Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 791Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
656can be C<undef>. Does the right thing when the player is currently in a 792can be C<undef>. Does the right thing when the player is currently in a
657dialogue with the given NPC character. 793dialogue with the given NPC character.
658 794
685 $msg{msgid} = $id; 821 $msg{msgid} = $id;
686 822
687 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
688} 824}
689 825
826=item $player_object->may ("access")
827
828Returns wether the given player is authorized to access resource "access"
829(e.g. "command_wizcast").
830
831=cut
832
833sub cf::object::player::may {
834 my ($self, $access) = @_;
835
836 $self->flag (cf::FLAG_WIZ) ||
837 (ref $cf::CFG{"may_$access"}
838 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
839 : $cf::CFG{"may_$access"})
840}
841
842=cut
843
690############################################################################# 844#############################################################################
691# map scripting support 845
846=head2 SAFE SCRIPTING
847
848Functions that provide a safe environment to compile and execute
849snippets of perl code without them endangering the safety of the server
850itself. Looping constructs, I/O operators and other built-in functionality
851is not available in the safe scripting environment, and the number of
852functions and methods that can be called is greatly reduced.
853
854=cut
692 855
693our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
694our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
695 858
696$SIG{FPE} = 'IGNORE'; 859$SIG{FPE} = 'IGNORE';
697 860
698$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 861$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
699 862
700# here we export the classes and methods available to script code 863# here we export the classes and methods available to script code
864
865=pod
866
867The following fucntions and emthods are available within a safe environment:
868
869 cf::object contr pay_amount pay_player
870 cf::object::player player
871 cf::player peaceful
872
873=cut
701 874
702for ( 875for (
703 ["cf::object" => qw(contr pay_amount pay_player)], 876 ["cf::object" => qw(contr pay_amount pay_player)],
704 ["cf::object::player" => qw(player)], 877 ["cf::object::player" => qw(player)],
705 ["cf::player" => qw(peaceful)], 878 ["cf::player" => qw(peaceful)],
708 my ($pkg, @funs) = @$_; 881 my ($pkg, @funs) = @$_;
709 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
710 for @funs; 883 for @funs;
711} 884}
712 885
886=over 4
887
888=item @retval = safe_eval $code, [var => value, ...]
889
890Compiled and executes the given perl code snippet. additional var/value
891pairs result in temporary local (my) scalar variables of the given name
892that are available in the code snippet. Example:
893
894 my $five = safe_eval '$first + $second', first => 1, second => 4;
895
896=cut
897
713sub safe_eval($;@) { 898sub safe_eval($;@) {
714 my ($code, %vars) = @_; 899 my ($code, %vars) = @_;
715 900
716 my $qcode = $code; 901 my $qcode = $code;
717 $qcode =~ s/"/‟/g; # not allowed in #line filenames 902 $qcode =~ s/"/‟/g; # not allowed in #line filenames
739 } 924 }
740 925
741 wantarray ? @res : $res[0] 926 wantarray ? @res : $res[0]
742} 927}
743 928
929=item cf::register_script_function $function => $cb
930
931Register a function that can be called from within map/npc scripts. The
932function should be reasonably secure and should be put into a package name
933like the extension.
934
935Example: register a function that gets called whenever a map script calls
936C<rent::overview>, as used by the C<rent> extension.
937
938 cf::register_script_function "rent::overview" => sub {
939 ...
940 };
941
942=cut
943
744sub register_script_function { 944sub register_script_function {
745 my ($fun, $cb) = @_; 945 my ($fun, $cb) = @_;
746 946
747 no strict 'refs'; 947 no strict 'refs';
748 *{"safe::$fun"} = $safe_hole->wrap ($cb); 948 *{"safe::$fun"} = $safe_hole->wrap ($cb);
749} 949}
750 950
951=back
952
953=cut
954
955#############################################################################
956
957=head2 EXTENSION DATABASE SUPPORT
958
959Crossfire maintains a very simple database for extension use. It can
960currently store anything that can be serialised using Storable, which
961excludes objects.
962
963The parameter C<$family> should best start with the name of the extension
964using it, it should be unique.
965
966=over 4
967
968=item $hashref = cf::db_get $family
969
970Return a hashref for use by the extension C<$family>, which can be
971modified. After modifications, you have to call C<cf::db_dirty> or
972C<cf::db_sync>.
973
974=item $value = cf::db_get $family => $key
975
976Returns a single value from the database
977
978=item cf::db_put $family => $hashref
979
980Stores the given family hashref into the database. Updates are delayed, if
981you want the data to be synced to disk immediately, use C<cf::db_sync>.
982
983=item cf::db_put $family => $key => $value
984
985Stores the given C<$value> in the family hash. Updates are delayed, if you
986want the data to be synced to disk immediately, use C<cf::db_sync>.
987
988=item cf::db_dirty
989
990Marks the database as dirty, to be updated at a later time.
991
992=item cf::db_sync
993
994Immediately write the database to disk I<if it is dirty>.
995
996=cut
997
998our $DB;
999
1000{
1001 my $path = cf::localdir . "/database.pst";
1002
1003 sub db_load() {
1004 warn "loading database $path\n";#d# remove later
1005 $DB = stat $path ? Storable::retrieve $path : { };
1006 }
1007
1008 my $pid;
1009
1010 sub db_save() {
1011 warn "saving database $path\n";#d# remove later
1012 waitpid $pid, 0 if $pid;
1013 if (0 == ($pid = fork)) {
1014 $DB->{_meta}{version} = 1;
1015 Storable::nstore $DB, "$path~";
1016 rename "$path~", $path;
1017 cf::_exit 0 if defined $pid;
1018 }
1019 }
1020
1021 my $dirty;
1022
1023 sub db_sync() {
1024 db_save if $dirty;
1025 undef $dirty;
1026 }
1027
1028 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1029 db_sync;
1030 });
1031
1032 sub db_dirty() {
1033 $dirty = 1;
1034 $idle->start;
1035 }
1036
1037 sub db_get($;$) {
1038 @_ >= 2
1039 ? $DB->{$_[0]}{$_[1]}
1040 : ($DB->{$_[0]} ||= { })
1041 }
1042
1043 sub db_put($$;$) {
1044 if (@_ >= 3) {
1045 $DB->{$_[0]}{$_[1]} = $_[2];
1046 } else {
1047 $DB->{$_[0]} = $_[1];
1048 }
1049 db_dirty;
1050 }
1051
1052 attach_global
1053 prio => 10000,
1054 on_cleanup => sub {
1055 db_sync;
1056 },
1057 ;
1058}
1059
751############################################################################# 1060#############################################################################
752# the server's main() 1061# the server's main()
753 1062
1063sub cfg_load {
1064 open my $fh, "<:utf8", cf::confdir . "/config"
1065 or return;
1066
1067 local $/;
1068 *CFG = YAML::Syck::Load <$fh>;
1069}
1070
754sub main { 1071sub main {
1072 cfg_load;
1073 db_load;
1074 load_extensions;
755 Event::loop; 1075 Event::loop;
756} 1076}
757 1077
758############################################################################# 1078#############################################################################
759# initialisation 1079# initialisation
760 1080
1081sub _perl_reload(&) {
1082 my ($msg) = @_;
1083
1084 $msg->("reloading...");
1085
1086 eval {
1087 # cancel all watchers
1088 for (Event::all_watchers) {
1089 $_->cancel if $_->data & WF_AUTOCANCEL;
1090 }
1091
1092 # unload all extensions
1093 for (@exts) {
1094 $msg->("unloading <$_>");
1095 unload_extension $_;
1096 }
1097
1098 # unload all modules loaded from $LIBDIR
1099 while (my ($k, $v) = each %INC) {
1100 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1101
1102 $msg->("removing <$k>");
1103 delete $INC{$k};
1104
1105 $k =~ s/\.pm$//;
1106 $k =~ s/\//::/g;
1107
1108 if (my $cb = $k->can ("unload_module")) {
1109 $cb->();
1110 }
1111
1112 Symbol::delete_package $k;
1113 }
1114
1115 # sync database to disk
1116 cf::db_sync;
1117
1118 # get rid of safe::, as good as possible
1119 Symbol::delete_package "safe::$_"
1120 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1121
1122 # remove register_script_function callbacks
1123 # TODO
1124
1125 # unload cf.pm "a bit"
1126 delete $INC{"cf.pm"};
1127
1128 # don't, removes xs symbols, too,
1129 # and global variables created in xs
1130 #Symbol::delete_package __PACKAGE__;
1131
1132 # reload cf.pm
1133 $msg->("reloading cf.pm");
1134 require cf;
1135
1136 # load config and database again
1137 cf::cfg_load;
1138 cf::db_load;
1139
1140 # load extensions
1141 $msg->("load extensions");
1142 cf::load_extensions;
1143
1144 # reattach attachments to objects
1145 $msg->("reattach");
1146 _global_reattach;
1147 };
1148 $msg->($@) if $@;
1149
1150 $msg->("reloaded");
1151};
1152
1153sub perl_reload() {
1154 _perl_reload {
1155 warn $_[0];
1156 print "$_[0]\n";
1157 };
1158}
1159
761register "<global>", __PACKAGE__; 1160register "<global>", __PACKAGE__;
762 1161
1162register_command "perl-reload" => sub {
1163 my ($who, $arg) = @_;
1164
1165 if ($who->flag (FLAG_WIZ)) {
1166 _perl_reload {
1167 warn $_[0];
1168 $who->message ($_[0]);
1169 };
1170 }
1171};
1172
763unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
764 1174
765load_extensions;
766
767$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
768 prio => 1, 1176 prio => 1,
1177 async => 1,
769 at => $NEXT_TICK || 1, 1178 at => $NEXT_TICK || 1,
1179 data => WF_AUTOCANCEL,
770 cb => sub { 1180 cb => sub {
771 cf::server_tick; # one server iteration 1181 cf::server_tick; # one server iteration
772 1182
773 my $NOW = Event::time; 1183 my $NOW = Event::time;
774 $NEXT_TICK += $TICK; 1184 $NEXT_TICK += $TICK;
775 1185
776 # if we are delayed by four ticks, skip them all 1186 # if we are delayed by four ticks or more, skip them all
777 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1187 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
778 1188
779 $TICK_WATCHER->at ($NEXT_TICK); 1189 $TICK_WATCHER->at ($NEXT_TICK);
780 $TICK_WATCHER->start; 1190 $TICK_WATCHER->start;
781 }, 1191 },
782); 1192);
783 1193
1194IO::AIO::max_poll_time $TICK * 0.2;
1195
1196Event->io (fd => IO::AIO::poll_fileno,
1197 poll => 'r',
1198 prio => 5,
1199 data => WF_AUTOCANCEL,
1200 cb => \&IO::AIO::poll_cb);
1201
7841 12021
785 1203

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines