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.71 by root, Sun Oct 1 10:59:30 2006 UTC vs.
Revision 1.86 by root, Thu Dec 14 05:09:32 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 ();
11use YAML::Syck ();
10use Time::HiRes; 12use Time::HiRes;
11use Event; 13use Event;
12$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
13 15
16# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
17$YAML::Syck::ImplicitUnicode = 1;
18
14use strict; 19use strict;
15 20
21our %COMMAND = ();
22our %COMMAND_TIME = ();
23our %EXTCMD = ();
24
16_init_vars; 25_init_vars;
17 26
18our %COMMAND = ();
19our @EVENT; 27our @EVENT;
20our $LIBDIR = maps_directory "perl"; 28our $LIBDIR = maps_directory "perl";
21 29
22our $TICK = MAX_TIME * 1e-6; 30our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 31our $TICK_WATCHER;
24our $NEXT_TICK; 32our $NEXT_TICK;
25 33
26our %CFG; 34our %CFG;
27 35
36our $UPTIME; $UPTIME ||= time;
37
28############################################################################# 38#############################################################################
29 39
30=head2 GLOBAL VARIABLES 40=head2 GLOBAL VARIABLES
31 41
32=over 4 42=over 4
43
44=item $cf::UPTIME
45
46The timestamp of the server start (so not actually an uptime).
33 47
34=item $cf::LIBDIR 48=item $cf::LIBDIR
35 49
36The perl library directory, where extensions and cf-specific modules can 50The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 51be found. It will be added to C<@INC> automatically.
… …
62 76
63@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 77@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
64 78
65# we bless all objects into (empty) derived classes to force a method lookup 79# we bless all objects into (empty) derived classes to force a method lookup
66# within the Safe compartment. 80# within the Safe compartment.
67for my $pkg (qw(cf::object cf::object::player cf::player cf::map cf::party cf::region cf::arch cf::living)) { 81for my $pkg (qw(
82 cf::object cf::object::player
83 cf::client_socket cf::player
84 cf::arch cf::living
85 cf::map cf::party cf::region
86)) {
68 no strict 'refs'; 87 no strict 'refs';
69 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 88 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
70} 89}
71 90
72$Event::DIED = sub { 91$Event::DIED = sub {
… …
74}; 93};
75 94
76my %ext_pkg; 95my %ext_pkg;
77my @exts; 96my @exts;
78my @hook; 97my @hook;
79my %command;
80my %extcmd;
81 98
82=head2 UTILITY FUNCTIONS 99=head2 UTILITY FUNCTIONS
83 100
84=over 4 101=over 4
85 102
… …
514 unlink $filename; 531 unlink $filename;
515 unlink "$filename.pst"; 532 unlink "$filename.pst";
516 } 533 }
517} 534}
518 535
536sub object_freezer_as_string {
537 my ($rdata, $objs) = @_;
538
539 use Data::Dumper;
540
541 $$rdata . Dumper $objs
542}
543
519sub object_thawer_load { 544sub object_thawer_load {
520 my ($filename) = @_; 545 my ($filename) = @_;
521 546
522 local $/; 547 local $/;
523 548
… …
548 if exists $src->{_attachment}; 573 if exists $src->{_attachment};
549 }, 574 },
550; 575;
551 576
552############################################################################# 577#############################################################################
553# old plug-in events 578# command handling &c
554 579
555sub inject_event { 580=item cf::register_command $name => \&callback($ob,$args);
556 my $extension = shift;
557 my $event_code = shift;
558 581
559 my $cb = $hook[$event_code]{$extension} 582Register a callback for execution when the client sends the user command
560 or return; 583$name.
561 584
562 &$cb 585=cut
563}
564
565sub inject_global_event {
566 my $event = shift;
567
568 my $cb = $hook[$event]
569 or return;
570
571 List::Util::max map &$_, values %$cb
572}
573
574sub inject_command {
575 my ($name, $obj, $params) = @_;
576
577 for my $cmd (@{ $command{$name} }) {
578 $cmd->[1]->($obj, $params);
579 }
580
581 -1
582}
583 586
584sub register_command { 587sub register_command {
585 my ($name, $time, $cb) = @_; 588 my ($name, $cb) = @_;
586 589
587 my $caller = caller; 590 my $caller = caller;
588 #warn "registering command '$name/$time' to '$caller'"; 591 #warn "registering command '$name/$time' to '$caller'";
589 592
590 push @{ $command{$name} }, [$time, $cb, $caller]; 593 push @{ $COMMAND{$name} }, [$caller, $cb];
591 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
592} 594}
595
596=item cf::register_extcmd $name => \&callback($pl,$packet);
597
598Register a callbackf ro execution when the client sends an extcmd packet.
599
600If the callback returns something, it is sent back as if reply was being
601called.
602
603=cut
593 604
594sub register_extcmd { 605sub register_extcmd {
595 my ($name, $cb) = @_; 606 my ($name, $cb) = @_;
596 607
597 my $caller = caller; 608 my $caller = caller;
598 #warn "registering extcmd '$name' to '$caller'"; 609 #warn "registering extcmd '$name' to '$caller'";
599 610
600 $extcmd{$name} = [$cb, $caller]; 611 $EXTCMD{$name} = [$cb, $caller];
601} 612}
613
614attach_to_players
615 on_command => sub {
616 my ($pl, $name, $params) = @_;
617
618 my $cb = $COMMAND{$name}
619 or return;
620
621 for my $cmd (@$cb) {
622 $cmd->[1]->($pl->ob, $params);
623 }
624
625 cf::override;
626 },
627 on_extcmd => sub {
628 my ($pl, $buf) = @_;
629
630 my $msg = eval { from_json $buf };
631
632 if (ref $msg) {
633 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
634 if (my %reply = $cb->[0]->($pl, $msg)) {
635 $pl->ext_reply ($msg->{msgid}, %reply);
636 }
637 }
638 } else {
639 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
640 }
641
642 cf::override;
643 },
644;
602 645
603sub register { 646sub register {
604 my ($base, $pkg) = @_; 647 my ($base, $pkg) = @_;
605 648
606 #TODO 649 #TODO
… …
625 . "#line 1 \"$path\"\n{\n" 668 . "#line 1 \"$path\"\n{\n"
626 . (do { local $/; <$fh> }) 669 . (do { local $/; <$fh> })
627 . "\n};\n1"; 670 . "\n};\n1";
628 671
629 eval $source 672 eval $source
630 or die "$path: $@"; 673 or die $@ ? "$path: $@\n"
674 : "extension disabled.\n";
631 675
632 push @exts, $pkg; 676 push @exts, $pkg;
633 $ext_pkg{$base} = $pkg; 677 $ext_pkg{$base} = $pkg;
634 678
635# no strict 'refs'; 679# no strict 'refs';
… …
648# for my $idx (0 .. $#PLUGIN_EVENT) { 692# for my $idx (0 .. $#PLUGIN_EVENT) {
649# delete $hook[$idx]{$pkg}; 693# delete $hook[$idx]{$pkg};
650# } 694# }
651 695
652 # remove commands 696 # remove commands
653 for my $name (keys %command) { 697 for my $name (keys %COMMAND) {
654 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 698 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
655 699
656 if (@cb) { 700 if (@cb) {
657 $command{$name} = \@cb; 701 $COMMAND{$name} = \@cb;
658 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
659 } else { 702 } else {
660 delete $command{$name};
661 delete $COMMAND{"$name\000"}; 703 delete $COMMAND{$name};
662 } 704 }
663 } 705 }
664 706
665 # remove extcmds 707 # remove extcmds
666 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 708 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
667 delete $extcmd{$name}; 709 delete $EXTCMD{$name};
668 } 710 }
669 711
670 if (my $cb = $pkg->can ("unload")) { 712 if (my $cb = $pkg->can ("unload")) {
671 eval { 713 eval {
672 $cb->($pkg); 714 $cb->($pkg);
… …
688 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
689 } 731 }
690} 732}
691 733
692############################################################################# 734#############################################################################
693# extcmd framework, basically convert ext <msg>
694# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
695
696attach_to_players
697 on_extcmd => sub {
698 my ($pl, $buf) = @_;
699
700 my $msg = eval { from_json $buf };
701
702 if (ref $msg) {
703 if (my $cb = $extcmd{$msg->{msgtype}}) {
704 if (my %reply = $cb->[0]->($pl, $msg)) {
705 $pl->ext_reply ($msg->{msgid}, %reply);
706 }
707 }
708 } else {
709 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
710 }
711
712 cf::override;
713 },
714;
715
716#############################################################################
717# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
718 736
719*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
720 my ($map) = @_; 738 my ($map) = @_;
721 739
… …
766sub cf::player::exists($) { 784sub cf::player::exists($) {
767 cf::player::find $_[0] 785 cf::player::find $_[0]
768 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;
769} 787}
770 788
771=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
772 790
773Sends 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>
774can 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
775dialogue with the given NPC character. 793dialogue with the given NPC character.
776 794
… …
803 $msg{msgid} = $id; 821 $msg{msgid} = $id;
804 822
805 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
806} 824}
807 825
808=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}
809 841
810=cut 842=cut
811 843
812############################################################################# 844#############################################################################
813 845
… …
815 847
816Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
821 853
822=cut 854=cut
823 855
824our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
961 993
962Immediately write the database to disk I<if it is dirty>. 994Immediately write the database to disk I<if it is dirty>.
963 995
964=cut 996=cut
965 997
998our $DB;
999
966{ 1000{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 1001 my $path = cf::localdir . "/database.pst";
969 1002
970 sub db_load() { 1003 sub db_load() {
971 warn "loading database $path\n";#d# remove later 1004 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 1005 $DB = stat $path ? Storable::retrieve $path : { };
973 } 1006 }
974 1007
975 my $pid; 1008 my $pid;
976 1009
977 sub db_save() { 1010 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1011 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1012 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1013 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1014 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1015 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1016 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1017 cf::_exit 0 if defined $pid;
985 } 1018 }
986 } 1019 }
987 1020
… …
1001 $idle->start; 1034 $idle->start;
1002 } 1035 }
1003 1036
1004 sub db_get($;$) { 1037 sub db_get($;$) {
1005 @_ >= 2 1038 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1039 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1040 : ($DB->{$_[0]} ||= { })
1008 } 1041 }
1009 1042
1010 sub db_put($$;$) { 1043 sub db_put($$;$) {
1011 if (@_ >= 3) { 1044 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1045 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1046 } else {
1014 $db->{$_[0]} = $_[1]; 1047 $DB->{$_[0]} = $_[1];
1015 } 1048 }
1016 db_dirty; 1049 db_dirty;
1017 } 1050 }
1018 1051
1019 attach_global 1052 attach_global
… …
1025} 1058}
1026 1059
1027############################################################################# 1060#############################################################################
1028# the server's main() 1061# the server's main()
1029 1062
1063sub cfg_load {
1064 open my $fh, "<:utf8", cf::confdir . "/config"
1065 or return;
1066
1067 local $/;
1068 *CFG = YAML::Syck::Load <$fh>;
1069}
1070
1030sub main { 1071sub main {
1072 cfg_load;
1031 db_load; 1073 db_load;
1032 load_extensions; 1074 load_extensions;
1033 Event::loop; 1075 Event::loop;
1034} 1076}
1035 1077
… …
1087 1129
1088 # reload cf.pm 1130 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1131 $msg->("reloading cf.pm");
1090 require cf; 1132 require cf;
1091 1133
1092 # load database again 1134 # load config and database again
1135 cf::cfg_load;
1093 cf::db_load; 1136 cf::db_load;
1094 1137
1095 # load extensions 1138 # load extensions
1096 $msg->("load extensions"); 1139 $msg->("load extensions");
1097 cf::load_extensions; 1140 cf::load_extensions;
… …
1110 warn $_[0]; 1153 warn $_[0];
1111 print "$_[0]\n"; 1154 print "$_[0]\n";
1112 }; 1155 };
1113} 1156}
1114 1157
1158register "<global>", __PACKAGE__;
1159
1115register_command "perl-reload", 0, sub { 1160register_command "perl-reload" => sub {
1116 my ($who, $arg) = @_; 1161 my ($who, $arg) = @_;
1117 1162
1118 if ($who->flag (FLAG_WIZ)) { 1163 if ($who->flag (FLAG_WIZ)) {
1119 _perl_reload { 1164 _perl_reload {
1120 warn $_[0]; 1165 warn $_[0];
1121 $who->message ($_[0]); 1166 $who->message ($_[0]);
1122 }; 1167 };
1123 } 1168 }
1124}; 1169};
1125 1170
1126register "<global>", __PACKAGE__;
1127
1128unshift @INC, $LIBDIR; 1171unshift @INC, $LIBDIR;
1129 1172
1130$TICK_WATCHER = Event->timer ( 1173$TICK_WATCHER = Event->timer (
1131 prio => 1, 1174 prio => 1,
1175 async => 1,
1132 at => $NEXT_TICK || 1, 1176 at => $NEXT_TICK || 1,
1133 cb => sub { 1177 cb => sub {
1134 cf::server_tick; # one server iteration 1178 cf::server_tick; # one server iteration
1135 1179
1136 my $NOW = Event::time; 1180 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1181 $NEXT_TICK += $TICK;
1138 1182
1139 # if we are delayed by four ticks, skip them all 1183 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1184 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1185
1142 $TICK_WATCHER->at ($NEXT_TICK); 1186 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1187 $TICK_WATCHER->start;
1144 }, 1188 },
1145); 1189);
1146 1190
1191IO::AIO::max_poll_time $TICK * 0.2;
1192
1193Event->io (fd => IO::AIO::poll_fileno,
1194 poll => 'r',
1195 prio => 5,
1196 cb => \&IO::AIO::poll_cb);
1197
11471 11981
1148 1199

Diff Legend

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