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.61 by root, Sun Sep 3 22:45:56 2006 UTC vs.
Revision 1.91 by elmex, Sun Dec 17 22:03:44 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
… …
506 unlink $filename; 533 unlink $filename;
507 unlink "$filename.pst"; 534 unlink "$filename.pst";
508 } 535 }
509} 536}
510 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
511sub object_thawer_load { 546sub object_thawer_load {
512 my ($filename) = @_; 547 my ($filename) = @_;
513 548
514 local $/; 549 local $/;
515 550
… …
540 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
541 }, 576 },
542; 577;
543 578
544############################################################################# 579#############################################################################
545# old plug-in events 580# command handling &c
546 581
547sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
548 my $extension = shift;
549 my $event_code = shift;
550 583
551 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
552 or return; 585$name.
553 586
554 &$cb 587=cut
555}
556
557sub inject_global_event {
558 my $event = shift;
559
560 my $cb = $hook[$event]
561 or return;
562
563 List::Util::max map &$_, values %$cb
564}
565
566sub inject_command {
567 my ($name, $obj, $params) = @_;
568
569 for my $cmd (@{ $command{$name} }) {
570 $cmd->[1]->($obj, $params);
571 }
572
573 -1
574}
575 588
576sub register_command { 589sub register_command {
577 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
578 591
579 my $caller = caller; 592 my $caller = caller;
580 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
581 594
582 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
583 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
584} 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
585 606
586sub register_extcmd { 607sub register_extcmd {
587 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
588 609
589 my $caller = caller; 610 my $caller = caller;
590 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
591 612
592 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
593} 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;
594 647
595sub register { 648sub register {
596 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
597 650
598 #TODO 651 #TODO
… …
617 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
618 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
619 . "\n};\n1"; 672 . "\n};\n1";
620 673
621 eval $source 674 eval $source
622 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
623 677
624 push @exts, $pkg; 678 push @exts, $pkg;
625 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
626 680
627# no strict 'refs'; 681# no strict 'refs';
… …
640# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
641# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
642# } 696# }
643 697
644 # remove commands 698 # remove commands
645 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
646 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
647 701
648 if (@cb) { 702 if (@cb) {
649 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
650 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
651 } else { 704 } else {
652 delete $command{$name};
653 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
654 } 706 }
655 } 707 }
656 708
657 # remove extcmds 709 # remove extcmds
658 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
659 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
660 } 712 }
661 713
662 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
663 eval { 715 eval {
664 $cb->($pkg); 716 $cb->($pkg);
… …
668 720
669 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
670} 722}
671 723
672sub load_extensions { 724sub load_extensions {
673 my $LIBDIR = maps_directory "perl";
674
675 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
676 next unless -r $ext; 726 next unless -r $ext;
677 eval { 727 eval {
678 load_extension $ext; 728 load_extension $ext;
679 1 729 1
680 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
681 } 731 }
682} 732}
683 733
684sub _perl_reload(&) {
685 my ($msg) = @_;
686
687 $msg->("reloading...");
688
689 eval {
690 # 1. cancel all watchers
691 $_->cancel for Event::all_watchers;
692
693 # 2. unload all extensions
694 for (@exts) {
695 $msg->("unloading <$_>");
696 unload_extension $_;
697 }
698
699 # 3. unload all modules loaded from $LIBDIR
700 while (my ($k, $v) = each %INC) {
701 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
702
703 $msg->("removing <$k>");
704 delete $INC{$k};
705
706 $k =~ s/\.pm$//;
707 $k =~ s/\//::/g;
708
709 if (my $cb = $k->can ("unload_module")) {
710 $cb->();
711 }
712
713 Symbol::delete_package $k;
714 }
715
716 # 4. get rid of safe::, as good as possible
717 Symbol::delete_package "safe::$_"
718 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
719
720 # 5. remove register_script_function callbacks
721 # TODO
722
723 # 6. unload cf.pm "a bit"
724 delete $INC{"cf.pm"};
725
726 # don't, removes xs symbols, too,
727 # and global variables created in xs
728 #Symbol::delete_package __PACKAGE__;
729
730 # 7. reload cf.pm
731 $msg->("reloading cf.pm");
732 require cf;
733
734 $msg->("load extensions");
735 cf::load_extensions;
736 };
737 $msg->($@) if $@;
738
739 $msg->("reloaded");
740};
741
742sub perl_reload() {
743 _perl_reload {
744 warn $_[0];
745 print "$_[0]\n";
746 };
747}
748
749register_command "perl-reload", 0, sub {
750 my ($who, $arg) = @_;
751
752 if ($who->flag (FLAG_WIZ)) {
753 _perl_reload {
754 warn $_[0];
755 $who->message ($_[0]);
756 };
757 }
758};
759
760#############################################################################
761# extcmd framework, basically convert ext <msg>
762# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
763
764attach_to_players
765 on_extcmd => sub {
766 my ($pl, $buf) = @_;
767
768 my $msg = eval { from_json $buf };
769
770 if (ref $msg) {
771 if (my $cb = $extcmd{$msg->{msgtype}}) {
772 if (my %reply = $cb->[0]->($pl, $msg)) {
773 $pl->ext_reply ($msg->{msgid}, %reply);
774 }
775 }
776 } else {
777 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
778 }
779
780 cf::override;
781 },
782;
783
784############################################################################# 734#############################################################################
785# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
786 736
787*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
788 my ($map) = @_; 738 my ($map) = @_;
… …
816 } 766 }
817 }, 767 },
818; 768;
819 769
820############################################################################# 770#############################################################################
821# core extensions - in perl 771
772=head2 CORE EXTENSIONS
773
774Functions and methods that extend core crossfire objects.
775
776=over 4
822 777
823=item cf::player::exists $login 778=item cf::player::exists $login
824 779
825Returns true when the given account exists. 780Returns true when the given account exists.
826 781
… …
829sub cf::player::exists($) { 784sub cf::player::exists($) {
830 cf::player::find $_[0] 785 cf::player::find $_[0]
831 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;
832} 787}
833 788
834=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
835 790
836Sends 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>
837can 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
838dialogue with the given NPC character. 793dialogue with the given NPC character.
839 794
… …
866 $msg{msgid} = $id; 821 $msg{msgid} = $id;
867 822
868 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
869} 824}
870 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
871############################################################################# 844#############################################################################
872# 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
873 855
874our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
875our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
876 858
877$SIG{FPE} = 'IGNORE'; 859$SIG{FPE} = 'IGNORE';
878 860
879$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));
880 862
881# here we export the classes and methods available to script code 863# here we export the classes and methods available to script code
882 864
865=pod
866
867The following fucntions and emthods are available within a safe environment:
868
869 cf::object contr pay_amount pay_player map
870 cf::object::player player
871 cf::player peaceful
872 cf::map trigger
873
874=cut
875
883for ( 876for (
884 ["cf::object" => qw(contr pay_amount pay_player)], 877 ["cf::object" => qw(contr pay_amount pay_player map)],
885 ["cf::object::player" => qw(player)], 878 ["cf::object::player" => qw(player)],
886 ["cf::player" => qw(peaceful)], 879 ["cf::player" => qw(peaceful)],
880 ["cf::map" => qw(trigger)],
887) { 881) {
888 no strict 'refs'; 882 no strict 'refs';
889 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
890 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
891 for @funs; 885 for @funs;
892} 886}
887
888=over 4
889
890=item @retval = safe_eval $code, [var => value, ...]
891
892Compiled and executes the given perl code snippet. additional var/value
893pairs result in temporary local (my) scalar variables of the given name
894that are available in the code snippet. Example:
895
896 my $five = safe_eval '$first + $second', first => 1, second => 4;
897
898=cut
893 899
894sub safe_eval($;@) { 900sub safe_eval($;@) {
895 my ($code, %vars) = @_; 901 my ($code, %vars) = @_;
896 902
897 my $qcode = $code; 903 my $qcode = $code;
… …
920 } 926 }
921 927
922 wantarray ? @res : $res[0] 928 wantarray ? @res : $res[0]
923} 929}
924 930
931=item cf::register_script_function $function => $cb
932
933Register a function that can be called from within map/npc scripts. The
934function should be reasonably secure and should be put into a package name
935like the extension.
936
937Example: register a function that gets called whenever a map script calls
938C<rent::overview>, as used by the C<rent> extension.
939
940 cf::register_script_function "rent::overview" => sub {
941 ...
942 };
943
944=cut
945
925sub register_script_function { 946sub register_script_function {
926 my ($fun, $cb) = @_; 947 my ($fun, $cb) = @_;
927 948
928 no strict 'refs'; 949 no strict 'refs';
929 *{"safe::$fun"} = $safe_hole->wrap ($cb); 950 *{"safe::$fun"} = $safe_hole->wrap ($cb);
930} 951}
931 952
953=back
954
955=cut
956
957#############################################################################
958
959=head2 EXTENSION DATABASE SUPPORT
960
961Crossfire maintains a very simple database for extension use. It can
962currently store anything that can be serialised using Storable, which
963excludes objects.
964
965The parameter C<$family> should best start with the name of the extension
966using it, it should be unique.
967
968=over 4
969
970=item $hashref = cf::db_get $family
971
972Return a hashref for use by the extension C<$family>, which can be
973modified. After modifications, you have to call C<cf::db_dirty> or
974C<cf::db_sync>.
975
976=item $value = cf::db_get $family => $key
977
978Returns a single value from the database
979
980=item cf::db_put $family => $hashref
981
982Stores the given family hashref into the database. Updates are delayed, if
983you want the data to be synced to disk immediately, use C<cf::db_sync>.
984
985=item cf::db_put $family => $key => $value
986
987Stores the given C<$value> in the family hash. Updates are delayed, if you
988want the data to be synced to disk immediately, use C<cf::db_sync>.
989
990=item cf::db_dirty
991
992Marks the database as dirty, to be updated at a later time.
993
994=item cf::db_sync
995
996Immediately write the database to disk I<if it is dirty>.
997
998=cut
999
1000our $DB;
1001
1002{
1003 my $path = cf::localdir . "/database.pst";
1004
1005 sub db_load() {
1006 warn "loading database $path\n";#d# remove later
1007 $DB = stat $path ? Storable::retrieve $path : { };
1008 }
1009
1010 my $pid;
1011
1012 sub db_save() {
1013 warn "saving database $path\n";#d# remove later
1014 waitpid $pid, 0 if $pid;
1015 if (0 == ($pid = fork)) {
1016 $DB->{_meta}{version} = 1;
1017 Storable::nstore $DB, "$path~";
1018 rename "$path~", $path;
1019 cf::_exit 0 if defined $pid;
1020 }
1021 }
1022
1023 my $dirty;
1024
1025 sub db_sync() {
1026 db_save if $dirty;
1027 undef $dirty;
1028 }
1029
1030 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1031 db_sync;
1032 });
1033
1034 sub db_dirty() {
1035 $dirty = 1;
1036 $idle->start;
1037 }
1038
1039 sub db_get($;$) {
1040 @_ >= 2
1041 ? $DB->{$_[0]}{$_[1]}
1042 : ($DB->{$_[0]} ||= { })
1043 }
1044
1045 sub db_put($$;$) {
1046 if (@_ >= 3) {
1047 $DB->{$_[0]}{$_[1]} = $_[2];
1048 } else {
1049 $DB->{$_[0]} = $_[1];
1050 }
1051 db_dirty;
1052 }
1053
1054 attach_global
1055 prio => 10000,
1056 on_cleanup => sub {
1057 db_sync;
1058 },
1059 ;
1060}
1061
932############################################################################# 1062#############################################################################
933# the server's main() 1063# the server's main()
934 1064
1065sub cfg_load {
1066 open my $fh, "<:utf8", cf::confdir . "/config"
1067 or return;
1068
1069 local $/;
1070 *CFG = YAML::Syck::Load <$fh>;
1071}
1072
935sub main { 1073sub main {
1074 cfg_load;
1075 db_load;
936 load_extensions; 1076 load_extensions;
937 Event::loop; 1077 Event::loop;
938} 1078}
939 1079
940############################################################################# 1080#############################################################################
941# initialisation 1081# initialisation
942 1082
1083sub _perl_reload(&) {
1084 my ($msg) = @_;
1085
1086 $msg->("reloading...");
1087
1088 eval {
1089 # cancel all watchers
1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1093
1094 # unload all extensions
1095 for (@exts) {
1096 $msg->("unloading <$_>");
1097 unload_extension $_;
1098 }
1099
1100 # unload all modules loaded from $LIBDIR
1101 while (my ($k, $v) = each %INC) {
1102 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1103
1104 $msg->("removing <$k>");
1105 delete $INC{$k};
1106
1107 $k =~ s/\.pm$//;
1108 $k =~ s/\//::/g;
1109
1110 if (my $cb = $k->can ("unload_module")) {
1111 $cb->();
1112 }
1113
1114 Symbol::delete_package $k;
1115 }
1116
1117 # sync database to disk
1118 cf::db_sync;
1119
1120 # get rid of safe::, as good as possible
1121 Symbol::delete_package "safe::$_"
1122 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1123
1124 # remove register_script_function callbacks
1125 # TODO
1126
1127 # unload cf.pm "a bit"
1128 delete $INC{"cf.pm"};
1129
1130 # don't, removes xs symbols, too,
1131 # and global variables created in xs
1132 #Symbol::delete_package __PACKAGE__;
1133
1134 # reload cf.pm
1135 $msg->("reloading cf.pm");
1136 require cf;
1137
1138 # load config and database again
1139 cf::cfg_load;
1140 cf::db_load;
1141
1142 # load extensions
1143 $msg->("load extensions");
1144 cf::load_extensions;
1145
1146 # reattach attachments to objects
1147 $msg->("reattach");
1148 _global_reattach;
1149 };
1150 $msg->($@) if $@;
1151
1152 $msg->("reloaded");
1153};
1154
1155sub perl_reload() {
1156 _perl_reload {
1157 warn $_[0];
1158 print "$_[0]\n";
1159 };
1160}
1161
943register "<global>", __PACKAGE__; 1162register "<global>", __PACKAGE__;
944 1163
1164register_command "perl-reload" => sub {
1165 my ($who, $arg) = @_;
1166
1167 if ($who->flag (FLAG_WIZ)) {
1168 _perl_reload {
1169 warn $_[0];
1170 $who->message ($_[0]);
1171 };
1172 }
1173};
1174
945unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
946 1176
947$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
948 prio => 1, 1178 prio => 0,
949 at => $NEXT_TICK || 1, 1179 at => $NEXT_TICK || 1,
1180 data => WF_AUTOCANCEL,
950 cb => sub { 1181 cb => sub {
951 cf::server_tick; # one server iteration 1182 cf::server_tick; # one server iteration
952 1183
953 my $NOW = Event::time; 1184 my $NOW = Event::time;
954 $NEXT_TICK += $TICK; 1185 $NEXT_TICK += $TICK;
955 1186
956 # if we are delayed by four ticks, skip them all 1187 # if we are delayed by four ticks or more, skip them all
957 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1188 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
958 1189
959 $TICK_WATCHER->at ($NEXT_TICK); 1190 $TICK_WATCHER->at ($NEXT_TICK);
960 $TICK_WATCHER->start; 1191 $TICK_WATCHER->start;
961 }, 1192 },
962); 1193);
963 1194
964_reload_2; 1195IO::AIO::max_poll_time $TICK * 0.2;
1196
1197Event->io (fd => IO::AIO::poll_fileno,
1198 poll => 'r',
1199 prio => 5,
1200 data => WF_AUTOCANCEL,
1201 cb => \&IO::AIO::poll_cb);
965 1202
9661 12031
967 1204

Diff Legend

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