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.58 by root, Wed Aug 30 12:08:15 2006 UTC vs.
Revision 1.76 by root, Mon Oct 2 15:28:36 2006 UTC

… …
5use Storable; 5use Storable;
6use Opcode; 6use Opcode;
7use Safe; 7use Safe;
8use Safe::Hole; 8use Safe::Hole;
9 9
10use YAML::Syck ();
10use Time::HiRes; 11use Time::HiRes;
11use Event; 12use Event;
12$Event::Eval = 1; # no idea why this is required, but it is 13$Event::Eval = 1; # no idea why this is required, but it is
13 14
15# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
16$YAML::Syck::ImplicitUnicode = 1;
17
14use strict; 18use strict;
15 19
16_reload_1; 20_init_vars;
17 21
18our %COMMAND = (); 22our %COMMAND = ();
19our @EVENT; 23our @EVENT;
20our %PROP_TYPE;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl"; 24our $LIBDIR = maps_directory "perl";
23 25
24our $TICK = MAX_TIME * 1e-6; 26our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 27our $TICK_WATCHER;
26our $NEXT_TICK; 28our $NEXT_TICK;
29
30our %CFG;
31
32our $uptime;
33
34$uptime ||= time;
35
36#############################################################################
37
38=head2 GLOBAL VARIABLES
39
40=over 4
41
42=item $cf::LIBDIR
43
44The perl library directory, where extensions and cf-specific modules can
45be found. It will be added to C<@INC> automatically.
46
47=item $cf::TICK
48
49The interval between server ticks, in seconds.
50
51=item %cf::CFG
52
53Configuration for the server, loaded from C</etc/crossfire/config>, or
54from wherever your confdir points to.
55
56=back
57
58=cut
27 59
28BEGIN { 60BEGIN {
29 *CORE::GLOBAL::warn = sub { 61 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 62 my $msg = join "", @_;
31 $msg .= "\n" 63 $msg .= "\n"
… …
34 print STDERR "cfperl: $msg"; 66 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 67 LOG llevError, "cfperl: $msg";
36 }; 68 };
37} 69}
38 70
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'; 71@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 72
75# we bless all objects into (empty) derived classes to force a method lookup 73# we bless all objects into (empty) derived classes to force a method lookup
76# within the Safe compartment. 74# 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)) { 75for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) {
… …
87my @exts; 85my @exts;
88my @hook; 86my @hook;
89my %command; 87my %command;
90my %extcmd; 88my %extcmd;
91 89
92############################################################################# 90=head2 UTILITY FUNCTIONS
93# utility functions 91
92=over 4
93
94=cut
94 95
95use JSON::Syck (); # TODO# replace by JSON::PC once working 96use JSON::Syck (); # TODO# replace by JSON::PC once working
97
98=item $ref = cf::from_json $json
99
100Converts a JSON string into the corresponding perl data structure.
101
102=cut
96 103
97sub from_json($) { 104sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 105 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 106 JSON::Syck::Load $_[0]
100} 107}
101 108
109=item $json = cf::to_json $ref
110
111Converts a perl data structure into its JSON representation.
112
113=cut
114
102sub to_json($) { 115sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 116 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 117 JSON::Syck::Dump $_[0]
105} 118}
106 119
107############################################################################# 120=back
108# "new" plug-in system
109 121
122=cut
123
124#############################################################################
125
110=head3 EVENTS AND OBJECT ATTACHMENTS 126=head2 EVENTS AND OBJECT ATTACHMENTS
111 127
112=over 4 128=over 4
113 129
114=item $object->attach ($attachment, key => $value...) 130=item $object->attach ($attachment, key => $value...)
115 131
… …
389 for (@$callbacks) { 405 for (@$callbacks) {
390 eval { &{$_->[1]} }; 406 eval { &{$_->[1]} };
391 407
392 if ($@) { 408 if ($@) {
393 warn "$@"; 409 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 410 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
395 override; 411 override;
396 } 412 }
397 413
398 return 1 if $override; 414 return 1 if $override;
399 } 415 }
… …
415removed in future versions), and there is no public API to access override 431removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly). 432results (if you must, access C<@cf::invoke_results> directly).
417 433
418=back 434=back
419 435
420=head2 methods valid for all pointers 436=cut
437
438#############################################################################
439
440=head2 METHODS VALID FOR ALL CORE OBJECTS
421 441
422=over 4 442=over 4
423 443
424=item $object->valid 444=item $object->valid, $player->valid, $map->valid
425
426=item $player->valid
427
428=item $map->valid
429 445
430Just because you have a perl object does not mean that the corresponding 446Just 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 447C-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 448valid 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 449can be used to test for existence of the C object part without causing an
… …
476 } 492 }
477 } 493 }
478} 494}
479 495
480sub object_freezer_save { 496sub object_freezer_save {
481 my ($filename, $objs) = @_; 497 my ($filename, $rdata, $objs) = @_;
482 498
483 if (@$objs) { 499 if (length $$rdata) {
500 warn sprintf "saving %s (%d,%d)\n",
501 $filename, length $$rdata, scalar @$objs;
502
484 open my $fh, ">:raw", "$filename.pst~"; 503 if (open my $fh, ">:raw", "$filename~") {
504 chmod SAVE_MODE, $fh;
505 syswrite $fh, $$rdata;
506 close $fh;
507
508 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
509 chmod SAVE_MODE, $fh;
485 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 510 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
486 close $fh; 511 close $fh;
487 chmod SAVE_MODE, "$filename.pst~";
488 rename "$filename.pst~", "$filename.pst"; 512 rename "$filename.pst~", "$filename.pst";
513 } else {
514 unlink "$filename.pst";
515 }
516
517 rename "$filename~", $filename;
518 } else {
519 warn "FATAL: $filename~: $!\n";
520 }
489 } else { 521 } else {
522 unlink $filename;
490 unlink "$filename.pst"; 523 unlink "$filename.pst";
491 } 524 }
492
493 chmod SAVE_MODE, "$filename~";
494 rename "$filename~", $filename;
495} 525}
496 526
497sub object_thawer_load { 527sub object_thawer_load {
498 my ($filename) = @_; 528 my ($filename) = @_;
499 529
530 local $/;
531
532 my $av;
533
534 #TODO: use sysread etc.
535 if (open my $data, "<:raw:perlio", $filename) {
536 $data = <$data>;
500 open my $fh, "<:raw:perlio", "$filename.pst" 537 if (open my $pst, "<:raw:perlio", "$filename.pst") {
501 or return; 538 $av = eval { (Storable::thaw <$pst>)->{objs} };
539 }
540 return ($data, $av);
541 }
502 542
503 eval { local $/; (Storable::thaw <$fh>)->{objs} } 543 ()
504} 544}
505 545
506attach_to_objects 546attach_to_objects
507 prio => -1000000, 547 prio => -1000000,
508 on_clone => sub { 548 on_clone => sub {
… …
654 load_extension $ext; 694 load_extension $ext;
655 1 695 1
656 } or warn "$ext not loaded: $@"; 696 } or warn "$ext not loaded: $@";
657 } 697 }
658} 698}
659
660sub _perl_reload(&) {
661 my ($msg) = @_;
662
663 $msg->("reloading...");
664
665 eval {
666 # 1. cancel all watchers
667 $_->cancel for Event::all_watchers;
668
669 # 2. unload all extensions
670 for (@exts) {
671 $msg->("unloading <$_>");
672 unload_extension $_;
673 }
674
675 # 3. unload all modules loaded from $LIBDIR
676 while (my ($k, $v) = each %INC) {
677 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
678
679 $msg->("removing <$k>");
680 delete $INC{$k};
681
682 $k =~ s/\.pm$//;
683 $k =~ s/\//::/g;
684
685 if (my $cb = $k->can ("unload_module")) {
686 $cb->();
687 }
688
689 Symbol::delete_package $k;
690 }
691
692 # 4. get rid of safe::, as good as possible
693 Symbol::delete_package "safe::$_"
694 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
695
696 # 5. remove register_script_function callbacks
697 # TODO
698
699 # 6. unload cf.pm "a bit"
700 delete $INC{"cf.pm"};
701
702 # don't, removes xs symbols, too,
703 # and global variables created in xs
704 #Symbol::delete_package __PACKAGE__;
705
706 # 7. reload cf.pm
707 $msg->("reloading cf.pm");
708 require cf;
709 };
710 $msg->($@) if $@;
711
712 $msg->("reloaded");
713};
714
715sub perl_reload() {
716 _perl_reload {
717 warn $_[0];
718 print "$_[0]\n";
719 };
720}
721
722register_command "perl-reload", 0, sub {
723 my ($who, $arg) = @_;
724
725 if ($who->flag (FLAG_WIZ)) {
726 _perl_reload {
727 warn $_[0];
728 $who->message ($_[0]);
729 };
730 }
731};
732 699
733############################################################################# 700#############################################################################
734# extcmd framework, basically convert ext <msg> 701# extcmd framework, basically convert ext <msg>
735# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 702# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
736 703
… …
773 740
774sub all_objects(@) { 741sub all_objects(@) {
775 @_, map all_objects ($_->inv), @_ 742 @_, map all_objects ($_->inv), @_
776} 743}
777 744
745# TODO: compatibility cruft, remove when no longer needed
778attach_to_players 746attach_to_players
779 on_load => sub { 747 on_load => sub {
780 my ($pl, $path) = @_; 748 my ($pl, $path) = @_;
781 749
782 for my $o (all_objects $pl->ob) { 750 for my $o (all_objects $pl->ob) {
… …
788 } 756 }
789 }, 757 },
790; 758;
791 759
792############################################################################# 760#############################################################################
793# core extensions - in perl 761
762=head2 CORE EXTENSIONS
763
764Functions and methods that extend core crossfire objects.
765
766=over 4
794 767
795=item cf::player::exists $login 768=item cf::player::exists $login
796 769
797Returns true when the given account exists. 770Returns true when the given account exists.
798 771
… …
801sub cf::player::exists($) { 774sub cf::player::exists($) {
802 cf::player::find $_[0] 775 cf::player::find $_[0]
803 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 776 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
804} 777}
805 778
806=item $player->reply ($npc, $msg[, $flags]) 779=item $object->reply ($npc, $msg[, $flags])
807 780
808Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 781Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
809can be C<undef>. Does the right thing when the player is currently in a 782can be C<undef>. Does the right thing when the player is currently in a
810dialogue with the given NPC character. 783dialogue with the given NPC character.
811 784
… …
838 $msg{msgid} = $id; 811 $msg{msgid} = $id;
839 812
840 $self->send ("ext " . to_json \%msg); 813 $self->send ("ext " . to_json \%msg);
841} 814}
842 815
816=back
817
818=cut
819
843############################################################################# 820#############################################################################
844# map scripting support 821
822=head2 SAFE SCRIPTING
823
824Functions that provide a safe environment to compile and execute
825snippets of perl code without them endangering the safety of the server
826itself. Looping constructs, I/O operators and other built-in functionality
827is not available in the safe scripting environment, and the number of
828functions and methods that cna be called is greatly reduced.
829
830=cut
845 831
846our $safe = new Safe "safe"; 832our $safe = new Safe "safe";
847our $safe_hole = new Safe::Hole; 833our $safe_hole = new Safe::Hole;
848 834
849$SIG{FPE} = 'IGNORE'; 835$SIG{FPE} = 'IGNORE';
850 836
851$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 837$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
852 838
853# here we export the classes and methods available to script code 839# here we export the classes and methods available to script code
840
841=pod
842
843The following fucntions and emthods are available within a safe environment:
844
845 cf::object contr pay_amount pay_player
846 cf::object::player player
847 cf::player peaceful
848
849=cut
854 850
855for ( 851for (
856 ["cf::object" => qw(contr pay_amount pay_player)], 852 ["cf::object" => qw(contr pay_amount pay_player)],
857 ["cf::object::player" => qw(player)], 853 ["cf::object::player" => qw(player)],
858 ["cf::player" => qw(peaceful)], 854 ["cf::player" => qw(peaceful)],
… …
861 my ($pkg, @funs) = @$_; 857 my ($pkg, @funs) = @$_;
862 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 858 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
863 for @funs; 859 for @funs;
864} 860}
865 861
862=over 4
863
864=item @retval = safe_eval $code, [var => value, ...]
865
866Compiled and executes the given perl code snippet. additional var/value
867pairs result in temporary local (my) scalar variables of the given name
868that are available in the code snippet. Example:
869
870 my $five = safe_eval '$first + $second', first => 1, second => 4;
871
872=cut
873
866sub safe_eval($;@) { 874sub safe_eval($;@) {
867 my ($code, %vars) = @_; 875 my ($code, %vars) = @_;
868 876
869 my $qcode = $code; 877 my $qcode = $code;
870 $qcode =~ s/"/‟/g; # not allowed in #line filenames 878 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
892 } 900 }
893 901
894 wantarray ? @res : $res[0] 902 wantarray ? @res : $res[0]
895} 903}
896 904
905=item cf::register_script_function $function => $cb
906
907Register a function that can be called from within map/npc scripts. The
908function should be reasonably secure and should be put into a package name
909like the extension.
910
911Example: register a function that gets called whenever a map script calls
912C<rent::overview>, as used by the C<rent> extension.
913
914 cf::register_script_function "rent::overview" => sub {
915 ...
916 };
917
918=cut
919
897sub register_script_function { 920sub register_script_function {
898 my ($fun, $cb) = @_; 921 my ($fun, $cb) = @_;
899 922
900 no strict 'refs'; 923 no strict 'refs';
901 *{"safe::$fun"} = $safe_hole->wrap ($cb); 924 *{"safe::$fun"} = $safe_hole->wrap ($cb);
902} 925}
903 926
927=back
928
929=cut
930
931#############################################################################
932
933=head2 EXTENSION DATABASE SUPPORT
934
935Crossfire maintains a very simple database for extension use. It can
936currently store anything that can be serialised using Storable, which
937excludes objects.
938
939The parameter C<$family> should best start with the name of the extension
940using it, it should be unique.
941
942=over 4
943
944=item $hashref = cf::db_get $family
945
946Return a hashref for use by the extension C<$family>, which can be
947modified. After modifications, you have to call C<cf::db_dirty> or
948C<cf::db_sync>.
949
950=item $value = cf::db_get $family => $key
951
952Returns a single value from the database
953
954=item cf::db_put $family => $hashref
955
956Stores the given family hashref into the database. Updates are delayed, if
957you want the data to be synced to disk immediately, use C<cf::db_sync>.
958
959=item cf::db_put $family => $key => $value
960
961Stores the given C<$value> in the family hash. Updates are delayed, if you
962want the data to be synced to disk immediately, use C<cf::db_sync>.
963
964=item cf::db_dirty
965
966Marks the database as dirty, to be updated at a later time.
967
968=item cf::db_sync
969
970Immediately write the database to disk I<if it is dirty>.
971
972=cut
973
974{
975 my $db;
976 my $path = cf::localdir . "/database.pst";
977
978 sub db_load() {
979 warn "loading database $path\n";#d# remove later
980 $db = stat $path ? Storable::retrieve $path : { };
981 }
982
983 my $pid;
984
985 sub db_save() {
986 warn "saving database $path\n";#d# remove later
987 waitpid $pid, 0 if $pid;
988 if (0 == ($pid = fork)) {
989 $db->{_meta}{version} = 1;
990 Storable::nstore $db, "$path~";
991 rename "$path~", $path;
992 cf::_exit 0 if defined $pid;
993 }
994 }
995
996 my $dirty;
997
998 sub db_sync() {
999 db_save if $dirty;
1000 undef $dirty;
1001 }
1002
1003 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub {
1004 db_sync;
1005 });
1006
1007 sub db_dirty() {
1008 $dirty = 1;
1009 $idle->start;
1010 }
1011
1012 sub db_get($;$) {
1013 @_ >= 2
1014 ? $db->{$_[0]}{$_[1]}
1015 : ($db->{$_[0]} ||= { })
1016 }
1017
1018 sub db_put($$;$) {
1019 if (@_ >= 3) {
1020 $db->{$_[0]}{$_[1]} = $_[2];
1021 } else {
1022 $db->{$_[0]} = $_[1];
1023 }
1024 db_dirty;
1025 }
1026
1027 attach_global
1028 prio => 10000,
1029 on_cleanup => sub {
1030 db_sync;
1031 },
1032 ;
1033}
1034
904############################################################################# 1035#############################################################################
905# the server's main() 1036# the server's main()
906 1037
1038sub cfg_load {
1039 open my $fh, "<:utf8", cf::confdir . "/config"
1040 or return;
1041
1042 local $/;
1043 *CFG = YAML::Syck::Load <$fh>;
1044}
1045
907sub main { 1046sub main {
1047 cfg_load;
1048 db_load;
1049 load_extensions;
908 Event::loop; 1050 Event::loop;
909} 1051}
910 1052
911############################################################################# 1053#############################################################################
912# initialisation 1054# initialisation
913 1055
1056sub _perl_reload(&) {
1057 my ($msg) = @_;
1058
1059 $msg->("reloading...");
1060
1061 eval {
1062 # cancel all watchers
1063 $_->cancel for Event::all_watchers;
1064
1065 # unload all extensions
1066 for (@exts) {
1067 $msg->("unloading <$_>");
1068 unload_extension $_;
1069 }
1070
1071 # unload all modules loaded from $LIBDIR
1072 while (my ($k, $v) = each %INC) {
1073 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1074
1075 $msg->("removing <$k>");
1076 delete $INC{$k};
1077
1078 $k =~ s/\.pm$//;
1079 $k =~ s/\//::/g;
1080
1081 if (my $cb = $k->can ("unload_module")) {
1082 $cb->();
1083 }
1084
1085 Symbol::delete_package $k;
1086 }
1087
1088 # sync database to disk
1089 cf::db_sync;
1090
1091 # get rid of safe::, as good as possible
1092 Symbol::delete_package "safe::$_"
1093 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1094
1095 # remove register_script_function callbacks
1096 # TODO
1097
1098 # unload cf.pm "a bit"
1099 delete $INC{"cf.pm"};
1100
1101 # don't, removes xs symbols, too,
1102 # and global variables created in xs
1103 #Symbol::delete_package __PACKAGE__;
1104
1105 # reload cf.pm
1106 $msg->("reloading cf.pm");
1107 require cf;
1108
1109 # load config and database again
1110 cf::cfg_load;
1111 cf::db_load;
1112
1113 # load extensions
1114 $msg->("load extensions");
1115 cf::load_extensions;
1116
1117 # reattach attachments to objects
1118 $msg->("reattach");
1119 _global_reattach;
1120 };
1121 $msg->($@) if $@;
1122
1123 $msg->("reloaded");
1124};
1125
1126sub perl_reload() {
1127 _perl_reload {
1128 warn $_[0];
1129 print "$_[0]\n";
1130 };
1131}
1132
1133register_command "perl-reload", 0, sub {
1134 my ($who, $arg) = @_;
1135
1136 if ($who->flag (FLAG_WIZ)) {
1137 _perl_reload {
1138 warn $_[0];
1139 $who->message ($_[0]);
1140 };
1141 }
1142};
1143
914register "<global>", __PACKAGE__; 1144register "<global>", __PACKAGE__;
915 1145
916unshift @INC, $LIBDIR; 1146unshift @INC, $LIBDIR;
917
918load_extensions;
919 1147
920$TICK_WATCHER = Event->timer ( 1148$TICK_WATCHER = Event->timer (
921 prio => 1, 1149 prio => 1,
922 at => $NEXT_TICK || 1, 1150 at => $NEXT_TICK || 1,
923 cb => sub { 1151 cb => sub {
… …
932 $TICK_WATCHER->at ($NEXT_TICK); 1160 $TICK_WATCHER->at ($NEXT_TICK);
933 $TICK_WATCHER->start; 1161 $TICK_WATCHER->start;
934 }, 1162 },
935); 1163);
936 1164
937_reload_2;
938
9391 11651
940 1166

Diff Legend

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