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.77 by root, Sun Nov 5 11:13:01 2006 UTC vs.
Revision 1.90 by root, Sat Dec 16 04:22:13 2006 UTC

… …
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1; 17$YAML::Syck::ImplicitUnicode = 1;
18 18
19use strict; 19use strict;
20 20
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
21_init_vars; 27_init_vars;
22 28
23our %COMMAND = ();
24our @EVENT; 29our @EVENT;
25our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
26 31
27our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
28our $TICK_WATCHER; 33our $TICK_WATCHER;
29our $NEXT_TICK; 34our $NEXT_TICK;
30 35
31our %CFG; 36our %CFG;
32 37
33our $uptime; 38our $UPTIME; $UPTIME ||= time;
34
35$uptime ||= time;
36 39
37############################################################################# 40#############################################################################
38 41
39=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
40 43
41=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
42 49
43=item $cf::LIBDIR 50=item $cf::LIBDIR
44 51
45The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
46be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
71 78
72@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
73 80
74# 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
75# within the Safe compartment. 82# within the Safe compartment.
76for 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 cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
77 no strict 'refs'; 89 no strict 'refs';
78 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
79} 91}
80 92
81$Event::DIED = sub { 93$Event::DIED = sub {
… …
83}; 95};
84 96
85my %ext_pkg; 97my %ext_pkg;
86my @exts; 98my @exts;
87my @hook; 99my @hook;
88my %command;
89my %extcmd;
90 100
91=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
92 102
93=over 4 103=over 4
94 104
… …
523 unlink $filename; 533 unlink $filename;
524 unlink "$filename.pst"; 534 unlink "$filename.pst";
525 } 535 }
526} 536}
527 537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
544}
545
528sub object_thawer_load { 546sub object_thawer_load {
529 my ($filename) = @_; 547 my ($filename) = @_;
530 548
531 local $/; 549 local $/;
532 550
… …
557 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
558 }, 576 },
559; 577;
560 578
561############################################################################# 579#############################################################################
562# old plug-in events 580# command handling &c
563 581
564sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
565 my $extension = shift;
566 my $event_code = shift;
567 583
568 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
569 or return; 585$name.
570 586
571 &$cb 587=cut
572}
573
574sub inject_global_event {
575 my $event = shift;
576
577 my $cb = $hook[$event]
578 or return;
579
580 List::Util::max map &$_, values %$cb
581}
582
583sub inject_command {
584 my ($name, $obj, $params) = @_;
585
586 for my $cmd (@{ $command{$name} }) {
587 $cmd->[1]->($obj, $params);
588 }
589
590 -1
591}
592 588
593sub register_command { 589sub register_command {
594 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
595 591
596 my $caller = caller; 592 my $caller = caller;
597 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
598 594
599 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
600 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
601} 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
602 606
603sub register_extcmd { 607sub register_extcmd {
604 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
605 609
606 my $caller = caller; 610 my $caller = caller;
607 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
608 612
609 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
610} 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;
611 647
612sub register { 648sub register {
613 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
614 650
615 #TODO 651 #TODO
… …
634 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
635 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
636 . "\n};\n1"; 672 . "\n};\n1";
637 673
638 eval $source 674 eval $source
639 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
640 677
641 push @exts, $pkg; 678 push @exts, $pkg;
642 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
643 680
644# no strict 'refs'; 681# no strict 'refs';
… …
657# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
658# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
659# } 696# }
660 697
661 # remove commands 698 # remove commands
662 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
663 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
664 701
665 if (@cb) { 702 if (@cb) {
666 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
667 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
668 } else { 704 } else {
669 delete $command{$name};
670 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
671 } 706 }
672 } 707 }
673 708
674 # remove extcmds 709 # remove extcmds
675 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
676 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
677 } 712 }
678 713
679 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
680 eval { 715 eval {
681 $cb->($pkg); 716 $cb->($pkg);
… …
685 720
686 Symbol::delete_package $pkg; 721 Symbol::delete_package $pkg;
687} 722}
688 723
689sub load_extensions { 724sub load_extensions {
690 my $LIBDIR = maps_directory "perl";
691
692 for my $ext (<$LIBDIR/*.ext>) { 725 for my $ext (<$LIBDIR/*.ext>) {
693 next unless -r $ext; 726 next unless -r $ext;
694 eval { 727 eval {
695 load_extension $ext; 728 load_extension $ext;
696 1 729 1
697 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
698 } 731 }
699} 732}
700 733
701############################################################################# 734#############################################################################
702# extcmd framework, basically convert ext <msg>
703# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
704
705attach_to_players
706 on_extcmd => sub {
707 my ($pl, $buf) = @_;
708
709 my $msg = eval { from_json $buf };
710
711 if (ref $msg) {
712 if (my $cb = $extcmd{$msg->{msgtype}}) {
713 if (my %reply = $cb->[0]->($pl, $msg)) {
714 $pl->ext_reply ($msg->{msgid}, %reply);
715 }
716 }
717 } else {
718 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
719 }
720
721 cf::override;
722 },
723;
724
725#############################################################################
726# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
727 736
728*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
729 my ($map) = @_; 738 my ($map) = @_;
730 739
… …
775sub cf::player::exists($) { 784sub cf::player::exists($) {
776 cf::player::find $_[0] 785 cf::player::find $_[0]
777 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 786 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
778} 787}
779 788
780=item $object->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
781 790
782Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 791Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
783can be C<undef>. Does the right thing when the player is currently in a 792can be C<undef>. Does the right thing when the player is currently in a
784dialogue with the given NPC character. 793dialogue with the given NPC character.
785 794
… …
812 $msg{msgid} = $id; 821 $msg{msgid} = $id;
813 822
814 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
815} 824}
816 825
817=back 826=item $player_object->may ("access")
827
828Returns wether the given player is authorized to access resource "access"
829(e.g. "command_wizcast").
830
831=cut
832
833sub cf::object::player::may {
834 my ($self, $access) = @_;
835
836 $self->flag (cf::FLAG_WIZ) ||
837 (ref $cf::CFG{"may_$access"}
838 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
839 : $cf::CFG{"may_$access"})
840}
818 841
819=cut 842=cut
820 843
821############################################################################# 844#############################################################################
822 845
… …
824 847
825Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
826snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
827itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
828is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
829functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
830 853
831=cut 854=cut
832 855
833our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
834our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
970 993
971Immediately write the database to disk I<if it is dirty>. 994Immediately write the database to disk I<if it is dirty>.
972 995
973=cut 996=cut
974 997
998our $DB;
999
975{ 1000{
976 my $db;
977 my $path = cf::localdir . "/database.pst"; 1001 my $path = cf::localdir . "/database.pst";
978 1002
979 sub db_load() { 1003 sub db_load() {
980 warn "loading database $path\n";#d# remove later 1004 warn "loading database $path\n";#d# remove later
981 $db = stat $path ? Storable::retrieve $path : { }; 1005 $DB = stat $path ? Storable::retrieve $path : { };
982 } 1006 }
983 1007
984 my $pid; 1008 my $pid;
985 1009
986 sub db_save() { 1010 sub db_save() {
987 warn "saving database $path\n";#d# remove later 1011 warn "saving database $path\n";#d# remove later
988 waitpid $pid, 0 if $pid; 1012 waitpid $pid, 0 if $pid;
989 if (0 == ($pid = fork)) { 1013 if (0 == ($pid = fork)) {
990 $db->{_meta}{version} = 1; 1014 $DB->{_meta}{version} = 1;
991 Storable::nstore $db, "$path~"; 1015 Storable::nstore $DB, "$path~";
992 rename "$path~", $path; 1016 rename "$path~", $path;
993 cf::_exit 0 if defined $pid; 1017 cf::_exit 0 if defined $pid;
994 } 1018 }
995 } 1019 }
996 1020
… …
999 sub db_sync() { 1023 sub db_sync() {
1000 db_save if $dirty; 1024 db_save if $dirty;
1001 undef $dirty; 1025 undef $dirty;
1002 } 1026 }
1003 1027
1004 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1028 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1005 db_sync; 1029 db_sync;
1006 }); 1030 });
1007 1031
1008 sub db_dirty() { 1032 sub db_dirty() {
1009 $dirty = 1; 1033 $dirty = 1;
1010 $idle->start; 1034 $idle->start;
1011 } 1035 }
1012 1036
1013 sub db_get($;$) { 1037 sub db_get($;$) {
1014 @_ >= 2 1038 @_ >= 2
1015 ? $db->{$_[0]}{$_[1]} 1039 ? $DB->{$_[0]}{$_[1]}
1016 : ($db->{$_[0]} ||= { }) 1040 : ($DB->{$_[0]} ||= { })
1017 } 1041 }
1018 1042
1019 sub db_put($$;$) { 1043 sub db_put($$;$) {
1020 if (@_ >= 3) { 1044 if (@_ >= 3) {
1021 $db->{$_[0]}{$_[1]} = $_[2]; 1045 $DB->{$_[0]}{$_[1]} = $_[2];
1022 } else { 1046 } else {
1023 $db->{$_[0]} = $_[1]; 1047 $DB->{$_[0]} = $_[1];
1024 } 1048 }
1025 db_dirty; 1049 db_dirty;
1026 } 1050 }
1027 1051
1028 attach_global 1052 attach_global
… …
1059 1083
1060 $msg->("reloading..."); 1084 $msg->("reloading...");
1061 1085
1062 eval { 1086 eval {
1063 # cancel all watchers 1087 # cancel all watchers
1064 $_->cancel for Event::all_watchers; 1088 for (Event::all_watchers) {
1089 $_->cancel if $_->data & WF_AUTOCANCEL;
1090 }
1065 1091
1066 # unload all extensions 1092 # unload all extensions
1067 for (@exts) { 1093 for (@exts) {
1068 $msg->("unloading <$_>"); 1094 $msg->("unloading <$_>");
1069 unload_extension $_; 1095 unload_extension $_;
… …
1129 warn $_[0]; 1155 warn $_[0];
1130 print "$_[0]\n"; 1156 print "$_[0]\n";
1131 }; 1157 };
1132} 1158}
1133 1159
1160register "<global>", __PACKAGE__;
1161
1134register_command "perl-reload", 0, sub { 1162register_command "perl-reload" => sub {
1135 my ($who, $arg) = @_; 1163 my ($who, $arg) = @_;
1136 1164
1137 if ($who->flag (FLAG_WIZ)) { 1165 if ($who->flag (FLAG_WIZ)) {
1138 _perl_reload { 1166 _perl_reload {
1139 warn $_[0]; 1167 warn $_[0];
1140 $who->message ($_[0]); 1168 $who->message ($_[0]);
1141 }; 1169 };
1142 } 1170 }
1143}; 1171};
1144 1172
1145register "<global>", __PACKAGE__;
1146
1147unshift @INC, $LIBDIR; 1173unshift @INC, $LIBDIR;
1148 1174
1149$TICK_WATCHER = Event->timer ( 1175$TICK_WATCHER = Event->timer (
1150 prio => 1, 1176 prio => 0,
1151 async => 1,
1152 at => $NEXT_TICK || 1, 1177 at => $NEXT_TICK || 1,
1178 data => WF_AUTOCANCEL,
1153 cb => sub { 1179 cb => sub {
1154 cf::server_tick; # one server iteration 1180 cf::server_tick; # one server iteration
1155 1181
1156 my $NOW = Event::time; 1182 my $NOW = Event::time;
1157 $NEXT_TICK += $TICK; 1183 $NEXT_TICK += $TICK;
1158 1184
1159 # if we are delayed by four ticks, skip them all 1185 # if we are delayed by four ticks or more, skip them all
1160 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1186 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1161 1187
1162 $TICK_WATCHER->at ($NEXT_TICK); 1188 $TICK_WATCHER->at ($NEXT_TICK);
1163 $TICK_WATCHER->start; 1189 $TICK_WATCHER->start;
1164 }, 1190 },
… …
1167IO::AIO::max_poll_time $TICK * 0.2; 1193IO::AIO::max_poll_time $TICK * 0.2;
1168 1194
1169Event->io (fd => IO::AIO::poll_fileno, 1195Event->io (fd => IO::AIO::poll_fileno,
1170 poll => 'r', 1196 poll => 'r',
1171 prio => 5, 1197 prio => 5,
1198 data => WF_AUTOCANCEL,
1172 cb => \&IO::AIO::poll_cb); 1199 cb => \&IO::AIO::poll_cb);
1173 1200
11741 12011
1175 1202

Diff Legend

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