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.87 by root, Thu Dec 14 22:45:40 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 = maps_directory "perl";
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_socket 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);
… …
697 } or warn "$ext not loaded: $@"; 732 } or warn "$ext not loaded: $@";
698 } 733 }
699} 734}
700 735
701############################################################################# 736#############################################################################
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 737# load/save/clean perl data associated with a map
727 738
728*cf::mapsupport::on_clean = sub { 739*cf::mapsupport::on_clean = sub {
729 my ($map) = @_; 740 my ($map) = @_;
730 741
… …
775sub cf::player::exists($) { 786sub cf::player::exists($) {
776 cf::player::find $_[0] 787 cf::player::find $_[0]
777 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 788 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
778} 789}
779 790
780=item $object->reply ($npc, $msg[, $flags]) 791=item $player_object->reply ($npc, $msg[, $flags])
781 792
782Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 793Sends 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 794can be C<undef>. Does the right thing when the player is currently in a
784dialogue with the given NPC character. 795dialogue with the given NPC character.
785 796
… …
812 $msg{msgid} = $id; 823 $msg{msgid} = $id;
813 824
814 $self->send ("ext " . to_json \%msg); 825 $self->send ("ext " . to_json \%msg);
815} 826}
816 827
817=back 828=item $player_object->may ("access")
829
830Returns wether the given player is authorized to access resource "access"
831(e.g. "command_wizcast").
832
833=cut
834
835sub cf::object::player::may {
836 my ($self, $access) = @_;
837
838 $self->flag (cf::FLAG_WIZ) ||
839 (ref $cf::CFG{"may_$access"}
840 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
841 : $cf::CFG{"may_$access"})
842}
818 843
819=cut 844=cut
820 845
821############################################################################# 846#############################################################################
822 847
… …
824 849
825Functions that provide a safe environment to compile and execute 850Functions that provide a safe environment to compile and execute
826snippets of perl code without them endangering the safety of the server 851snippets of perl code without them endangering the safety of the server
827itself. Looping constructs, I/O operators and other built-in functionality 852itself. Looping constructs, I/O operators and other built-in functionality
828is not available in the safe scripting environment, and the number of 853is not available in the safe scripting environment, and the number of
829functions and methods that cna be called is greatly reduced. 854functions and methods that can be called is greatly reduced.
830 855
831=cut 856=cut
832 857
833our $safe = new Safe "safe"; 858our $safe = new Safe "safe";
834our $safe_hole = new Safe::Hole; 859our $safe_hole = new Safe::Hole;
… …
970 995
971Immediately write the database to disk I<if it is dirty>. 996Immediately write the database to disk I<if it is dirty>.
972 997
973=cut 998=cut
974 999
1000our $DB;
1001
975{ 1002{
976 my $db;
977 my $path = cf::localdir . "/database.pst"; 1003 my $path = cf::localdir . "/database.pst";
978 1004
979 sub db_load() { 1005 sub db_load() {
980 warn "loading database $path\n";#d# remove later 1006 warn "loading database $path\n";#d# remove later
981 $db = stat $path ? Storable::retrieve $path : { }; 1007 $DB = stat $path ? Storable::retrieve $path : { };
982 } 1008 }
983 1009
984 my $pid; 1010 my $pid;
985 1011
986 sub db_save() { 1012 sub db_save() {
987 warn "saving database $path\n";#d# remove later 1013 warn "saving database $path\n";#d# remove later
988 waitpid $pid, 0 if $pid; 1014 waitpid $pid, 0 if $pid;
989 if (0 == ($pid = fork)) { 1015 if (0 == ($pid = fork)) {
990 $db->{_meta}{version} = 1; 1016 $DB->{_meta}{version} = 1;
991 Storable::nstore $db, "$path~"; 1017 Storable::nstore $DB, "$path~";
992 rename "$path~", $path; 1018 rename "$path~", $path;
993 cf::_exit 0 if defined $pid; 1019 cf::_exit 0 if defined $pid;
994 } 1020 }
995 } 1021 }
996 1022
… …
999 sub db_sync() { 1025 sub db_sync() {
1000 db_save if $dirty; 1026 db_save if $dirty;
1001 undef $dirty; 1027 undef $dirty;
1002 } 1028 }
1003 1029
1004 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1030 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1005 db_sync; 1031 db_sync;
1006 }); 1032 });
1007 1033
1008 sub db_dirty() { 1034 sub db_dirty() {
1009 $dirty = 1; 1035 $dirty = 1;
1010 $idle->start; 1036 $idle->start;
1011 } 1037 }
1012 1038
1013 sub db_get($;$) { 1039 sub db_get($;$) {
1014 @_ >= 2 1040 @_ >= 2
1015 ? $db->{$_[0]}{$_[1]} 1041 ? $DB->{$_[0]}{$_[1]}
1016 : ($db->{$_[0]} ||= { }) 1042 : ($DB->{$_[0]} ||= { })
1017 } 1043 }
1018 1044
1019 sub db_put($$;$) { 1045 sub db_put($$;$) {
1020 if (@_ >= 3) { 1046 if (@_ >= 3) {
1021 $db->{$_[0]}{$_[1]} = $_[2]; 1047 $DB->{$_[0]}{$_[1]} = $_[2];
1022 } else { 1048 } else {
1023 $db->{$_[0]} = $_[1]; 1049 $DB->{$_[0]} = $_[1];
1024 } 1050 }
1025 db_dirty; 1051 db_dirty;
1026 } 1052 }
1027 1053
1028 attach_global 1054 attach_global
… …
1059 1085
1060 $msg->("reloading..."); 1086 $msg->("reloading...");
1061 1087
1062 eval { 1088 eval {
1063 # cancel all watchers 1089 # cancel all watchers
1064 $_->cancel for Event::all_watchers; 1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1065 1093
1066 # unload all extensions 1094 # unload all extensions
1067 for (@exts) { 1095 for (@exts) {
1068 $msg->("unloading <$_>"); 1096 $msg->("unloading <$_>");
1069 unload_extension $_; 1097 unload_extension $_;
… …
1129 warn $_[0]; 1157 warn $_[0];
1130 print "$_[0]\n"; 1158 print "$_[0]\n";
1131 }; 1159 };
1132} 1160}
1133 1161
1162register "<global>", __PACKAGE__;
1163
1134register_command "perl-reload", 0, sub { 1164register_command "perl-reload" => sub {
1135 my ($who, $arg) = @_; 1165 my ($who, $arg) = @_;
1136 1166
1137 if ($who->flag (FLAG_WIZ)) { 1167 if ($who->flag (FLAG_WIZ)) {
1138 _perl_reload { 1168 _perl_reload {
1139 warn $_[0]; 1169 warn $_[0];
1140 $who->message ($_[0]); 1170 $who->message ($_[0]);
1141 }; 1171 };
1142 } 1172 }
1143}; 1173};
1144 1174
1145register "<global>", __PACKAGE__;
1146
1147unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
1148 1176
1149$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
1150 prio => 1, 1178 prio => 1,
1151 async => 1, 1179 async => 1,
1152 at => $NEXT_TICK || 1, 1180 at => $NEXT_TICK || 1,
1181 data => WF_AUTOCANCEL,
1153 cb => sub { 1182 cb => sub {
1154 cf::server_tick; # one server iteration 1183 cf::server_tick; # one server iteration
1155 1184
1156 my $NOW = Event::time; 1185 my $NOW = Event::time;
1157 $NEXT_TICK += $TICK; 1186 $NEXT_TICK += $TICK;
1158 1187
1159 # if we are delayed by four ticks, skip them all 1188 # if we are delayed by four ticks or more, skip them all
1160 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1189 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1161 1190
1162 $TICK_WATCHER->at ($NEXT_TICK); 1191 $TICK_WATCHER->at ($NEXT_TICK);
1163 $TICK_WATCHER->start; 1192 $TICK_WATCHER->start;
1164 }, 1193 },
… …
1167IO::AIO::max_poll_time $TICK * 0.2; 1196IO::AIO::max_poll_time $TICK * 0.2;
1168 1197
1169Event->io (fd => IO::AIO::poll_fileno, 1198Event->io (fd => IO::AIO::poll_fileno,
1170 poll => 'r', 1199 poll => 'r',
1171 prio => 5, 1200 prio => 5,
1201 data => WF_AUTOCANCEL,
1172 cb => \&IO::AIO::poll_cb); 1202 cb => \&IO::AIO::poll_cb);
1173 1203
11741 12041
1175 1205

Diff Legend

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