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

Diff Legend

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