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.57 by root, Wed Aug 30 11:21:24 2006 UTC vs.
Revision 1.70 by root, Sun Oct 1 10:55:37 2006 UTC

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

Diff Legend

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