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.85 by root, Mon Dec 11 22:56:57 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.
… …
83}; 88};
84 89
85my %ext_pkg; 90my %ext_pkg;
86my @exts; 91my @exts;
87my @hook; 92my @hook;
88my %command;
89my %extcmd;
90 93
91=head2 UTILITY FUNCTIONS 94=head2 UTILITY FUNCTIONS
92 95
93=over 4 96=over 4
94 97
… …
523 unlink $filename; 526 unlink $filename;
524 unlink "$filename.pst"; 527 unlink "$filename.pst";
525 } 528 }
526} 529}
527 530
531sub object_freezer_as_string {
532 my ($rdata, $objs) = @_;
533
534 use Data::Dumper;
535
536 $$rdata . Dumper $objs
537}
538
528sub object_thawer_load { 539sub object_thawer_load {
529 my ($filename) = @_; 540 my ($filename) = @_;
530 541
531 local $/; 542 local $/;
532 543
… …
557 if exists $src->{_attachment}; 568 if exists $src->{_attachment};
558 }, 569 },
559; 570;
560 571
561############################################################################# 572#############################################################################
562# old plug-in events 573# command handling &c
563 574
564sub inject_event { 575=item cf::register_command $name => \&callback($ob,$args);
565 my $extension = shift;
566 my $event_code = shift;
567 576
568 my $cb = $hook[$event_code]{$extension} 577Register a callback for execution when the client sends the user command
569 or return; 578$name.
570 579
571 &$cb 580=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 581
593sub register_command { 582sub register_command {
594 my ($name, $time, $cb) = @_; 583 my ($name, $cb) = @_;
595 584
596 my $caller = caller; 585 my $caller = caller;
597 #warn "registering command '$name/$time' to '$caller'"; 586 #warn "registering command '$name/$time' to '$caller'";
598 587
599 push @{ $command{$name} }, [$time, $cb, $caller]; 588 push @{ $COMMAND{$name} }, [$caller, $cb];
600 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
601} 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
602 599
603sub register_extcmd { 600sub register_extcmd {
604 my ($name, $cb) = @_; 601 my ($name, $cb) = @_;
605 602
606 my $caller = caller; 603 my $caller = caller;
607 #warn "registering extcmd '$name' to '$caller'"; 604 #warn "registering extcmd '$name' to '$caller'";
608 605
609 $extcmd{$name} = [$cb, $caller]; 606 $EXTCMD{$name} = [$cb, $caller];
610} 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;
611 640
612sub register { 641sub register {
613 my ($base, $pkg) = @_; 642 my ($base, $pkg) = @_;
614 643
615 #TODO 644 #TODO
… …
634 . "#line 1 \"$path\"\n{\n" 663 . "#line 1 \"$path\"\n{\n"
635 . (do { local $/; <$fh> }) 664 . (do { local $/; <$fh> })
636 . "\n};\n1"; 665 . "\n};\n1";
637 666
638 eval $source 667 eval $source
639 or die "$path: $@"; 668 or die $@ ? "$path: $@\n"
669 : "extension disabled.\n";
640 670
641 push @exts, $pkg; 671 push @exts, $pkg;
642 $ext_pkg{$base} = $pkg; 672 $ext_pkg{$base} = $pkg;
643 673
644# no strict 'refs'; 674# no strict 'refs';
… …
657# for my $idx (0 .. $#PLUGIN_EVENT) { 687# for my $idx (0 .. $#PLUGIN_EVENT) {
658# delete $hook[$idx]{$pkg}; 688# delete $hook[$idx]{$pkg};
659# } 689# }
660 690
661 # remove commands 691 # remove commands
662 for my $name (keys %command) { 692 for my $name (keys %COMMAND) {
663 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 693 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
664 694
665 if (@cb) { 695 if (@cb) {
666 $command{$name} = \@cb; 696 $COMMAND{$name} = \@cb;
667 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
668 } else { 697 } else {
669 delete $command{$name};
670 delete $COMMAND{"$name\000"}; 698 delete $COMMAND{$name};
671 } 699 }
672 } 700 }
673 701
674 # remove extcmds 702 # remove extcmds
675 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 703 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
676 delete $extcmd{$name}; 704 delete $EXTCMD{$name};
677 } 705 }
678 706
679 if (my $cb = $pkg->can ("unload")) { 707 if (my $cb = $pkg->can ("unload")) {
680 eval { 708 eval {
681 $cb->($pkg); 709 $cb->($pkg);
… …
697 } or warn "$ext not loaded: $@"; 725 } or warn "$ext not loaded: $@";
698 } 726 }
699} 727}
700 728
701############################################################################# 729#############################################################################
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 730# load/save/clean perl data associated with a map
727 731
728*cf::mapsupport::on_clean = sub { 732*cf::mapsupport::on_clean = sub {
729 my ($map) = @_; 733 my ($map) = @_;
730 734
… …
775sub cf::player::exists($) { 779sub cf::player::exists($) {
776 cf::player::find $_[0] 780 cf::player::find $_[0]
777 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;
778} 782}
779 783
780=item $object->reply ($npc, $msg[, $flags]) 784=item $player_object->reply ($npc, $msg[, $flags])
781 785
782Sends 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>
783can 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
784dialogue with the given NPC character. 788dialogue with the given NPC character.
785 789
… …
812 $msg{msgid} = $id; 816 $msg{msgid} = $id;
813 817
814 $self->send ("ext " . to_json \%msg); 818 $self->send ("ext " . to_json \%msg);
815} 819}
816 820
817=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}
818 836
819=cut 837=cut
820 838
821############################################################################# 839#############################################################################
822 840
… …
824 842
825Functions that provide a safe environment to compile and execute 843Functions that provide a safe environment to compile and execute
826snippets of perl code without them endangering the safety of the server 844snippets of perl code without them endangering the safety of the server
827itself. Looping constructs, I/O operators and other built-in functionality 845itself. Looping constructs, I/O operators and other built-in functionality
828is not available in the safe scripting environment, and the number of 846is not available in the safe scripting environment, and the number of
829functions and methods that cna be called is greatly reduced. 847functions and methods that can be called is greatly reduced.
830 848
831=cut 849=cut
832 850
833our $safe = new Safe "safe"; 851our $safe = new Safe "safe";
834our $safe_hole = new Safe::Hole; 852our $safe_hole = new Safe::Hole;
… …
970 988
971Immediately write the database to disk I<if it is dirty>. 989Immediately write the database to disk I<if it is dirty>.
972 990
973=cut 991=cut
974 992
993our $DB;
994
975{ 995{
976 my $db;
977 my $path = cf::localdir . "/database.pst"; 996 my $path = cf::localdir . "/database.pst";
978 997
979 sub db_load() { 998 sub db_load() {
980 warn "loading database $path\n";#d# remove later 999 warn "loading database $path\n";#d# remove later
981 $db = stat $path ? Storable::retrieve $path : { }; 1000 $DB = stat $path ? Storable::retrieve $path : { };
982 } 1001 }
983 1002
984 my $pid; 1003 my $pid;
985 1004
986 sub db_save() { 1005 sub db_save() {
987 warn "saving database $path\n";#d# remove later 1006 warn "saving database $path\n";#d# remove later
988 waitpid $pid, 0 if $pid; 1007 waitpid $pid, 0 if $pid;
989 if (0 == ($pid = fork)) { 1008 if (0 == ($pid = fork)) {
990 $db->{_meta}{version} = 1; 1009 $DB->{_meta}{version} = 1;
991 Storable::nstore $db, "$path~"; 1010 Storable::nstore $DB, "$path~";
992 rename "$path~", $path; 1011 rename "$path~", $path;
993 cf::_exit 0 if defined $pid; 1012 cf::_exit 0 if defined $pid;
994 } 1013 }
995 } 1014 }
996 1015
… …
1010 $idle->start; 1029 $idle->start;
1011 } 1030 }
1012 1031
1013 sub db_get($;$) { 1032 sub db_get($;$) {
1014 @_ >= 2 1033 @_ >= 2
1015 ? $db->{$_[0]}{$_[1]} 1034 ? $DB->{$_[0]}{$_[1]}
1016 : ($db->{$_[0]} ||= { }) 1035 : ($DB->{$_[0]} ||= { })
1017 } 1036 }
1018 1037
1019 sub db_put($$;$) { 1038 sub db_put($$;$) {
1020 if (@_ >= 3) { 1039 if (@_ >= 3) {
1021 $db->{$_[0]}{$_[1]} = $_[2]; 1040 $DB->{$_[0]}{$_[1]} = $_[2];
1022 } else { 1041 } else {
1023 $db->{$_[0]} = $_[1]; 1042 $DB->{$_[0]} = $_[1];
1024 } 1043 }
1025 db_dirty; 1044 db_dirty;
1026 } 1045 }
1027 1046
1028 attach_global 1047 attach_global
… …
1129 warn $_[0]; 1148 warn $_[0];
1130 print "$_[0]\n"; 1149 print "$_[0]\n";
1131 }; 1150 };
1132} 1151}
1133 1152
1153register "<global>", __PACKAGE__;
1154
1134register_command "perl-reload", 0, sub { 1155register_command "perl-reload" => sub {
1135 my ($who, $arg) = @_; 1156 my ($who, $arg) = @_;
1136 1157
1137 if ($who->flag (FLAG_WIZ)) { 1158 if ($who->flag (FLAG_WIZ)) {
1138 _perl_reload { 1159 _perl_reload {
1139 warn $_[0]; 1160 warn $_[0];
1140 $who->message ($_[0]); 1161 $who->message ($_[0]);
1141 }; 1162 };
1142 } 1163 }
1143}; 1164};
1144
1145register "<global>", __PACKAGE__;
1146 1165
1147unshift @INC, $LIBDIR; 1166unshift @INC, $LIBDIR;
1148 1167
1149$TICK_WATCHER = Event->timer ( 1168$TICK_WATCHER = Event->timer (
1150 prio => 1, 1169 prio => 1,
… …
1154 cf::server_tick; # one server iteration 1173 cf::server_tick; # one server iteration
1155 1174
1156 my $NOW = Event::time; 1175 my $NOW = Event::time;
1157 $NEXT_TICK += $TICK; 1176 $NEXT_TICK += $TICK;
1158 1177
1159 # if we are delayed by four ticks, skip them all 1178 # if we are delayed by four ticks or more, skip them all
1160 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1179 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1161 1180
1162 $TICK_WATCHER->at ($NEXT_TICK); 1181 $TICK_WATCHER->at ($NEXT_TICK);
1163 $TICK_WATCHER->start; 1182 $TICK_WATCHER->start;
1164 }, 1183 },

Diff Legend

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