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.86 by root, Thu Dec 14 05:09:32 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;
17
18our %COMMAND = (); 21our %COMMAND = ();
22our %COMMAND_TIME = ();
23our %EXTCMD = ();
24
25_init_vars;
26
19our @EVENT; 27our @EVENT;
20our %PROP_TYPE;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl"; 28our $LIBDIR = maps_directory "perl";
23 29
24our $TICK = MAX_TIME * 1e-6; 30our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 31our $TICK_WATCHER;
26our $NEXT_TICK; 32our $NEXT_TICK;
33
34our %CFG;
35
36our $UPTIME; $UPTIME ||= time;
37
38#############################################################################
39
40=head2 GLOBAL VARIABLES
41
42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
47
48=item $cf::LIBDIR
49
50The perl library directory, where extensions and cf-specific modules can
51be found. It will be added to C<@INC> automatically.
52
53=item $cf::TICK
54
55The interval between server ticks, in seconds.
56
57=item %cf::CFG
58
59Configuration for the server, loaded from C</etc/crossfire/config>, or
60from wherever your confdir points to.
61
62=back
63
64=cut
27 65
28BEGIN { 66BEGIN {
29 *CORE::GLOBAL::warn = sub { 67 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 68 my $msg = join "", @_;
31 $msg .= "\n" 69 $msg .= "\n"
… …
34 print STDERR "cfperl: $msg"; 72 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 73 LOG llevError, "cfperl: $msg";
36 }; 74 };
37} 75}
38 76
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'; 77@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 78
75# we bless all objects into (empty) derived classes to force a method lookup 79# we bless all objects into (empty) derived classes to force a method lookup
76# within the Safe compartment. 80# 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)) { 81for my $pkg (qw(
82 cf::object cf::object::player
83 cf::client_socket cf::player
84 cf::arch cf::living
85 cf::map cf::party cf::region
86)) {
78 no strict 'refs'; 87 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 88 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 89}
81 90
82$Event::DIED = sub { 91$Event::DIED = sub {
… …
84}; 93};
85 94
86my %ext_pkg; 95my %ext_pkg;
87my @exts; 96my @exts;
88my @hook; 97my @hook;
89my %command;
90my %extcmd;
91 98
92############################################################################# 99=head2 UTILITY FUNCTIONS
93# utility functions 100
101=over 4
102
103=cut
94 104
95use JSON::Syck (); # TODO# replace by JSON::PC once working 105use JSON::Syck (); # TODO# replace by JSON::PC once working
106
107=item $ref = cf::from_json $json
108
109Converts a JSON string into the corresponding perl data structure.
110
111=cut
96 112
97sub from_json($) { 113sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 114 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 115 JSON::Syck::Load $_[0]
100} 116}
101 117
118=item $json = cf::to_json $ref
119
120Converts a perl data structure into its JSON representation.
121
122=cut
123
102sub to_json($) { 124sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 125 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 126 JSON::Syck::Dump $_[0]
105} 127}
106 128
129=back
130
131=cut
132
107############################################################################# 133#############################################################################
108# "new" plug-in system
109 134
110=head3 EVENTS AND OBJECT ATTACHMENTS 135=head2 EVENTS AND OBJECT ATTACHMENTS
111 136
112=over 4 137=over 4
113 138
114=item $object->attach ($attachment, key => $value...) 139=item $object->attach ($attachment, key => $value...)
115 140
… …
389 for (@$callbacks) { 414 for (@$callbacks) {
390 eval { &{$_->[1]} }; 415 eval { &{$_->[1]} };
391 416
392 if ($@) { 417 if ($@) {
393 warn "$@"; 418 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 419 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
395 override; 420 override;
396 } 421 }
397 422
398 return 1 if $override; 423 return 1 if $override;
399 } 424 }
… …
415removed in future versions), and there is no public API to access override 440removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly). 441results (if you must, access C<@cf::invoke_results> directly).
417 442
418=back 443=back
419 444
420=head2 methods valid for all pointers 445=cut
446
447#############################################################################
448
449=head2 METHODS VALID FOR ALL CORE OBJECTS
421 450
422=over 4 451=over 4
423 452
424=item $object->valid 453=item $object->valid, $player->valid, $map->valid
425
426=item $player->valid
427
428=item $map->valid
429 454
430Just because you have a perl object does not mean that the corresponding 455Just 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 456C-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 457valid 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 458can be used to test for existence of the C object part without causing an
… …
506 unlink $filename; 531 unlink $filename;
507 unlink "$filename.pst"; 532 unlink "$filename.pst";
508 } 533 }
509} 534}
510 535
536sub object_freezer_as_string {
537 my ($rdata, $objs) = @_;
538
539 use Data::Dumper;
540
541 $$rdata . Dumper $objs
542}
543
511sub object_thawer_load { 544sub object_thawer_load {
512 my ($filename) = @_; 545 my ($filename) = @_;
513 546
514 local $/; 547 local $/;
515 548
… …
540 if exists $src->{_attachment}; 573 if exists $src->{_attachment};
541 }, 574 },
542; 575;
543 576
544############################################################################# 577#############################################################################
545# old plug-in events 578# command handling &c
546 579
547sub inject_event { 580=item cf::register_command $name => \&callback($ob,$args);
548 my $extension = shift;
549 my $event_code = shift;
550 581
551 my $cb = $hook[$event_code]{$extension} 582Register a callback for execution when the client sends the user command
552 or return; 583$name.
553 584
554 &$cb 585=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 586
576sub register_command { 587sub register_command {
577 my ($name, $time, $cb) = @_; 588 my ($name, $cb) = @_;
578 589
579 my $caller = caller; 590 my $caller = caller;
580 #warn "registering command '$name/$time' to '$caller'"; 591 #warn "registering command '$name/$time' to '$caller'";
581 592
582 push @{ $command{$name} }, [$time, $cb, $caller]; 593 push @{ $COMMAND{$name} }, [$caller, $cb];
583 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
584} 594}
595
596=item cf::register_extcmd $name => \&callback($pl,$packet);
597
598Register a callbackf ro execution when the client sends an extcmd packet.
599
600If the callback returns something, it is sent back as if reply was being
601called.
602
603=cut
585 604
586sub register_extcmd { 605sub register_extcmd {
587 my ($name, $cb) = @_; 606 my ($name, $cb) = @_;
588 607
589 my $caller = caller; 608 my $caller = caller;
590 #warn "registering extcmd '$name' to '$caller'"; 609 #warn "registering extcmd '$name' to '$caller'";
591 610
592 $extcmd{$name} = [$cb, $caller]; 611 $EXTCMD{$name} = [$cb, $caller];
593} 612}
613
614attach_to_players
615 on_command => sub {
616 my ($pl, $name, $params) = @_;
617
618 my $cb = $COMMAND{$name}
619 or return;
620
621 for my $cmd (@$cb) {
622 $cmd->[1]->($pl->ob, $params);
623 }
624
625 cf::override;
626 },
627 on_extcmd => sub {
628 my ($pl, $buf) = @_;
629
630 my $msg = eval { from_json $buf };
631
632 if (ref $msg) {
633 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
634 if (my %reply = $cb->[0]->($pl, $msg)) {
635 $pl->ext_reply ($msg->{msgid}, %reply);
636 }
637 }
638 } else {
639 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
640 }
641
642 cf::override;
643 },
644;
594 645
595sub register { 646sub register {
596 my ($base, $pkg) = @_; 647 my ($base, $pkg) = @_;
597 648
598 #TODO 649 #TODO
… …
617 . "#line 1 \"$path\"\n{\n" 668 . "#line 1 \"$path\"\n{\n"
618 . (do { local $/; <$fh> }) 669 . (do { local $/; <$fh> })
619 . "\n};\n1"; 670 . "\n};\n1";
620 671
621 eval $source 672 eval $source
622 or die "$path: $@"; 673 or die $@ ? "$path: $@\n"
674 : "extension disabled.\n";
623 675
624 push @exts, $pkg; 676 push @exts, $pkg;
625 $ext_pkg{$base} = $pkg; 677 $ext_pkg{$base} = $pkg;
626 678
627# no strict 'refs'; 679# no strict 'refs';
… …
640# for my $idx (0 .. $#PLUGIN_EVENT) { 692# for my $idx (0 .. $#PLUGIN_EVENT) {
641# delete $hook[$idx]{$pkg}; 693# delete $hook[$idx]{$pkg};
642# } 694# }
643 695
644 # remove commands 696 # remove commands
645 for my $name (keys %command) { 697 for my $name (keys %COMMAND) {
646 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 698 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
647 699
648 if (@cb) { 700 if (@cb) {
649 $command{$name} = \@cb; 701 $COMMAND{$name} = \@cb;
650 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
651 } else { 702 } else {
652 delete $command{$name};
653 delete $COMMAND{"$name\000"}; 703 delete $COMMAND{$name};
654 } 704 }
655 } 705 }
656 706
657 # remove extcmds 707 # remove extcmds
658 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 708 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
659 delete $extcmd{$name}; 709 delete $EXTCMD{$name};
660 } 710 }
661 711
662 if (my $cb = $pkg->can ("unload")) { 712 if (my $cb = $pkg->can ("unload")) {
663 eval { 713 eval {
664 $cb->($pkg); 714 $cb->($pkg);
… …
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
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
882 874
883for ( 875for (
884 ["cf::object" => qw(contr pay_amount pay_player)], 876 ["cf::object" => qw(contr pay_amount pay_player)],
885 ["cf::object::player" => qw(player)], 877 ["cf::object::player" => qw(player)],
886 ["cf::player" => qw(peaceful)], 878 ["cf::player" => qw(peaceful)],
… …
889 my ($pkg, @funs) = @$_; 881 my ($pkg, @funs) = @$_;
890 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 882 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
891 for @funs; 883 for @funs;
892} 884}
893 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
894sub safe_eval($;@) { 898sub safe_eval($;@) {
895 my ($code, %vars) = @_; 899 my ($code, %vars) = @_;
896 900
897 my $qcode = $code; 901 my $qcode = $code;
898 $qcode =~ s/"/‟/g; # not allowed in #line filenames 902 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
920 } 924 }
921 925
922 wantarray ? @res : $res[0] 926 wantarray ? @res : $res[0]
923} 927}
924 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
925sub register_script_function { 944sub register_script_function {
926 my ($fun, $cb) = @_; 945 my ($fun, $cb) = @_;
927 946
928 no strict 'refs'; 947 no strict 'refs';
929 *{"safe::$fun"} = $safe_hole->wrap ($cb); 948 *{"safe::$fun"} = $safe_hole->wrap ($cb);
930} 949}
931 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, 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
932############################################################################# 1060#############################################################################
933# the server's main() 1061# the server's main()
934 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
935sub main { 1071sub main {
1072 cfg_load;
1073 db_load;
936 load_extensions; 1074 load_extensions;
937 Event::loop; 1075 Event::loop;
938} 1076}
939 1077
940############################################################################# 1078#############################################################################
941# initialisation 1079# initialisation
942 1080
1081sub _perl_reload(&) {
1082 my ($msg) = @_;
1083
1084 $msg->("reloading...");
1085
1086 eval {
1087 # cancel all watchers
1088 $_->cancel for Event::all_watchers;
1089
1090 # unload all extensions
1091 for (@exts) {
1092 $msg->("unloading <$_>");
1093 unload_extension $_;
1094 }
1095
1096 # unload all modules loaded from $LIBDIR
1097 while (my ($k, $v) = each %INC) {
1098 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1099
1100 $msg->("removing <$k>");
1101 delete $INC{$k};
1102
1103 $k =~ s/\.pm$//;
1104 $k =~ s/\//::/g;
1105
1106 if (my $cb = $k->can ("unload_module")) {
1107 $cb->();
1108 }
1109
1110 Symbol::delete_package $k;
1111 }
1112
1113 # sync database to disk
1114 cf::db_sync;
1115
1116 # get rid of safe::, as good as possible
1117 Symbol::delete_package "safe::$_"
1118 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1119
1120 # remove register_script_function callbacks
1121 # TODO
1122
1123 # unload cf.pm "a bit"
1124 delete $INC{"cf.pm"};
1125
1126 # don't, removes xs symbols, too,
1127 # and global variables created in xs
1128 #Symbol::delete_package __PACKAGE__;
1129
1130 # reload cf.pm
1131 $msg->("reloading cf.pm");
1132 require cf;
1133
1134 # load config and database again
1135 cf::cfg_load;
1136 cf::db_load;
1137
1138 # load extensions
1139 $msg->("load extensions");
1140 cf::load_extensions;
1141
1142 # reattach attachments to objects
1143 $msg->("reattach");
1144 _global_reattach;
1145 };
1146 $msg->($@) if $@;
1147
1148 $msg->("reloaded");
1149};
1150
1151sub perl_reload() {
1152 _perl_reload {
1153 warn $_[0];
1154 print "$_[0]\n";
1155 };
1156}
1157
943register "<global>", __PACKAGE__; 1158register "<global>", __PACKAGE__;
944 1159
1160register_command "perl-reload" => sub {
1161 my ($who, $arg) = @_;
1162
1163 if ($who->flag (FLAG_WIZ)) {
1164 _perl_reload {
1165 warn $_[0];
1166 $who->message ($_[0]);
1167 };
1168 }
1169};
1170
945unshift @INC, $LIBDIR; 1171unshift @INC, $LIBDIR;
946 1172
947$TICK_WATCHER = Event->timer ( 1173$TICK_WATCHER = Event->timer (
948 prio => 1, 1174 prio => 1,
1175 async => 1,
949 at => $NEXT_TICK || 1, 1176 at => $NEXT_TICK || 1,
950 cb => sub { 1177 cb => sub {
951 cf::server_tick; # one server iteration 1178 cf::server_tick; # one server iteration
952 1179
953 my $NOW = Event::time; 1180 my $NOW = Event::time;
954 $NEXT_TICK += $TICK; 1181 $NEXT_TICK += $TICK;
955 1182
956 # if we are delayed by four ticks, skip them all 1183 # if we are delayed by four ticks or more, skip them all
957 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1184 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
958 1185
959 $TICK_WATCHER->at ($NEXT_TICK); 1186 $TICK_WATCHER->at ($NEXT_TICK);
960 $TICK_WATCHER->start; 1187 $TICK_WATCHER->start;
961 }, 1188 },
962); 1189);
963 1190
964_reload_2; 1191IO::AIO::max_poll_time $TICK * 0.2;
1192
1193Event->io (fd => IO::AIO::poll_fileno,
1194 poll => 'r',
1195 prio => 5,
1196 cb => \&IO::AIO::poll_cb);
965 1197
9661 11981
967 1199

Diff Legend

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