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.70 by root, Sun Oct 1 10:55:37 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
… …
108 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 125 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
109 JSON::Syck::Dump $_[0] 126 JSON::Syck::Dump $_[0]
110} 127}
111 128
112=back 129=back
130
131=cut
113 132
114############################################################################# 133#############################################################################
115 134
116=head2 EVENTS AND OBJECT ATTACHMENTS 135=head2 EVENTS AND OBJECT ATTACHMENTS
117 136
… …
420This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 439This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
421removed in future versions), and there is no public API to access override 440removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly). 441results (if you must, access C<@cf::invoke_results> directly).
423 442
424=back 443=back
444
445=cut
425 446
426############################################################################# 447#############################################################################
427 448
428=head2 METHODS VALID FOR ALL CORE OBJECTS 449=head2 METHODS VALID FOR ALL CORE OBJECTS
429 450
… …
510 unlink $filename; 531 unlink $filename;
511 unlink "$filename.pst"; 532 unlink "$filename.pst";
512 } 533 }
513} 534}
514 535
536sub object_freezer_as_string {
537 my ($rdata, $objs) = @_;
538
539 use Data::Dumper;
540
541 $$rdata . Dumper $objs
542}
543
515sub object_thawer_load { 544sub object_thawer_load {
516 my ($filename) = @_; 545 my ($filename) = @_;
517 546
518 local $/; 547 local $/;
519 548
… …
544 if exists $src->{_attachment}; 573 if exists $src->{_attachment};
545 }, 574 },
546; 575;
547 576
548############################################################################# 577#############################################################################
549# old plug-in events 578# command handling &c
550 579
551sub inject_event { 580=item cf::register_command $name => \&callback($ob,$args);
552 my $extension = shift;
553 my $event_code = shift;
554 581
555 my $cb = $hook[$event_code]{$extension} 582Register a callback for execution when the client sends the user command
556 or return; 583$name.
557 584
558 &$cb 585=cut
559}
560
561sub inject_global_event {
562 my $event = shift;
563
564 my $cb = $hook[$event]
565 or return;
566
567 List::Util::max map &$_, values %$cb
568}
569
570sub inject_command {
571 my ($name, $obj, $params) = @_;
572
573 for my $cmd (@{ $command{$name} }) {
574 $cmd->[1]->($obj, $params);
575 }
576
577 -1
578}
579 586
580sub register_command { 587sub register_command {
581 my ($name, $time, $cb) = @_; 588 my ($name, $cb) = @_;
582 589
583 my $caller = caller; 590 my $caller = caller;
584 #warn "registering command '$name/$time' to '$caller'"; 591 #warn "registering command '$name/$time' to '$caller'";
585 592
586 push @{ $command{$name} }, [$time, $cb, $caller]; 593 push @{ $COMMAND{$name} }, [$caller, $cb];
587 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
588} 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
589 604
590sub register_extcmd { 605sub register_extcmd {
591 my ($name, $cb) = @_; 606 my ($name, $cb) = @_;
592 607
593 my $caller = caller; 608 my $caller = caller;
594 #warn "registering extcmd '$name' to '$caller'"; 609 #warn "registering extcmd '$name' to '$caller'";
595 610
596 $extcmd{$name} = [$cb, $caller]; 611 $EXTCMD{$name} = [$cb, $caller];
597} 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;
598 645
599sub register { 646sub register {
600 my ($base, $pkg) = @_; 647 my ($base, $pkg) = @_;
601 648
602 #TODO 649 #TODO
… …
621 . "#line 1 \"$path\"\n{\n" 668 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 669 . (do { local $/; <$fh> })
623 . "\n};\n1"; 670 . "\n};\n1";
624 671
625 eval $source 672 eval $source
626 or die "$path: $@"; 673 or die $@ ? "$path: $@\n"
674 : "extension disabled.\n";
627 675
628 push @exts, $pkg; 676 push @exts, $pkg;
629 $ext_pkg{$base} = $pkg; 677 $ext_pkg{$base} = $pkg;
630 678
631# no strict 'refs'; 679# no strict 'refs';
… …
644# for my $idx (0 .. $#PLUGIN_EVENT) { 692# for my $idx (0 .. $#PLUGIN_EVENT) {
645# delete $hook[$idx]{$pkg}; 693# delete $hook[$idx]{$pkg};
646# } 694# }
647 695
648 # remove commands 696 # remove commands
649 for my $name (keys %command) { 697 for my $name (keys %COMMAND) {
650 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 698 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
651 699
652 if (@cb) { 700 if (@cb) {
653 $command{$name} = \@cb; 701 $COMMAND{$name} = \@cb;
654 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
655 } else { 702 } else {
656 delete $command{$name};
657 delete $COMMAND{"$name\000"}; 703 delete $COMMAND{$name};
658 } 704 }
659 } 705 }
660 706
661 # remove extcmds 707 # remove extcmds
662 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 708 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
663 delete $extcmd{$name}; 709 delete $EXTCMD{$name};
664 } 710 }
665 711
666 if (my $cb = $pkg->can ("unload")) { 712 if (my $cb = $pkg->can ("unload")) {
667 eval { 713 eval {
668 $cb->($pkg); 714 $cb->($pkg);
… …
684 } or warn "$ext not loaded: $@"; 730 } or warn "$ext not loaded: $@";
685 } 731 }
686} 732}
687 733
688############################################################################# 734#############################################################################
689# extcmd framework, basically convert ext <msg>
690# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
691
692attach_to_players
693 on_extcmd => sub {
694 my ($pl, $buf) = @_;
695
696 my $msg = eval { from_json $buf };
697
698 if (ref $msg) {
699 if (my $cb = $extcmd{$msg->{msgtype}}) {
700 if (my %reply = $cb->[0]->($pl, $msg)) {
701 $pl->ext_reply ($msg->{msgid}, %reply);
702 }
703 }
704 } else {
705 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
706 }
707
708 cf::override;
709 },
710;
711
712#############################################################################
713# load/save/clean perl data associated with a map 735# load/save/clean perl data associated with a map
714 736
715*cf::mapsupport::on_clean = sub { 737*cf::mapsupport::on_clean = sub {
716 my ($map) = @_; 738 my ($map) = @_;
717 739
… …
762sub cf::player::exists($) { 784sub cf::player::exists($) {
763 cf::player::find $_[0] 785 cf::player::find $_[0]
764 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;
765} 787}
766 788
767=item $player->reply ($npc, $msg[, $flags]) 789=item $player_object->reply ($npc, $msg[, $flags])
768 790
769Sends 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>
770can 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
771dialogue with the given NPC character. 793dialogue with the given NPC character.
772 794
… …
799 $msg{msgid} = $id; 821 $msg{msgid} = $id;
800 822
801 $self->send ("ext " . to_json \%msg); 823 $self->send ("ext " . to_json \%msg);
802} 824}
803 825
804=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}
805 841
806=cut 842=cut
807 843
808############################################################################# 844#############################################################################
809 845
… …
811 847
812Functions that provide a safe environment to compile and execute 848Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 849snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 850itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 851is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 852functions and methods that can be called is greatly reduced.
817 853
818=cut 854=cut
819 855
820our $safe = new Safe "safe"; 856our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 857our $safe_hole = new Safe::Hole;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 948 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 949}
914 950
915=back 951=back
916 952
953=cut
954
917############################################################################# 955#############################################################################
918 956
919=head2 EXTENSION DATABASE SUPPORT 957=head2 EXTENSION DATABASE SUPPORT
920 958
921Crossfire maintains a very simple database for extension use. It can 959Crossfire maintains a very simple database for extension use. It can
… …
955 993
956Immediately write the database to disk I<if it is dirty>. 994Immediately write the database to disk I<if it is dirty>.
957 995
958=cut 996=cut
959 997
998our $DB;
999
960{ 1000{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 1001 my $path = cf::localdir . "/database.pst";
963 1002
964 sub db_load() { 1003 sub db_load() {
965 warn "loading database $path\n";#d# remove later 1004 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1005 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1006 }
968 1007
969 my $pid; 1008 my $pid;
970 1009
971 sub db_save() { 1010 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1011 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1012 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1013 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1014 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1015 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1016 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1017 cf::_exit 0 if defined $pid;
979 } 1018 }
980 } 1019 }
981 1020
… …
995 $idle->start; 1034 $idle->start;
996 } 1035 }
997 1036
998 sub db_get($;$) { 1037 sub db_get($;$) {
999 @_ >= 2 1038 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1039 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1040 : ($DB->{$_[0]} ||= { })
1002 } 1041 }
1003 1042
1004 sub db_put($$;$) { 1043 sub db_put($$;$) {
1005 if (@_ >= 3) { 1044 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1045 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1046 } else {
1008 $db->{$_[0]} = $_[1]; 1047 $DB->{$_[0]} = $_[1];
1009 } 1048 }
1010 db_dirty; 1049 db_dirty;
1011 } 1050 }
1012 1051
1013 attach_global 1052 attach_global
… …
1019} 1058}
1020 1059
1021############################################################################# 1060#############################################################################
1022# the server's main() 1061# the server's main()
1023 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
1024sub main { 1071sub main {
1072 cfg_load;
1025 db_load; 1073 db_load;
1026 load_extensions; 1074 load_extensions;
1027 Event::loop; 1075 Event::loop;
1028} 1076}
1029 1077
… …
1081 1129
1082 # reload cf.pm 1130 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1131 $msg->("reloading cf.pm");
1084 require cf; 1132 require cf;
1085 1133
1086 # load database again 1134 # load config and database again
1135 cf::cfg_load;
1087 cf::db_load; 1136 cf::db_load;
1088 1137
1089 # load extensions 1138 # load extensions
1090 $msg->("load extensions"); 1139 $msg->("load extensions");
1091 cf::load_extensions; 1140 cf::load_extensions;
… …
1104 warn $_[0]; 1153 warn $_[0];
1105 print "$_[0]\n"; 1154 print "$_[0]\n";
1106 }; 1155 };
1107} 1156}
1108 1157
1158register "<global>", __PACKAGE__;
1159
1109register_command "perl-reload", 0, sub { 1160register_command "perl-reload" => sub {
1110 my ($who, $arg) = @_; 1161 my ($who, $arg) = @_;
1111 1162
1112 if ($who->flag (FLAG_WIZ)) { 1163 if ($who->flag (FLAG_WIZ)) {
1113 _perl_reload { 1164 _perl_reload {
1114 warn $_[0]; 1165 warn $_[0];
1115 $who->message ($_[0]); 1166 $who->message ($_[0]);
1116 }; 1167 };
1117 } 1168 }
1118}; 1169};
1119 1170
1120register "<global>", __PACKAGE__;
1121
1122unshift @INC, $LIBDIR; 1171unshift @INC, $LIBDIR;
1123 1172
1124$TICK_WATCHER = Event->timer ( 1173$TICK_WATCHER = Event->timer (
1125 prio => 1, 1174 prio => 1,
1175 async => 1,
1126 at => $NEXT_TICK || 1, 1176 at => $NEXT_TICK || 1,
1127 cb => sub { 1177 cb => sub {
1128 cf::server_tick; # one server iteration 1178 cf::server_tick; # one server iteration
1129 1179
1130 my $NOW = Event::time; 1180 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1181 $NEXT_TICK += $TICK;
1132 1182
1133 # if we are delayed by four ticks, skip them all 1183 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1184 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1185
1136 $TICK_WATCHER->at ($NEXT_TICK); 1186 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1187 $TICK_WATCHER->start;
1138 }, 1188 },
1139); 1189);
1140 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
11411 11981
1142 1199

Diff Legend

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