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.85 by root, Mon Dec 11 22:56:57 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.
… …
74}; 88};
75 89
76my %ext_pkg; 90my %ext_pkg;
77my @exts; 91my @exts;
78my @hook; 92my @hook;
79my %command;
80my %extcmd;
81 93
82=head2 UTILITY FUNCTIONS 94=head2 UTILITY FUNCTIONS
83 95
84=over 4 96=over 4
85 97
… …
514 unlink $filename; 526 unlink $filename;
515 unlink "$filename.pst"; 527 unlink "$filename.pst";
516 } 528 }
517} 529}
518 530
531sub object_freezer_as_string {
532 my ($rdata, $objs) = @_;
533
534 use Data::Dumper;
535
536 $$rdata . Dumper $objs
537}
538
519sub object_thawer_load { 539sub object_thawer_load {
520 my ($filename) = @_; 540 my ($filename) = @_;
521 541
522 local $/; 542 local $/;
523 543
… …
548 if exists $src->{_attachment}; 568 if exists $src->{_attachment};
549 }, 569 },
550; 570;
551 571
552############################################################################# 572#############################################################################
553# old plug-in events 573# command handling &c
554 574
555sub inject_event { 575=item cf::register_command $name => \&callback($ob,$args);
556 my $extension = shift;
557 my $event_code = shift;
558 576
559 my $cb = $hook[$event_code]{$extension} 577Register a callback for execution when the client sends the user command
560 or return; 578$name.
561 579
562 &$cb 580=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 581
584sub register_command { 582sub register_command {
585 my ($name, $time, $cb) = @_; 583 my ($name, $cb) = @_;
586 584
587 my $caller = caller; 585 my $caller = caller;
588 #warn "registering command '$name/$time' to '$caller'"; 586 #warn "registering command '$name/$time' to '$caller'";
589 587
590 push @{ $command{$name} }, [$time, $cb, $caller]; 588 push @{ $COMMAND{$name} }, [$caller, $cb];
591 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
592} 589}
590
591=item cf::register_extcmd $name => \&callback($pl,$packet);
592
593Register a callbackf ro execution when the client sends an extcmd packet.
594
595If the callback returns something, it is sent back as if reply was being
596called.
597
598=cut
593 599
594sub register_extcmd { 600sub register_extcmd {
595 my ($name, $cb) = @_; 601 my ($name, $cb) = @_;
596 602
597 my $caller = caller; 603 my $caller = caller;
598 #warn "registering extcmd '$name' to '$caller'"; 604 #warn "registering extcmd '$name' to '$caller'";
599 605
600 $extcmd{$name} = [$cb, $caller]; 606 $EXTCMD{$name} = [$cb, $caller];
601} 607}
608
609attach_to_players
610 on_command => sub {
611 my ($pl, $name, $params) = @_;
612
613 my $cb = $COMMAND{$name}
614 or return;
615
616 for my $cmd (@$cb) {
617 $cmd->[1]->($pl->ob, $params);
618 }
619
620 cf::override;
621 },
622 on_extcmd => sub {
623 my ($pl, $buf) = @_;
624
625 my $msg = eval { from_json $buf };
626
627 if (ref $msg) {
628 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
629 if (my %reply = $cb->[0]->($pl, $msg)) {
630 $pl->ext_reply ($msg->{msgid}, %reply);
631 }
632 }
633 } else {
634 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
635 }
636
637 cf::override;
638 },
639;
602 640
603sub register { 641sub register {
604 my ($base, $pkg) = @_; 642 my ($base, $pkg) = @_;
605 643
606 #TODO 644 #TODO
… …
625 . "#line 1 \"$path\"\n{\n" 663 . "#line 1 \"$path\"\n{\n"
626 . (do { local $/; <$fh> }) 664 . (do { local $/; <$fh> })
627 . "\n};\n1"; 665 . "\n};\n1";
628 666
629 eval $source 667 eval $source
630 or die "$path: $@"; 668 or die $@ ? "$path: $@\n"
669 : "extension disabled.\n";
631 670
632 push @exts, $pkg; 671 push @exts, $pkg;
633 $ext_pkg{$base} = $pkg; 672 $ext_pkg{$base} = $pkg;
634 673
635# no strict 'refs'; 674# no strict 'refs';
… …
648# for my $idx (0 .. $#PLUGIN_EVENT) { 687# for my $idx (0 .. $#PLUGIN_EVENT) {
649# delete $hook[$idx]{$pkg}; 688# delete $hook[$idx]{$pkg};
650# } 689# }
651 690
652 # remove commands 691 # remove commands
653 for my $name (keys %command) { 692 for my $name (keys %COMMAND) {
654 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 693 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
655 694
656 if (@cb) { 695 if (@cb) {
657 $command{$name} = \@cb; 696 $COMMAND{$name} = \@cb;
658 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
659 } else { 697 } else {
660 delete $command{$name};
661 delete $COMMAND{"$name\000"}; 698 delete $COMMAND{$name};
662 } 699 }
663 } 700 }
664 701
665 # remove extcmds 702 # remove extcmds
666 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 703 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
667 delete $extcmd{$name}; 704 delete $EXTCMD{$name};
668 } 705 }
669 706
670 if (my $cb = $pkg->can ("unload")) { 707 if (my $cb = $pkg->can ("unload")) {
671 eval { 708 eval {
672 $cb->($pkg); 709 $cb->($pkg);
… …
688 } or warn "$ext not loaded: $@"; 725 } or warn "$ext not loaded: $@";
689 } 726 }
690} 727}
691 728
692############################################################################# 729#############################################################################
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 730# load/save/clean perl data associated with a map
718 731
719*cf::mapsupport::on_clean = sub { 732*cf::mapsupport::on_clean = sub {
720 my ($map) = @_; 733 my ($map) = @_;
721 734
… …
766sub cf::player::exists($) { 779sub cf::player::exists($) {
767 cf::player::find $_[0] 780 cf::player::find $_[0]
768 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 781 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
769} 782}
770 783
771=item $player->reply ($npc, $msg[, $flags]) 784=item $player_object->reply ($npc, $msg[, $flags])
772 785
773Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 786Sends 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 787can be C<undef>. Does the right thing when the player is currently in a
775dialogue with the given NPC character. 788dialogue with the given NPC character.
776 789
… …
803 $msg{msgid} = $id; 816 $msg{msgid} = $id;
804 817
805 $self->send ("ext " . to_json \%msg); 818 $self->send ("ext " . to_json \%msg);
806} 819}
807 820
808=back 821=item $player_object->may ("access")
822
823Returns wether the given player is authorized to access resource "access"
824(e.g. "command_wizcast").
825
826=cut
827
828sub cf::object::player::may {
829 my ($self, $access) = @_;
830
831 $self->flag (cf::FLAG_WIZ) ||
832 (ref $cf::CFG{"may_$access"}
833 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
834 : $cf::CFG{"may_$access"})
835}
809 836
810=cut 837=cut
811 838
812############################################################################# 839#############################################################################
813 840
… …
815 842
816Functions that provide a safe environment to compile and execute 843Functions that provide a safe environment to compile and execute
817snippets of perl code without them endangering the safety of the server 844snippets of perl code without them endangering the safety of the server
818itself. Looping constructs, I/O operators and other built-in functionality 845itself. Looping constructs, I/O operators and other built-in functionality
819is not available in the safe scripting environment, and the number of 846is not available in the safe scripting environment, and the number of
820functions and methods that cna be called is greatly reduced. 847functions and methods that can be called is greatly reduced.
821 848
822=cut 849=cut
823 850
824our $safe = new Safe "safe"; 851our $safe = new Safe "safe";
825our $safe_hole = new Safe::Hole; 852our $safe_hole = new Safe::Hole;
… …
961 988
962Immediately write the database to disk I<if it is dirty>. 989Immediately write the database to disk I<if it is dirty>.
963 990
964=cut 991=cut
965 992
993our $DB;
994
966{ 995{
967 my $db;
968 my $path = cf::localdir . "/database.pst"; 996 my $path = cf::localdir . "/database.pst";
969 997
970 sub db_load() { 998 sub db_load() {
971 warn "loading database $path\n";#d# remove later 999 warn "loading database $path\n";#d# remove later
972 $db = stat $path ? Storable::retrieve $path : { }; 1000 $DB = stat $path ? Storable::retrieve $path : { };
973 } 1001 }
974 1002
975 my $pid; 1003 my $pid;
976 1004
977 sub db_save() { 1005 sub db_save() {
978 warn "saving database $path\n";#d# remove later 1006 warn "saving database $path\n";#d# remove later
979 waitpid $pid, 0 if $pid; 1007 waitpid $pid, 0 if $pid;
980 if (0 == ($pid = fork)) { 1008 if (0 == ($pid = fork)) {
981 $db->{_meta}{version} = 1; 1009 $DB->{_meta}{version} = 1;
982 Storable::nstore $db, "$path~"; 1010 Storable::nstore $DB, "$path~";
983 rename "$path~", $path; 1011 rename "$path~", $path;
984 cf::_exit 0 if defined $pid; 1012 cf::_exit 0 if defined $pid;
985 } 1013 }
986 } 1014 }
987 1015
… …
1001 $idle->start; 1029 $idle->start;
1002 } 1030 }
1003 1031
1004 sub db_get($;$) { 1032 sub db_get($;$) {
1005 @_ >= 2 1033 @_ >= 2
1006 ? $db->{$_[0]}{$_[1]} 1034 ? $DB->{$_[0]}{$_[1]}
1007 : ($db->{$_[0]} ||= { }) 1035 : ($DB->{$_[0]} ||= { })
1008 } 1036 }
1009 1037
1010 sub db_put($$;$) { 1038 sub db_put($$;$) {
1011 if (@_ >= 3) { 1039 if (@_ >= 3) {
1012 $db->{$_[0]}{$_[1]} = $_[2]; 1040 $DB->{$_[0]}{$_[1]} = $_[2];
1013 } else { 1041 } else {
1014 $db->{$_[0]} = $_[1]; 1042 $DB->{$_[0]} = $_[1];
1015 } 1043 }
1016 db_dirty; 1044 db_dirty;
1017 } 1045 }
1018 1046
1019 attach_global 1047 attach_global
… …
1025} 1053}
1026 1054
1027############################################################################# 1055#############################################################################
1028# the server's main() 1056# the server's main()
1029 1057
1058sub cfg_load {
1059 open my $fh, "<:utf8", cf::confdir . "/config"
1060 or return;
1061
1062 local $/;
1063 *CFG = YAML::Syck::Load <$fh>;
1064}
1065
1030sub main { 1066sub main {
1067 cfg_load;
1031 db_load; 1068 db_load;
1032 load_extensions; 1069 load_extensions;
1033 Event::loop; 1070 Event::loop;
1034} 1071}
1035 1072
… …
1087 1124
1088 # reload cf.pm 1125 # reload cf.pm
1089 $msg->("reloading cf.pm"); 1126 $msg->("reloading cf.pm");
1090 require cf; 1127 require cf;
1091 1128
1092 # load database again 1129 # load config and database again
1130 cf::cfg_load;
1093 cf::db_load; 1131 cf::db_load;
1094 1132
1095 # load extensions 1133 # load extensions
1096 $msg->("load extensions"); 1134 $msg->("load extensions");
1097 cf::load_extensions; 1135 cf::load_extensions;
… …
1110 warn $_[0]; 1148 warn $_[0];
1111 print "$_[0]\n"; 1149 print "$_[0]\n";
1112 }; 1150 };
1113} 1151}
1114 1152
1153register "<global>", __PACKAGE__;
1154
1115register_command "perl-reload", 0, sub { 1155register_command "perl-reload" => sub {
1116 my ($who, $arg) = @_; 1156 my ($who, $arg) = @_;
1117 1157
1118 if ($who->flag (FLAG_WIZ)) { 1158 if ($who->flag (FLAG_WIZ)) {
1119 _perl_reload { 1159 _perl_reload {
1120 warn $_[0]; 1160 warn $_[0];
1121 $who->message ($_[0]); 1161 $who->message ($_[0]);
1122 }; 1162 };
1123 } 1163 }
1124}; 1164};
1125 1165
1126register "<global>", __PACKAGE__;
1127
1128unshift @INC, $LIBDIR; 1166unshift @INC, $LIBDIR;
1129 1167
1130$TICK_WATCHER = Event->timer ( 1168$TICK_WATCHER = Event->timer (
1131 prio => 1, 1169 prio => 1,
1170 async => 1,
1132 at => $NEXT_TICK || 1, 1171 at => $NEXT_TICK || 1,
1133 cb => sub { 1172 cb => sub {
1134 cf::server_tick; # one server iteration 1173 cf::server_tick; # one server iteration
1135 1174
1136 my $NOW = Event::time; 1175 my $NOW = Event::time;
1137 $NEXT_TICK += $TICK; 1176 $NEXT_TICK += $TICK;
1138 1177
1139 # if we are delayed by four ticks, skip them all 1178 # if we are delayed by four ticks or more, skip them all
1140 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1179 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1141 1180
1142 $TICK_WATCHER->at ($NEXT_TICK); 1181 $TICK_WATCHER->at ($NEXT_TICK);
1143 $TICK_WATCHER->start; 1182 $TICK_WATCHER->start;
1144 }, 1183 },
1145); 1184);
1146 1185
1186IO::AIO::max_poll_time $TICK * 0.2;
1187
1188Event->io (fd => IO::AIO::poll_fileno,
1189 poll => 'r',
1190 prio => 5,
1191 cb => \&IO::AIO::poll_cb);
1192
11471 11931
1148 1194

Diff Legend

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