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.75 by root, Mon Oct 2 00:22:01 2006 UTC vs.
Revision 1.87 by root, Thu Dec 14 22:45:40 2006 UTC

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

Diff Legend

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