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

Diff Legend

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