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.77 by root, Sun Nov 5 11:13:01 2006 UTC vs.
Revision 1.86 by root, Thu Dec 14 05:09:32 2006 UTC

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

Diff Legend

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