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.57 by root, Wed Aug 30 11:21:24 2006 UTC vs.
Revision 1.90 by root, Sat Dec 16 04:22:13 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
16_reload_1; 21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
17 22
18our %COMMAND = (); 23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
27_init_vars;
28
19our @EVENT; 29our @EVENT;
20our %PROP_TYPE; 30our $LIBDIR = datadir . "/ext";
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl";
23 31
24our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 33our $TICK_WATCHER;
26our $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
27 67
28BEGIN { 68BEGIN {
29 *CORE::GLOBAL::warn = sub { 69 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 70 my $msg = join "", @_;
31 $msg .= "\n" 71 $msg .= "\n"
… …
34 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
36 }; 76 };
37} 77}
38 78
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
40
41# generate property mutators
42sub prop_gen {
43 my ($prefix, $class) = @_;
44
45 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 80
75# 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
76# within the Safe compartment. 82# within the Safe compartment.
77for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 83for my $pkg (qw(
84 cf::object cf::object::player
85 cf::client cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
78 no strict 'refs'; 89 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 91}
81 92
82$Event::DIED = sub { 93$Event::DIED = sub {
… …
84}; 95};
85 96
86my %ext_pkg; 97my %ext_pkg;
87my @exts; 98my @exts;
88my @hook; 99my @hook;
89my %command;
90my %extcmd;
91 100
92############################################################################# 101=head2 UTILITY FUNCTIONS
93# utility functions 102
103=over 4
104
105=cut
94 106
95use 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
96 114
97sub from_json($) { 115sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 116 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 117 JSON::Syck::Load $_[0]
100} 118}
101 119
120=item $json = cf::to_json $ref
121
122Converts a perl data structure into its JSON representation.
123
124=cut
125
102sub to_json($) { 126sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 127 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 128 JSON::Syck::Dump $_[0]
105} 129}
106 130
131=back
132
133=cut
134
107############################################################################# 135#############################################################################
108# "new" plug-in system
109 136
110=head3 EVENTS AND OBJECT ATTACHMENTS 137=head2 EVENTS AND OBJECT ATTACHMENTS
111 138
112=over 4 139=over 4
113 140
114=item $object->attach ($attachment, key => $value...) 141=item $object->attach ($attachment, key => $value...)
115 142
… …
389 for (@$callbacks) { 416 for (@$callbacks) {
390 eval { &{$_->[1]} }; 417 eval { &{$_->[1]} };
391 418
392 if ($@) { 419 if ($@) {
393 warn "$@"; 420 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 421 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
395 override; 422 override;
396 } 423 }
397 424
398 return 1 if $override; 425 return 1 if $override;
399 } 426 }
… …
415removed in future versions), and there is no public API to access override 442removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly). 443results (if you must, access C<@cf::invoke_results> directly).
417 444
418=back 445=back
419 446
420=head2 methods valid for all pointers 447=cut
448
449#############################################################################
450
451=head2 METHODS VALID FOR ALL CORE OBJECTS
421 452
422=over 4 453=over 4
423 454
424=item $object->valid 455=item $object->valid, $player->valid, $map->valid
425
426=item $player->valid
427
428=item $map->valid
429 456
430Just because you have a perl object does not mean that the corresponding 457Just because you have a perl object does not mean that the corresponding
431C-level object still exists. If you try to access an object that has no 458C-level object still exists. If you try to access an object that has no
432valid C counterpart anymore you get an exception at runtime. This method 459valid C counterpart anymore you get an exception at runtime. This method
433can be used to test for existence of the C object part without causing an 460can be used to test for existence of the C object part without causing an
… …
476 } 503 }
477 } 504 }
478} 505}
479 506
480sub object_freezer_save { 507sub object_freezer_save {
481 my ($filename, $objs) = @_; 508 my ($filename, $rdata, $objs) = @_;
482 509
483 if (@$objs) { 510 if (length $$rdata) {
511 warn sprintf "saving %s (%d,%d)\n",
512 $filename, length $$rdata, scalar @$objs;
513
484 open my $fh, ">:raw", "$filename.pst~"; 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;
485 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 521 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
486 close $fh; 522 close $fh;
487 unlink "$filename.cfperl";
488 chmod SAVE_MODE, "$filename.pst~";
489 rename "$filename.pst~", "$filename.pst"; 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 }
490 } else { 532 } else {
533 unlink $filename;
491 unlink "$filename.pst"; 534 unlink "$filename.pst";
492 } 535 }
536}
493 537
494 chmod SAVE_MODE, "$filename~"; 538sub object_freezer_as_string {
495 rename "$filename~", $filename; 539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
496} 544}
497 545
498sub object_thawer_load { 546sub object_thawer_load {
499 my ($filename) = @_; 547 my ($filename) = @_;
500 548
549 local $/;
550
551 my $av;
552
553 #TODO: use sysread etc.
554 if (open my $data, "<:raw:perlio", $filename) {
555 $data = <$data>;
501 open my $fh, "<:raw:perlio", "$filename.pst" 556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
502 or return; 557 $av = eval { (Storable::thaw <$pst>)->{objs} };
558 }
559 return ($data, $av);
560 }
503 561
504 eval { local $/; (Storable::thaw <$fh>)->{objs} } 562 ()
505} 563}
506 564
507attach_to_objects 565attach_to_objects
508 prio => -1000000, 566 prio => -1000000,
509 on_clone => sub { 567 on_clone => sub {
… …
517 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
518 }, 576 },
519; 577;
520 578
521############################################################################# 579#############################################################################
522# old plug-in events 580# command handling &c
523 581
524sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
525 my $extension = shift;
526 my $event_code = shift;
527 583
528 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
529 or return; 585$name.
530 586
531 &$cb 587=cut
532}
533
534sub inject_global_event {
535 my $event = shift;
536
537 my $cb = $hook[$event]
538 or return;
539
540 List::Util::max map &$_, values %$cb
541}
542
543sub inject_command {
544 my ($name, $obj, $params) = @_;
545
546 for my $cmd (@{ $command{$name} }) {
547 $cmd->[1]->($obj, $params);
548 }
549
550 -1
551}
552 588
553sub register_command { 589sub register_command {
554 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
555 591
556 my $caller = caller; 592 my $caller = caller;
557 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
558 594
559 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
560 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
561} 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
562 606
563sub register_extcmd { 607sub register_extcmd {
564 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
565 609
566 my $caller = caller; 610 my $caller = caller;
567 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
568 612
569 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
570} 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;
571 647
572sub register { 648sub register {
573 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
574 650
575 #TODO 651 #TODO
… …
594 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
595 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
596 . "\n};\n1"; 672 . "\n};\n1";
597 673
598 eval $source 674 eval $source
599 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
600 677
601 push @exts, $pkg; 678 push @exts, $pkg;
602 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
603 680
604# no strict 'refs'; 681# no strict 'refs';
… …
617# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
618# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
619# } 696# }
620 697
621 # remove commands 698 # remove commands
622 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
623 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
624 701
625 if (@cb) { 702 if (@cb) {
626 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
627 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
628 } else { 704 } else {
629 delete $command{$name};
630 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
631 } 706 }
632 } 707 }
633 708
634 # remove extcmds 709 # remove extcmds
635 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
636 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
637 } 712 }
638 713
639 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
640 eval { 715 eval {
641 $cb->($pkg); 716 $cb->($pkg);
… …
645 720
646 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
647} 722}
648 723
649sub load_extensions { 724sub load_extensions {
650 my $LIBDIR = maps_directory "perl";
651
652 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
653 next unless -r $ext; 726 next unless -r $ext;
654 eval { 727 eval {
655 load_extension $ext; 728 load_extension $ext;
656 1 729 1
657 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
658 } 731 }
659} 732}
660 733
661sub _perl_reload(&) {
662 my ($msg) = @_;
663
664 $msg->("reloading...");
665
666 eval {
667 # 1. cancel all watchers
668 $_->cancel for Event::all_watchers;
669
670 # 2. unload all extensions
671 for (@exts) {
672 $msg->("unloading <$_>");
673 unload_extension $_;
674 }
675
676 # 3. unload all modules loaded from $LIBDIR
677 while (my ($k, $v) = each %INC) {
678 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
679
680 $msg->("removing <$k>");
681 delete $INC{$k};
682
683 $k =~ s/\.pm$//;
684 $k =~ s/\//::/g;
685
686 if (my $cb = $k->can ("unload_module")) {
687 $cb->();
688 }
689
690 Symbol::delete_package $k;
691 }
692
693 # 4. get rid of safe::, as good as possible
694 Symbol::delete_package "safe::$_"
695 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
696
697 # 5. remove register_script_function callbacks
698 # TODO
699
700 # 6. unload cf.pm "a bit"
701 delete $INC{"cf.pm"};
702
703 # don't, removes xs symbols, too,
704 # and global variables created in xs
705 #Symbol::delete_package __PACKAGE__;
706
707 # 7. reload cf.pm
708 $msg->("reloading cf.pm");
709 require cf;
710 };
711 $msg->($@) if $@;
712
713 $msg->("reloaded");
714};
715
716sub perl_reload() {
717 _perl_reload {
718 warn $_[0];
719 print "$_[0]\n";
720 };
721}
722
723register_command "perl-reload", 0, sub {
724 my ($who, $arg) = @_;
725
726 if ($who->flag (FLAG_WIZ)) {
727 _perl_reload {
728 warn $_[0];
729 $who->message ($_[0]);
730 };
731 }
732};
733
734#############################################################################
735# extcmd framework, basically convert ext <msg>
736# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
737
738attach_to_players
739 on_extcmd => sub {
740 my ($pl, $buf) = @_;
741
742 my $msg = eval { from_json $buf };
743
744 if (ref $msg) {
745 if (my $cb = $extcmd{$msg->{msgtype}}) {
746 if (my %reply = $cb->[0]->($pl, $msg)) {
747 $pl->ext_reply ($msg->{msgid}, %reply);
748 }
749 }
750 } else {
751 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
752 }
753
754 cf::override;
755 },
756;
757
758############################################################################# 734#############################################################################
759# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
760 736
761*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
762 my ($map) = @_; 738 my ($map) = @_;
… …
765 defined $path or return; 741 defined $path or return;
766 742
767 unlink "$path.pst"; 743 unlink "$path.pst";
768}; 744};
769 745
770# old style persistent data, TODO: remove #d#
771*cf::mapsupport::on_swapin = sub {
772 my ($map) = @_;
773
774 my $path = $map->tmpname;
775 $path = $map->path unless defined $path;
776
777 open my $fh, "<:raw", "$path.cfperl"
778 or return; # no perl data
779
780 my $data = Storable::thaw do { local $/; <$fh> };
781
782 $data->{version} <= 1
783 or return; # too new
784
785 $map->_set_obs ($data->{obs});
786 $map->invoke (EVENT_MAP_UPGRADE);
787};
788
789attach_to_maps prio => -10000, package => cf::mapsupport::; 746attach_to_maps prio => -10000, package => cf::mapsupport::;
790 747
791############################################################################# 748#############################################################################
792# load/save perl data associated with player->ob objects 749# load/save perl data associated with player->ob objects
793 750
794sub all_objects(@) { 751sub all_objects(@) {
795 @_, map all_objects ($_->inv), @_ 752 @_, map all_objects ($_->inv), @_
796} 753}
797 754
755# TODO: compatibility cruft, remove when no longer needed
798attach_to_players 756attach_to_players
799 on_load => sub { 757 on_load => sub {
800 my ($pl, $path) = @_; 758 my ($pl, $path) = @_;
801 759
802 for my $o (all_objects $pl->ob) { 760 for my $o (all_objects $pl->ob) {
… …
808 } 766 }
809 }, 767 },
810; 768;
811 769
812############################################################################# 770#############################################################################
813# core extensions - in perl 771
772=head2 CORE EXTENSIONS
773
774Functions and methods that extend core crossfire objects.
775
776=over 4
814 777
815=item cf::player::exists $login 778=item cf::player::exists $login
816 779
817Returns true when the given account exists. 780Returns true when the given account exists.
818 781
… …
821sub cf::player::exists($) { 784sub cf::player::exists($) {
822 cf::player::find $_[0] 785 cf::player::find $_[0]
823 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;
824} 787}
825 788
826=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
827 790
828Sends 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>
829can 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
830dialogue with the given NPC character. 793dialogue with the given NPC character.
831 794
… …
858 $msg{msgid} = $id; 821 $msg{msgid} = $id;
859 822
860 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
861} 824}
862 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
863############################################################################# 844#############################################################################
864# 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
865 855
866our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
867our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
868 858
869$SIG{FPE} = 'IGNORE'; 859$SIG{FPE} = 'IGNORE';
870 860
871$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));
872 862
873# 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
874 874
875for ( 875for (
876 ["cf::object" => qw(contr pay_amount pay_player)], 876 ["cf::object" => qw(contr pay_amount pay_player)],
877 ["cf::object::player" => qw(player)], 877 ["cf::object::player" => qw(player)],
878 ["cf::player" => qw(peaceful)], 878 ["cf::player" => qw(peaceful)],
… …
881 my ($pkg, @funs) = @$_; 881 my ($pkg, @funs) = @$_;
882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
883 for @funs; 883 for @funs;
884} 884}
885 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
886sub safe_eval($;@) { 898sub safe_eval($;@) {
887 my ($code, %vars) = @_; 899 my ($code, %vars) = @_;
888 900
889 my $qcode = $code; 901 my $qcode = $code;
890 $qcode =~ s/"/‟/g; # not allowed in #line filenames 902 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
912 } 924 }
913 925
914 wantarray ? @res : $res[0] 926 wantarray ? @res : $res[0]
915} 927}
916 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
917sub register_script_function { 944sub register_script_function {
918 my ($fun, $cb) = @_; 945 my ($fun, $cb) = @_;
919 946
920 no strict 'refs'; 947 no strict 'refs';
921 *{"safe::$fun"} = $safe_hole->wrap ($cb); 948 *{"safe::$fun"} = $safe_hole->wrap ($cb);
922} 949}
923 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
924############################################################################# 1060#############################################################################
925# the server's main() 1061# the server's main()
926 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
927sub main { 1071sub main {
1072 cfg_load;
1073 db_load;
1074 load_extensions;
928 Event::loop; 1075 Event::loop;
929} 1076}
930 1077
931############################################################################# 1078#############################################################################
932# initialisation 1079# initialisation
933 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
934register "<global>", __PACKAGE__; 1160register "<global>", __PACKAGE__;
935 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
936unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
937 1174
938load_extensions;
939
940$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
941 prio => 1, 1176 prio => 0,
942 at => $NEXT_TICK || 1, 1177 at => $NEXT_TICK || 1,
1178 data => WF_AUTOCANCEL,
943 cb => sub { 1179 cb => sub {
944 cf::server_tick; # one server iteration 1180 cf::server_tick; # one server iteration
945 1181
946 my $NOW = Event::time; 1182 my $NOW = Event::time;
947 $NEXT_TICK += $TICK; 1183 $NEXT_TICK += $TICK;
948 1184
949 # if we are delayed by four ticks, skip them all 1185 # if we are delayed by four ticks or more, skip them all
950 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1186 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
951 1187
952 $TICK_WATCHER->at ($NEXT_TICK); 1188 $TICK_WATCHER->at ($NEXT_TICK);
953 $TICK_WATCHER->start; 1189 $TICK_WATCHER->start;
954 }, 1190 },
955); 1191);
956 1192
957_reload_2; 1193IO::AIO::max_poll_time $TICK * 0.2;
1194
1195Event->io (fd => IO::AIO::poll_fileno,
1196 poll => 'r',
1197 prio => 5,
1198 data => WF_AUTOCANCEL,
1199 cb => \&IO::AIO::poll_cb);
958 1200
9591 12011
960 1202

Diff Legend

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