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

Diff Legend

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