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.60 by root, Thu Aug 31 06:23:19 2006 UTC vs.
Revision 1.87 by root, Thu Dec 14 22:45:40 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;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl"; 30our $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_socket 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
549 local $/;
550
551 my $av;
552
553 #TODO: use sysread etc.
554 if (open my $data, "<:raw:perlio", $filename) {
555 $data = <$data>;
514 open my $fh, "<:raw:perlio", "$filename.pst" 556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
515 or return; 557 $av = eval { (Storable::thaw <$pst>)->{objs} };
558 }
559 return ($data, $av);
560 }
516 561
517 eval { local $/; (Storable::thaw <$fh>)->{objs} } 562 ()
518} 563}
519 564
520attach_to_objects 565attach_to_objects
521 prio => -1000000, 566 prio => -1000000,
522 on_clone => sub { 567 on_clone => sub {
… …
530 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
531 }, 576 },
532; 577;
533 578
534############################################################################# 579#############################################################################
535# old plug-in events 580# command handling &c
536 581
537sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
538 my $extension = shift;
539 my $event_code = shift;
540 583
541 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
542 or return; 585$name.
543 586
544 &$cb 587=cut
545}
546
547sub inject_global_event {
548 my $event = shift;
549
550 my $cb = $hook[$event]
551 or return;
552
553 List::Util::max map &$_, values %$cb
554}
555
556sub inject_command {
557 my ($name, $obj, $params) = @_;
558
559 for my $cmd (@{ $command{$name} }) {
560 $cmd->[1]->($obj, $params);
561 }
562
563 -1
564}
565 588
566sub register_command { 589sub register_command {
567 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
568 591
569 my $caller = caller; 592 my $caller = caller;
570 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
571 594
572 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
573 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
574} 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
575 606
576sub register_extcmd { 607sub register_extcmd {
577 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
578 609
579 my $caller = caller; 610 my $caller = caller;
580 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
581 612
582 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
583} 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;
584 647
585sub register { 648sub register {
586 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
587 650
588 #TODO 651 #TODO
… …
607 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
608 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
609 . "\n};\n1"; 672 . "\n};\n1";
610 673
611 eval $source 674 eval $source
612 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
613 677
614 push @exts, $pkg; 678 push @exts, $pkg;
615 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
616 680
617# no strict 'refs'; 681# no strict 'refs';
… …
630# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
631# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
632# } 696# }
633 697
634 # remove commands 698 # remove commands
635 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
636 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
637 701
638 if (@cb) { 702 if (@cb) {
639 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
640 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
641 } else { 704 } else {
642 delete $command{$name};
643 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
644 } 706 }
645 } 707 }
646 708
647 # remove extcmds 709 # remove extcmds
648 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
649 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
650 } 712 }
651 713
652 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
653 eval { 715 eval {
654 $cb->($pkg); 716 $cb->($pkg);
… …
669 1 731 1
670 } or warn "$ext not loaded: $@"; 732 } or warn "$ext not loaded: $@";
671 } 733 }
672} 734}
673 735
674sub _perl_reload(&) {
675 my ($msg) = @_;
676
677 $msg->("reloading...");
678
679 eval {
680 # 1. cancel all watchers
681 $_->cancel for Event::all_watchers;
682
683 # 2. unload all extensions
684 for (@exts) {
685 $msg->("unloading <$_>");
686 unload_extension $_;
687 }
688
689 # 3. unload all modules loaded from $LIBDIR
690 while (my ($k, $v) = each %INC) {
691 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
692
693 $msg->("removing <$k>");
694 delete $INC{$k};
695
696 $k =~ s/\.pm$//;
697 $k =~ s/\//::/g;
698
699 if (my $cb = $k->can ("unload_module")) {
700 $cb->();
701 }
702
703 Symbol::delete_package $k;
704 }
705
706 # 4. get rid of safe::, as good as possible
707 Symbol::delete_package "safe::$_"
708 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
709
710 # 5. remove register_script_function callbacks
711 # TODO
712
713 # 6. unload cf.pm "a bit"
714 delete $INC{"cf.pm"};
715
716 # don't, removes xs symbols, too,
717 # and global variables created in xs
718 #Symbol::delete_package __PACKAGE__;
719
720 # 7. reload cf.pm
721 $msg->("reloading cf.pm");
722 require cf;
723 };
724 $msg->($@) if $@;
725
726 $msg->("reloaded");
727};
728
729sub perl_reload() {
730 _perl_reload {
731 warn $_[0];
732 print "$_[0]\n";
733 };
734}
735
736register_command "perl-reload", 0, sub {
737 my ($who, $arg) = @_;
738
739 if ($who->flag (FLAG_WIZ)) {
740 _perl_reload {
741 warn $_[0];
742 $who->message ($_[0]);
743 };
744 }
745};
746
747#############################################################################
748# extcmd framework, basically convert ext <msg>
749# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
750
751attach_to_players
752 on_extcmd => sub {
753 my ($pl, $buf) = @_;
754
755 my $msg = eval { from_json $buf };
756
757 if (ref $msg) {
758 if (my $cb = $extcmd{$msg->{msgtype}}) {
759 if (my %reply = $cb->[0]->($pl, $msg)) {
760 $pl->ext_reply ($msg->{msgid}, %reply);
761 }
762 }
763 } else {
764 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
765 }
766
767 cf::override;
768 },
769;
770
771############################################################################# 736#############################################################################
772# load/save/clean perl data associated with a map 737# load/save/clean perl data associated with a map
773 738
774*cf::mapsupport::on_clean = sub { 739*cf::mapsupport::on_clean = sub {
775 my ($map) = @_; 740 my ($map) = @_;
… …
803 } 768 }
804 }, 769 },
805; 770;
806 771
807############################################################################# 772#############################################################################
808# core extensions - in perl 773
774=head2 CORE EXTENSIONS
775
776Functions and methods that extend core crossfire objects.
777
778=over 4
809 779
810=item cf::player::exists $login 780=item cf::player::exists $login
811 781
812Returns true when the given account exists. 782Returns true when the given account exists.
813 783
… …
816sub cf::player::exists($) { 786sub cf::player::exists($) {
817 cf::player::find $_[0] 787 cf::player::find $_[0]
818 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 788 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
819} 789}
820 790
821=item $player->reply ($npc, $msg[, $flags]) 791=item $player_object->reply ($npc, $msg[, $flags])
822 792
823Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 793Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
824can be C<undef>. Does the right thing when the player is currently in a 794can be C<undef>. Does the right thing when the player is currently in a
825dialogue with the given NPC character. 795dialogue with the given NPC character.
826 796
… …
853 $msg{msgid} = $id; 823 $msg{msgid} = $id;
854 824
855 $self->send ("ext " . to_json \%msg); 825 $self->send ("ext " . to_json \%msg);
856} 826}
857 827
828=item $player_object->may ("access")
829
830Returns wether the given player is authorized to access resource "access"
831(e.g. "command_wizcast").
832
833=cut
834
835sub cf::object::player::may {
836 my ($self, $access) = @_;
837
838 $self->flag (cf::FLAG_WIZ) ||
839 (ref $cf::CFG{"may_$access"}
840 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
841 : $cf::CFG{"may_$access"})
842}
843
844=cut
845
858############################################################################# 846#############################################################################
859# map scripting support 847
848=head2 SAFE SCRIPTING
849
850Functions that provide a safe environment to compile and execute
851snippets of perl code without them endangering the safety of the server
852itself. Looping constructs, I/O operators and other built-in functionality
853is not available in the safe scripting environment, and the number of
854functions and methods that can be called is greatly reduced.
855
856=cut
860 857
861our $safe = new Safe "safe"; 858our $safe = new Safe "safe";
862our $safe_hole = new Safe::Hole; 859our $safe_hole = new Safe::Hole;
863 860
864$SIG{FPE} = 'IGNORE'; 861$SIG{FPE} = 'IGNORE';
865 862
866$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 863$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
867 864
868# here we export the classes and methods available to script code 865# here we export the classes and methods available to script code
866
867=pod
868
869The following fucntions and emthods are available within a safe environment:
870
871 cf::object contr pay_amount pay_player
872 cf::object::player player
873 cf::player peaceful
874
875=cut
869 876
870for ( 877for (
871 ["cf::object" => qw(contr pay_amount pay_player)], 878 ["cf::object" => qw(contr pay_amount pay_player)],
872 ["cf::object::player" => qw(player)], 879 ["cf::object::player" => qw(player)],
873 ["cf::player" => qw(peaceful)], 880 ["cf::player" => qw(peaceful)],
… …
876 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
877 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
878 for @funs; 885 for @funs;
879} 886}
880 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
899
881sub safe_eval($;@) { 900sub safe_eval($;@) {
882 my ($code, %vars) = @_; 901 my ($code, %vars) = @_;
883 902
884 my $qcode = $code; 903 my $qcode = $code;
885 $qcode =~ s/"/‟/g; # not allowed in #line filenames 904 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
907 } 926 }
908 927
909 wantarray ? @res : $res[0] 928 wantarray ? @res : $res[0]
910} 929}
911 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
912sub register_script_function { 946sub register_script_function {
913 my ($fun, $cb) = @_; 947 my ($fun, $cb) = @_;
914 948
915 no strict 'refs'; 949 no strict 'refs';
916 *{"safe::$fun"} = $safe_hole->wrap ($cb); 950 *{"safe::$fun"} = $safe_hole->wrap ($cb);
917} 951}
918 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
919############################################################################# 1062#############################################################################
920# the server's main() 1063# the server's main()
921 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
922sub main { 1073sub main {
1074 cfg_load;
1075 db_load;
1076 load_extensions;
923 Event::loop; 1077 Event::loop;
924} 1078}
925 1079
926############################################################################# 1080#############################################################################
927# initialisation 1081# initialisation
928 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
929register "<global>", __PACKAGE__; 1162register "<global>", __PACKAGE__;
930 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
931unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
932 1176
933load_extensions;
934
935$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
936 prio => 1, 1178 prio => 1,
1179 async => 1,
937 at => $NEXT_TICK || 1, 1180 at => $NEXT_TICK || 1,
1181 data => WF_AUTOCANCEL,
938 cb => sub { 1182 cb => sub {
939 cf::server_tick; # one server iteration 1183 cf::server_tick; # one server iteration
940 1184
941 my $NOW = Event::time; 1185 my $NOW = Event::time;
942 $NEXT_TICK += $TICK; 1186 $NEXT_TICK += $TICK;
943 1187
944 # if we are delayed by four ticks, skip them all 1188 # if we are delayed by four ticks or more, skip them all
945 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1189 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
946 1190
947 $TICK_WATCHER->at ($NEXT_TICK); 1191 $TICK_WATCHER->at ($NEXT_TICK);
948 $TICK_WATCHER->start; 1192 $TICK_WATCHER->start;
949 }, 1193 },
950); 1194);
951 1195
952_reload_2; 1196IO::AIO::max_poll_time $TICK * 0.2;
1197
1198Event->io (fd => IO::AIO::poll_fileno,
1199 poll => 'r',
1200 prio => 5,
1201 data => WF_AUTOCANCEL,
1202 cb => \&IO::AIO::poll_cb);
953 1203
9541 12041
955 1205

Diff Legend

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