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.72 by root, Sun Oct 1 11:41:37 2006 UTC vs.
Revision 1.92 by root, Thu Dec 21 06:42:28 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
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
20_init_vars; 27_init_vars;
21 28
22our %COMMAND = ();
23our @EVENT; 29our @EVENT;
24our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
25 31
26our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
27our $TICK_WATCHER; 33our $TICK_WATCHER;
28our $NEXT_TICK; 34our $NEXT_TICK;
29 35
30our %CFG; 36our %CFG;
31 37
38our $UPTIME; $UPTIME ||= time;
39
32############################################################################# 40#############################################################################
33 41
34=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
35 43
36=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
37 49
38=item $cf::LIBDIR 50=item $cf::LIBDIR
39 51
40The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
41be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
66 78
67@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
68 80
69# we bless all objects into (empty) derived classes to force a method lookup 81# we bless all objects into (empty) derived classes to force a method lookup
70# within the Safe compartment. 82# 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)) { 83for my $pkg (qw(
84 cf::object cf::object::player
85 cf::client cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
72 no strict 'refs'; 89 no strict 'refs';
73 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
74} 91}
75 92
76$Event::DIED = sub { 93$Event::DIED = sub {
… …
78}; 95};
79 96
80my %ext_pkg; 97my %ext_pkg;
81my @exts; 98my @exts;
82my @hook; 99my @hook;
83my %command;
84my %extcmd;
85 100
86=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
87 102
88=over 4 103=over 4
89 104
… …
137 152
138=item $map->attach ($attachment, key => $value...) 153=item $map->attach ($attachment, key => $value...)
139 154
140=item $map->detach ($attachment) 155=item $map->detach ($attachment)
141 156
157Attach/detach a pre-registered attachment to a client.
158
159=item $client->attach ($attachment, key => $value...)
160
161=item $client->detach ($attachment)
162
142Attach/detach a pre-registered attachment to a map. 163Attach/detach a pre-registered attachment to a map.
143 164
144=item $bool = $object->attached ($name) 165=item $bool = $object->attached ($name)
145 166
146=item $bool = $player->attached ($name) 167=item $bool = $player->attached ($name)
168
169=item $bool = $client->attached ($name)
147 170
148=item $bool = $map->attached ($name) 171=item $bool = $map->attached ($name)
149 172
150Checks wether the named attachment is currently attached to the object. 173Checks wether the named attachment is currently attached to the object.
151 174
… …
198 221
199=item cf::attach_to_players ... 222=item cf::attach_to_players ...
200 223
201Attach handlers to all players. 224Attach handlers to all players.
202 225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
203=item cf::attach_to_maps ... 230=item cf::attach_to_maps ...
204 231
205Attach handlers to all maps. 232Attach handlers to all maps.
206 233
207=item cf:register_attachment $name, ... 234=item cf:register_attachment $name, ...
… …
223 250
224# the following variables are defined in .xs and must not be re-created 251# the following variables are defined in .xs and must not be re-created
225our @CB_GLOBAL = (); # registry for all global events 252our @CB_GLOBAL = (); # registry for all global events
226our @CB_OBJECT = (); # all objects (should not be used except in emergency) 253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
227our @CB_PLAYER = (); 254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
228our @CB_TYPE = (); # registry for type (cf-object class) based events 256our @CB_TYPE = (); # registry for type (cf-object class) based events
229our @CB_MAP = (); 257our @CB_MAP = ();
230 258
231my %attachment; 259my %attachment;
232 260
… …
315 $res 343 $res
316} 344}
317 345
318*cf::object::attach = 346*cf::object::attach =
319*cf::player::attach = 347*cf::player::attach =
348*cf::client::attach =
320*cf::map::attach = sub { 349*cf::map::attach = sub {
321 my ($obj, $name, %arg) = @_; 350 my ($obj, $name, %arg) = @_;
322 351
323 _attach_attachment $obj, $name, %arg; 352 _attach_attachment $obj, $name, %arg;
324}; 353};
325 354
326# all those should be optimised 355# all those should be optimised
327*cf::object::detach = 356*cf::object::detach =
328*cf::player::detach = 357*cf::player::detach =
358*cf::client::detach =
329*cf::map::detach = sub { 359*cf::map::detach = sub {
330 my ($obj, $name) = @_; 360 my ($obj, $name) = @_;
331 361
332 delete $obj->{_attachment}{$name}; 362 delete $obj->{_attachment}{$name};
333 reattach ($obj); 363 reattach ($obj);
334}; 364};
335 365
336*cf::object::attached = 366*cf::object::attached =
337*cf::player::attached = 367*cf::player::attached =
368*cf::client::attached =
338*cf::map::attached = sub { 369*cf::map::attached = sub {
339 my ($obj, $name) = @_; 370 my ($obj, $name) = @_;
340 371
341 exists $obj->{_attachment}{$name} 372 exists $obj->{_attachment}{$name}
342}; 373};
… …
358 389
359sub attach_to_players { 390sub attach_to_players {
360 _attach @CB_PLAYER, KLASS_PLAYER, @_ 391 _attach @CB_PLAYER, KLASS_PLAYER, @_
361} 392}
362 393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
363sub attach_to_maps { 398sub attach_to_maps {
364 _attach @CB_MAP, KLASS_MAP, @_ 399 _attach @CB_MAP, KLASS_MAP, @_
365} 400}
366 401
367sub register_attachment { 402sub register_attachment {
… …
372 407
373sub register_player_attachment { 408sub register_player_attachment {
374 my $name = shift; 409 my $name = shift;
375 410
376 $attachment{$name} = [[KLASS_PLAYER, @_]]; 411 $attachment{$name} = [[KLASS_PLAYER, @_]];
412}
413
414sub register_client_attachment {
415 my $name = shift;
416
417 $attachment{$name} = [[KLASS_CLIENT, @_]];
377} 418}
378 419
379sub register_map_attachment { 420sub register_map_attachment {
380 my $name = shift; 421 my $name = shift;
381 422
… …
417 458
418=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
419 460
420=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
421 462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
422=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
423 466
424Generate a global/object/player/map-specific event with the given arguments. 467Generate a global/object/player/map-specific event with the given arguments.
425 468
426This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be 469This API is preliminary (most likely, the EVENT_KLASS_xxx prefix will be
… …
435 478
436=head2 METHODS VALID FOR ALL CORE OBJECTS 479=head2 METHODS VALID FOR ALL CORE OBJECTS
437 480
438=over 4 481=over 4
439 482
440=item $object->valid, $player->valid, $map->valid 483=item $object->valid, $player->valid, $client->valid, $map->valid
441 484
442Just because you have a perl object does not mean that the corresponding 485Just because you have a perl object does not mean that the corresponding
443C-level object still exists. If you try to access an object that has no 486C-level object still exists. If you try to access an object that has no
444valid C counterpart anymore you get an exception at runtime. This method 487valid C counterpart anymore you get an exception at runtime. This method
445can be used to test for existence of the C object part without causing an 488can be used to test for existence of the C object part without causing an
… …
449 492
450=cut 493=cut
451 494
452*cf::object::valid = 495*cf::object::valid =
453*cf::player::valid = 496*cf::player::valid =
497*cf::client::valid =
454*cf::map::valid = \&cf::_valid; 498*cf::map::valid = \&cf::_valid;
455 499
456############################################################################# 500#############################################################################
457# object support 501# object support
458 502
… …
518 unlink $filename; 562 unlink $filename;
519 unlink "$filename.pst"; 563 unlink "$filename.pst";
520 } 564 }
521} 565}
522 566
567sub object_freezer_as_string {
568 my ($rdata, $objs) = @_;
569
570 use Data::Dumper;
571
572 $$rdata . Dumper $objs
573}
574
523sub object_thawer_load { 575sub object_thawer_load {
524 my ($filename) = @_; 576 my ($filename) = @_;
525 577
526 local $/; 578 local $/;
527 579
… …
552 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
553 }, 605 },
554; 606;
555 607
556############################################################################# 608#############################################################################
557# old plug-in events 609# command handling &c
558 610
559sub inject_event { 611=item cf::register_command $name => \&callback($ob,$args);
560 my $extension = shift;
561 my $event_code = shift;
562 612
563 my $cb = $hook[$event_code]{$extension} 613Register a callback for execution when the client sends the user command
564 or return; 614$name.
565 615
566 &$cb 616=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 617
588sub register_command { 618sub register_command {
589 my ($name, $time, $cb) = @_; 619 my ($name, $cb) = @_;
590 620
591 my $caller = caller; 621 my $caller = caller;
592 #warn "registering command '$name/$time' to '$caller'"; 622 #warn "registering command '$name/$time' to '$caller'";
593 623
594 push @{ $command{$name} }, [$time, $cb, $caller]; 624 push @{ $COMMAND{$name} }, [$caller, $cb];
595 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
596} 625}
626
627=item cf::register_extcmd $name => \&callback($pl,$packet);
628
629Register a callbackf ro execution when the client sends an extcmd packet.
630
631If the callback returns something, it is sent back as if reply was being
632called.
633
634=cut
597 635
598sub register_extcmd { 636sub register_extcmd {
599 my ($name, $cb) = @_; 637 my ($name, $cb) = @_;
600 638
601 my $caller = caller; 639 my $caller = caller;
602 #warn "registering extcmd '$name' to '$caller'"; 640 #warn "registering extcmd '$name' to '$caller'";
603 641
604 $extcmd{$name} = [$cb, $caller]; 642 $EXTCMD{$name} = [$cb, $caller];
605} 643}
644
645attach_to_players
646 on_command => sub {
647 my ($pl, $name, $params) = @_;
648
649 my $cb = $COMMAND{$name}
650 or return;
651
652 for my $cmd (@$cb) {
653 $cmd->[1]->($pl->ob, $params);
654 }
655
656 cf::override;
657 },
658 on_extcmd => sub {
659 my ($pl, $buf) = @_;
660
661 my $msg = eval { from_json $buf };
662
663 if (ref $msg) {
664 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
665 if (my %reply = $cb->[0]->($pl, $msg)) {
666 $pl->ext_reply ($msg->{msgid}, %reply);
667 }
668 }
669 } else {
670 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
671 }
672
673 cf::override;
674 },
675;
606 676
607sub register { 677sub register {
608 my ($base, $pkg) = @_; 678 my ($base, $pkg) = @_;
609 679
610 #TODO 680 #TODO
… …
629 . "#line 1 \"$path\"\n{\n" 699 . "#line 1 \"$path\"\n{\n"
630 . (do { local $/; <$fh> }) 700 . (do { local $/; <$fh> })
631 . "\n};\n1"; 701 . "\n};\n1";
632 702
633 eval $source 703 eval $source
634 or die "$path: $@"; 704 or die $@ ? "$path: $@\n"
705 : "extension disabled.\n";
635 706
636 push @exts, $pkg; 707 push @exts, $pkg;
637 $ext_pkg{$base} = $pkg; 708 $ext_pkg{$base} = $pkg;
638 709
639# no strict 'refs'; 710# no strict 'refs';
… …
652# for my $idx (0 .. $#PLUGIN_EVENT) { 723# for my $idx (0 .. $#PLUGIN_EVENT) {
653# delete $hook[$idx]{$pkg}; 724# delete $hook[$idx]{$pkg};
654# } 725# }
655 726
656 # remove commands 727 # remove commands
657 for my $name (keys %command) { 728 for my $name (keys %COMMAND) {
658 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 729 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
659 730
660 if (@cb) { 731 if (@cb) {
661 $command{$name} = \@cb; 732 $COMMAND{$name} = \@cb;
662 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
663 } else { 733 } else {
664 delete $command{$name};
665 delete $COMMAND{"$name\000"}; 734 delete $COMMAND{$name};
666 } 735 }
667 } 736 }
668 737
669 # remove extcmds 738 # remove extcmds
670 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 739 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
671 delete $extcmd{$name}; 740 delete $EXTCMD{$name};
672 } 741 }
673 742
674 if (my $cb = $pkg->can ("unload")) { 743 if (my $cb = $pkg->can ("unload")) {
675 eval { 744 eval {
676 $cb->($pkg); 745 $cb->($pkg);
… …
680 749
681 Symbol::delete_package $pkg; 750 Symbol::delete_package $pkg;
682} 751}
683 752
684sub load_extensions { 753sub load_extensions {
685 my $LIBDIR = maps_directory "perl";
686
687 for my $ext (<$LIBDIR/*.ext>) { 754 for my $ext (<$LIBDIR/*.ext>) {
688 next unless -r $ext; 755 next unless -r $ext;
689 eval { 756 eval {
690 load_extension $ext; 757 load_extension $ext;
691 1 758 1
692 } or warn "$ext not loaded: $@"; 759 } or warn "$ext not loaded: $@";
693 } 760 }
694} 761}
695 762
696############################################################################# 763#############################################################################
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 764# load/save/clean perl data associated with a map
722 765
723*cf::mapsupport::on_clean = sub { 766*cf::mapsupport::on_clean = sub {
724 my ($map) = @_; 767 my ($map) = @_;
725 768
… …
770sub cf::player::exists($) { 813sub cf::player::exists($) {
771 cf::player::find $_[0] 814 cf::player::find $_[0]
772 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 815 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
773} 816}
774 817
775=item $player->reply ($npc, $msg[, $flags]) 818=item $player_object->reply ($npc, $msg[, $flags])
776 819
777Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 820Sends 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 821can be C<undef>. Does the right thing when the player is currently in a
779dialogue with the given NPC character. 822dialogue with the given NPC character.
780 823
… …
807 $msg{msgid} = $id; 850 $msg{msgid} = $id;
808 851
809 $self->send ("ext " . to_json \%msg); 852 $self->send ("ext " . to_json \%msg);
810} 853}
811 854
812=back 855=item $player_object->may ("access")
856
857Returns wether the given player is authorized to access resource "access"
858(e.g. "command_wizcast").
859
860=cut
861
862sub cf::object::player::may {
863 my ($self, $access) = @_;
864
865 $self->flag (cf::FLAG_WIZ) ||
866 (ref $cf::CFG{"may_$access"}
867 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
868 : $cf::CFG{"may_$access"})
869}
813 870
814=cut 871=cut
815 872
816############################################################################# 873#############################################################################
817 874
… …
819 876
820Functions that provide a safe environment to compile and execute 877Functions that provide a safe environment to compile and execute
821snippets of perl code without them endangering the safety of the server 878snippets of perl code without them endangering the safety of the server
822itself. Looping constructs, I/O operators and other built-in functionality 879itself. Looping constructs, I/O operators and other built-in functionality
823is not available in the safe scripting environment, and the number of 880is not available in the safe scripting environment, and the number of
824functions and methods that cna be called is greatly reduced. 881functions and methods that can be called is greatly reduced.
825 882
826=cut 883=cut
827 884
828our $safe = new Safe "safe"; 885our $safe = new Safe "safe";
829our $safe_hole = new Safe::Hole; 886our $safe_hole = new Safe::Hole;
… …
836 893
837=pod 894=pod
838 895
839The following fucntions and emthods are available within a safe environment: 896The following fucntions and emthods are available within a safe environment:
840 897
841 cf::object contr pay_amount pay_player 898 cf::object contr pay_amount pay_player map
842 cf::object::player player 899 cf::object::player player
843 cf::player peaceful 900 cf::player peaceful
901 cf::map trigger
844 902
845=cut 903=cut
846 904
847for ( 905for (
848 ["cf::object" => qw(contr pay_amount pay_player)], 906 ["cf::object" => qw(contr pay_amount pay_player map)],
849 ["cf::object::player" => qw(player)], 907 ["cf::object::player" => qw(player)],
850 ["cf::player" => qw(peaceful)], 908 ["cf::player" => qw(peaceful)],
909 ["cf::map" => qw(trigger)],
851) { 910) {
852 no strict 'refs'; 911 no strict 'refs';
853 my ($pkg, @funs) = @$_; 912 my ($pkg, @funs) = @$_;
854 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 913 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
855 for @funs; 914 for @funs;
… …
965 1024
966Immediately write the database to disk I<if it is dirty>. 1025Immediately write the database to disk I<if it is dirty>.
967 1026
968=cut 1027=cut
969 1028
1029our $DB;
1030
970{ 1031{
971 my $db;
972 my $path = cf::localdir . "/database.pst"; 1032 my $path = cf::localdir . "/database.pst";
973 1033
974 sub db_load() { 1034 sub db_load() {
975 warn "loading database $path\n";#d# remove later 1035 warn "loading database $path\n";#d# remove later
976 $db = stat $path ? Storable::retrieve $path : { }; 1036 $DB = stat $path ? Storable::retrieve $path : { };
977 } 1037 }
978 1038
979 my $pid; 1039 my $pid;
980 1040
981 sub db_save() { 1041 sub db_save() {
982 warn "saving database $path\n";#d# remove later 1042 warn "saving database $path\n";#d# remove later
983 waitpid $pid, 0 if $pid; 1043 waitpid $pid, 0 if $pid;
984 if (0 == ($pid = fork)) { 1044 if (0 == ($pid = fork)) {
985 $db->{_meta}{version} = 1; 1045 $DB->{_meta}{version} = 1;
986 Storable::nstore $db, "$path~"; 1046 Storable::nstore $DB, "$path~";
987 rename "$path~", $path; 1047 rename "$path~", $path;
988 cf::_exit 0 if defined $pid; 1048 cf::_exit 0 if defined $pid;
989 } 1049 }
990 } 1050 }
991 1051
… …
994 sub db_sync() { 1054 sub db_sync() {
995 db_save if $dirty; 1055 db_save if $dirty;
996 undef $dirty; 1056 undef $dirty;
997 } 1057 }
998 1058
999 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, cb => sub { 1059 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1000 db_sync; 1060 db_sync;
1001 }); 1061 });
1002 1062
1003 sub db_dirty() { 1063 sub db_dirty() {
1004 $dirty = 1; 1064 $dirty = 1;
1005 $idle->start; 1065 $idle->start;
1006 } 1066 }
1007 1067
1008 sub db_get($;$) { 1068 sub db_get($;$) {
1009 @_ >= 2 1069 @_ >= 2
1010 ? $db->{$_[0]}{$_[1]} 1070 ? $DB->{$_[0]}{$_[1]}
1011 : ($db->{$_[0]} ||= { }) 1071 : ($DB->{$_[0]} ||= { })
1012 } 1072 }
1013 1073
1014 sub db_put($$;$) { 1074 sub db_put($$;$) {
1015 if (@_ >= 3) { 1075 if (@_ >= 3) {
1016 $db->{$_[0]}{$_[1]} = $_[2]; 1076 $DB->{$_[0]}{$_[1]} = $_[2];
1017 } else { 1077 } else {
1018 $db->{$_[0]} = $_[1]; 1078 $DB->{$_[0]} = $_[1];
1019 } 1079 }
1020 db_dirty; 1080 db_dirty;
1021 } 1081 }
1022 1082
1023 attach_global 1083 attach_global
… …
1029} 1089}
1030 1090
1031############################################################################# 1091#############################################################################
1032# the server's main() 1092# the server's main()
1033 1093
1034sub load_cfg { 1094sub cfg_load {
1035 open my $fh, "<:utf8", cf::confdir . "/config" 1095 open my $fh, "<:utf8", cf::confdir . "/config"
1036 or return; 1096 or return;
1037 1097
1038 local $/; 1098 local $/;
1039 *CFG = YAML::Syck::Load <$fh>; 1099 *CFG = YAML::Syck::Load <$fh>;
1040
1041 use Data::Dumper; warn Dumper \%CFG;
1042} 1100}
1043 1101
1044sub main { 1102sub main {
1045 load_cfg; 1103 cfg_load;
1046 db_load; 1104 db_load;
1047 load_extensions; 1105 load_extensions;
1048 Event::loop; 1106 Event::loop;
1049} 1107}
1050 1108
… …
1056 1114
1057 $msg->("reloading..."); 1115 $msg->("reloading...");
1058 1116
1059 eval { 1117 eval {
1060 # cancel all watchers 1118 # cancel all watchers
1061 $_->cancel for Event::all_watchers; 1119 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 }
1062 1122
1063 # unload all extensions 1123 # unload all extensions
1064 for (@exts) { 1124 for (@exts) {
1065 $msg->("unloading <$_>"); 1125 $msg->("unloading <$_>");
1066 unload_extension $_; 1126 unload_extension $_;
… …
1102 1162
1103 # reload cf.pm 1163 # reload cf.pm
1104 $msg->("reloading cf.pm"); 1164 $msg->("reloading cf.pm");
1105 require cf; 1165 require cf;
1106 1166
1107 # load database again 1167 # load config and database again
1168 cf::cfg_load;
1108 cf::db_load; 1169 cf::db_load;
1109 1170
1110 # load extensions 1171 # load extensions
1111 $msg->("load extensions"); 1172 $msg->("load extensions");
1112 cf::load_extensions; 1173 cf::load_extensions;
… …
1125 warn $_[0]; 1186 warn $_[0];
1126 print "$_[0]\n"; 1187 print "$_[0]\n";
1127 }; 1188 };
1128} 1189}
1129 1190
1191register "<global>", __PACKAGE__;
1192
1130register_command "perl-reload", 0, sub { 1193register_command "perl-reload" => sub {
1131 my ($who, $arg) = @_; 1194 my ($who, $arg) = @_;
1132 1195
1133 if ($who->flag (FLAG_WIZ)) { 1196 if ($who->flag (FLAG_WIZ)) {
1134 _perl_reload { 1197 _perl_reload {
1135 warn $_[0]; 1198 warn $_[0];
1136 $who->message ($_[0]); 1199 $who->message ($_[0]);
1137 }; 1200 };
1138 } 1201 }
1139}; 1202};
1140 1203
1141register "<global>", __PACKAGE__;
1142
1143unshift @INC, $LIBDIR; 1204unshift @INC, $LIBDIR;
1144 1205
1145$TICK_WATCHER = Event->timer ( 1206$TICK_WATCHER = Event->timer (
1146 prio => 1, 1207 prio => 0,
1147 at => $NEXT_TICK || 1, 1208 at => $NEXT_TICK || 1,
1209 data => WF_AUTOCANCEL,
1148 cb => sub { 1210 cb => sub {
1149 cf::server_tick; # one server iteration 1211 cf::server_tick; # one server iteration
1150 1212
1151 my $NOW = Event::time; 1213 my $NOW = Event::time;
1152 $NEXT_TICK += $TICK; 1214 $NEXT_TICK += $TICK;
1153 1215
1154 # if we are delayed by four ticks, skip them all 1216 # if we are delayed by four ticks or more, skip them all
1155 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1217 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1156 1218
1157 $TICK_WATCHER->at ($NEXT_TICK); 1219 $TICK_WATCHER->at ($NEXT_TICK);
1158 $TICK_WATCHER->start; 1220 $TICK_WATCHER->start;
1159 }, 1221 },
1160); 1222);
1161 1223
1224IO::AIO::max_poll_time $TICK * 0.2;
1225
1226Event->io (fd => IO::AIO::poll_fileno,
1227 poll => 'r',
1228 prio => 5,
1229 data => WF_AUTOCANCEL,
1230 cb => \&IO::AIO::poll_cb);
1231
11621 12321
1163 1233

Diff Legend

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