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.59 by root, Wed Aug 30 16:30:37 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
… …
478} 482}
479 483
480sub object_freezer_save { 484sub object_freezer_save {
481 my ($filename, $rdata, $objs) = @_; 485 my ($filename, $rdata, $objs) = @_;
482 486
487 if (length $$rdata) {
488 warn sprintf "saving %s (%d,%d)\n",
489 $filename, length $$rdata, scalar @$objs;
490
483 if (open my $fh, ">:raw", "$filename~") { 491 if (open my $fh, ">:raw", "$filename~") {
484 chmod SAVE_MODE, $fh;
485 syswrite $fh, $$rdata;
486 close $fh;
487
488 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
489 chmod SAVE_MODE, $fh; 492 chmod SAVE_MODE, $fh;
490 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 493 syswrite $fh, $$rdata;
491 close $fh; 494 close $fh;
495
496 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
497 chmod SAVE_MODE, $fh;
498 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
499 close $fh;
492 rename "$filename.pst~", "$filename.pst"; 500 rename "$filename.pst~", "$filename.pst";
501 } else {
502 unlink "$filename.pst";
503 }
504
505 rename "$filename~", $filename;
493 } else { 506 } else {
494 unlink "$filename.pst"; 507 warn "FATAL: $filename~: $!\n";
495 } 508 }
496
497 rename "$filename~", $filename;
498 } else { 509 } else {
499 warn "FATAL: $filename~: $!\n"; 510 unlink $filename;
511 unlink "$filename.pst";
500 } 512 }
501} 513}
502 514
503sub object_thawer_load { 515sub object_thawer_load {
504 my ($filename) = @_; 516 my ($filename) = @_;
505 517
518 local $/;
519
520 my $av;
521
522 #TODO: use sysread etc.
523 if (open my $data, "<:raw:perlio", $filename) {
524 $data = <$data>;
506 open my $fh, "<:raw:perlio", "$filename.pst" 525 if (open my $pst, "<:raw:perlio", "$filename.pst") {
507 or return; 526 $av = eval { (Storable::thaw <$pst>)->{objs} };
527 }
528 return ($data, $av);
529 }
508 530
509 eval { local $/; (Storable::thaw <$fh>)->{objs} } 531 ()
510} 532}
511 533
512attach_to_objects 534attach_to_objects
513 prio => -1000000, 535 prio => -1000000,
514 on_clone => sub { 536 on_clone => sub {
… …
660 load_extension $ext; 682 load_extension $ext;
661 1 683 1
662 } or warn "$ext not loaded: $@"; 684 } or warn "$ext not loaded: $@";
663 } 685 }
664} 686}
665
666sub _perl_reload(&) {
667 my ($msg) = @_;
668
669 $msg->("reloading...");
670
671 eval {
672 # 1. cancel all watchers
673 $_->cancel for Event::all_watchers;
674
675 # 2. unload all extensions
676 for (@exts) {
677 $msg->("unloading <$_>");
678 unload_extension $_;
679 }
680
681 # 3. unload all modules loaded from $LIBDIR
682 while (my ($k, $v) = each %INC) {
683 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
684
685 $msg->("removing <$k>");
686 delete $INC{$k};
687
688 $k =~ s/\.pm$//;
689 $k =~ s/\//::/g;
690
691 if (my $cb = $k->can ("unload_module")) {
692 $cb->();
693 }
694
695 Symbol::delete_package $k;
696 }
697
698 # 4. get rid of safe::, as good as possible
699 Symbol::delete_package "safe::$_"
700 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
701
702 # 5. remove register_script_function callbacks
703 # TODO
704
705 # 6. unload cf.pm "a bit"
706 delete $INC{"cf.pm"};
707
708 # don't, removes xs symbols, too,
709 # and global variables created in xs
710 #Symbol::delete_package __PACKAGE__;
711
712 # 7. reload cf.pm
713 $msg->("reloading cf.pm");
714 require cf;
715 };
716 $msg->($@) if $@;
717
718 $msg->("reloaded");
719};
720
721sub perl_reload() {
722 _perl_reload {
723 warn $_[0];
724 print "$_[0]\n";
725 };
726}
727
728register_command "perl-reload", 0, sub {
729 my ($who, $arg) = @_;
730
731 if ($who->flag (FLAG_WIZ)) {
732 _perl_reload {
733 warn $_[0];
734 $who->message ($_[0]);
735 };
736 }
737};
738 687
739############################################################################# 688#############################################################################
740# extcmd framework, basically convert ext <msg> 689# extcmd framework, basically convert ext <msg>
741# into pkg::->on_extcmd_arg1 (...) while shortcutting a few 690# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
742 691
… …
779 728
780sub all_objects(@) { 729sub all_objects(@) {
781 @_, map all_objects ($_->inv), @_ 730 @_, map all_objects ($_->inv), @_
782} 731}
783 732
733# TODO: compatibility cruft, remove when no longer needed
784attach_to_players 734attach_to_players
785 on_load => sub { 735 on_load => sub {
786 my ($pl, $path) = @_; 736 my ($pl, $path) = @_;
787 737
788 for my $o (all_objects $pl->ob) { 738 for my $o (all_objects $pl->ob) {
… …
794 } 744 }
795 }, 745 },
796; 746;
797 747
798############################################################################# 748#############################################################################
799# core extensions - in perl 749
750=head2 CORE EXTENSIONS
751
752Functions and methods that extend core crossfire objects.
753
754=over 4
800 755
801=item cf::player::exists $login 756=item cf::player::exists $login
802 757
803Returns true when the given account exists. 758Returns true when the given account exists.
804 759
… …
844 $msg{msgid} = $id; 799 $msg{msgid} = $id;
845 800
846 $self->send ("ext " . to_json \%msg); 801 $self->send ("ext " . to_json \%msg);
847} 802}
848 803
804=back
805
806=cut
807
849############################################################################# 808#############################################################################
850# 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
851 819
852our $safe = new Safe "safe"; 820our $safe = new Safe "safe";
853our $safe_hole = new Safe::Hole; 821our $safe_hole = new Safe::Hole;
854 822
855$SIG{FPE} = 'IGNORE'; 823$SIG{FPE} = 'IGNORE';
856 824
857$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));
858 826
859# 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
860 838
861for ( 839for (
862 ["cf::object" => qw(contr pay_amount pay_player)], 840 ["cf::object" => qw(contr pay_amount pay_player)],
863 ["cf::object::player" => qw(player)], 841 ["cf::object::player" => qw(player)],
864 ["cf::player" => qw(peaceful)], 842 ["cf::player" => qw(peaceful)],
… …
867 my ($pkg, @funs) = @$_; 845 my ($pkg, @funs) = @$_;
868 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 846 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
869 for @funs; 847 for @funs;
870} 848}
871 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
872sub safe_eval($;@) { 862sub safe_eval($;@) {
873 my ($code, %vars) = @_; 863 my ($code, %vars) = @_;
874 864
875 my $qcode = $code; 865 my $qcode = $code;
876 $qcode =~ s/"/‟/g; # not allowed in #line filenames 866 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
898 } 888 }
899 889
900 wantarray ? @res : $res[0] 890 wantarray ? @res : $res[0]
901} 891}
902 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
903sub register_script_function { 908sub register_script_function {
904 my ($fun, $cb) = @_; 909 my ($fun, $cb) = @_;
905 910
906 no strict 'refs'; 911 no strict 'refs';
907 *{"safe::$fun"} = $safe_hole->wrap ($cb); 912 *{"safe::$fun"} = $safe_hole->wrap ($cb);
908} 913}
909 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
910############################################################################# 1021#############################################################################
911# the server's main() 1022# the server's main()
912 1023
913sub main { 1024sub main {
1025 db_load;
1026 load_extensions;
914 Event::loop; 1027 Event::loop;
915} 1028}
916 1029
917############################################################################# 1030#############################################################################
918# initialisation 1031# initialisation
919 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
920register "<global>", __PACKAGE__; 1120register "<global>", __PACKAGE__;
921 1121
922unshift @INC, $LIBDIR; 1122unshift @INC, $LIBDIR;
923
924load_extensions;
925 1123
926$TICK_WATCHER = Event->timer ( 1124$TICK_WATCHER = Event->timer (
927 prio => 1, 1125 prio => 1,
928 at => $NEXT_TICK || 1, 1126 at => $NEXT_TICK || 1,
929 cb => sub { 1127 cb => sub {
… …
938 $TICK_WATCHER->at ($NEXT_TICK); 1136 $TICK_WATCHER->at ($NEXT_TICK);
939 $TICK_WATCHER->start; 1137 $TICK_WATCHER->start;
940 }, 1138 },
941); 1139);
942 1140
943_reload_2;
944
9451 11411
946 1142

Diff Legend

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