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.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 ();
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
21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
22
23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
16_init_vars; 27_init_vars;
17 28
18our %COMMAND = ();
19our @EVENT; 29our @EVENT;
20our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = datadir . "/ext";
21 31
22our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
23our $TICK_WATCHER; 33our $TICK_WATCHER;
24our $NEXT_TICK; 34our $NEXT_TICK;
25 35
26our %CFG; 36our %CFG;
27 37
38our $UPTIME; $UPTIME ||= time;
39
28############################################################################# 40#############################################################################
29 41
30=head2 GLOBAL VARIABLES 42=head2 GLOBAL VARIABLES
31 43
32=over 4 44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
33 49
34=item $cf::LIBDIR 50=item $cf::LIBDIR
35 51
36The perl library directory, where extensions and cf-specific modules can 52The perl library directory, where extensions and cf-specific modules can
37be found. It will be added to C<@INC> automatically. 53be found. It will be added to C<@INC> automatically.
… …
62 78
63@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
64 80
65# 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
66# within the Safe compartment. 82# 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)) { 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)) {
68 no strict 'refs'; 89 no strict 'refs';
69 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
70} 91}
71 92
72$Event::DIED = sub { 93$Event::DIED = sub {
… …
74}; 95};
75 96
76my %ext_pkg; 97my %ext_pkg;
77my @exts; 98my @exts;
78my @hook; 99my @hook;
79my %command;
80my %extcmd;
81 100
82=head2 UTILITY FUNCTIONS 101=head2 UTILITY FUNCTIONS
83 102
84=over 4 103=over 4
85 104
… …
109 JSON::Syck::Dump $_[0] 128 JSON::Syck::Dump $_[0]
110} 129}
111 130
112=back 131=back
113 132
133=cut
134
114############################################################################# 135#############################################################################
115 136
116=head2 EVENTS AND OBJECT ATTACHMENTS 137=head2 EVENTS AND OBJECT ATTACHMENTS
117 138
118=over 4 139=over 4
… …
131 152
132=item $map->attach ($attachment, key => $value...) 153=item $map->attach ($attachment, key => $value...)
133 154
134=item $map->detach ($attachment) 155=item $map->detach ($attachment)
135 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
136Attach/detach a pre-registered attachment to a map. 163Attach/detach a pre-registered attachment to a map.
137 164
138=item $bool = $object->attached ($name) 165=item $bool = $object->attached ($name)
139 166
140=item $bool = $player->attached ($name) 167=item $bool = $player->attached ($name)
168
169=item $bool = $client->attached ($name)
141 170
142=item $bool = $map->attached ($name) 171=item $bool = $map->attached ($name)
143 172
144Checks wether the named attachment is currently attached to the object. 173Checks wether the named attachment is currently attached to the object.
145 174
… …
192 221
193=item cf::attach_to_players ... 222=item cf::attach_to_players ...
194 223
195Attach handlers to all players. 224Attach handlers to all players.
196 225
226=item cf::attach_to_clients ...
227
228Attach handlers to all players.
229
197=item cf::attach_to_maps ... 230=item cf::attach_to_maps ...
198 231
199Attach handlers to all maps. 232Attach handlers to all maps.
200 233
201=item cf:register_attachment $name, ... 234=item cf:register_attachment $name, ...
… …
217 250
218# 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
219our @CB_GLOBAL = (); # registry for all global events 252our @CB_GLOBAL = (); # registry for all global events
220our @CB_OBJECT = (); # all objects (should not be used except in emergency) 253our @CB_OBJECT = (); # all objects (should not be used except in emergency)
221our @CB_PLAYER = (); 254our @CB_PLAYER = ();
255our @CB_CLIENT = ();
222our @CB_TYPE = (); # registry for type (cf-object class) based events 256our @CB_TYPE = (); # registry for type (cf-object class) based events
223our @CB_MAP = (); 257our @CB_MAP = ();
224 258
225my %attachment; 259my %attachment;
226 260
… …
309 $res 343 $res
310} 344}
311 345
312*cf::object::attach = 346*cf::object::attach =
313*cf::player::attach = 347*cf::player::attach =
348*cf::client::attach =
314*cf::map::attach = sub { 349*cf::map::attach = sub {
315 my ($obj, $name, %arg) = @_; 350 my ($obj, $name, %arg) = @_;
316 351
317 _attach_attachment $obj, $name, %arg; 352 _attach_attachment $obj, $name, %arg;
318}; 353};
319 354
320# all those should be optimised 355# all those should be optimised
321*cf::object::detach = 356*cf::object::detach =
322*cf::player::detach = 357*cf::player::detach =
358*cf::client::detach =
323*cf::map::detach = sub { 359*cf::map::detach = sub {
324 my ($obj, $name) = @_; 360 my ($obj, $name) = @_;
325 361
326 delete $obj->{_attachment}{$name}; 362 delete $obj->{_attachment}{$name};
327 reattach ($obj); 363 reattach ($obj);
328}; 364};
329 365
330*cf::object::attached = 366*cf::object::attached =
331*cf::player::attached = 367*cf::player::attached =
368*cf::client::attached =
332*cf::map::attached = sub { 369*cf::map::attached = sub {
333 my ($obj, $name) = @_; 370 my ($obj, $name) = @_;
334 371
335 exists $obj->{_attachment}{$name} 372 exists $obj->{_attachment}{$name}
336}; 373};
… …
352 389
353sub attach_to_players { 390sub attach_to_players {
354 _attach @CB_PLAYER, KLASS_PLAYER, @_ 391 _attach @CB_PLAYER, KLASS_PLAYER, @_
355} 392}
356 393
394sub attach_to_clients {
395 _attach @CB_CLIENT, KLASS_CLIENT, @_
396}
397
357sub attach_to_maps { 398sub attach_to_maps {
358 _attach @CB_MAP, KLASS_MAP, @_ 399 _attach @CB_MAP, KLASS_MAP, @_
359} 400}
360 401
361sub register_attachment { 402sub register_attachment {
… …
366 407
367sub register_player_attachment { 408sub register_player_attachment {
368 my $name = shift; 409 my $name = shift;
369 410
370 $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, @_]];
371} 418}
372 419
373sub register_map_attachment { 420sub register_map_attachment {
374 my $name = shift; 421 my $name = shift;
375 422
… …
411 458
412=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...) 459=item $bool = $object->invoke (EVENT_OBJECT_XXX, ...)
413 460
414=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...) 461=item $bool = $player->invoke (EVENT_PLAYER_XXX, ...)
415 462
463=item $bool = $client->invoke (EVENT_CLIENT_XXX, ...)
464
416=item $bool = $map->invoke (EVENT_MAP_XXX, ...) 465=item $bool = $map->invoke (EVENT_MAP_XXX, ...)
417 466
418Generate a global/object/player/map-specific event with the given arguments. 467Generate a global/object/player/map-specific event with the given arguments.
419 468
420This 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
421removed in future versions), and there is no public API to access override 470removed in future versions), and there is no public API to access override
422results (if you must, access C<@cf::invoke_results> directly). 471results (if you must, access C<@cf::invoke_results> directly).
423 472
424=back 473=back
425 474
475=cut
476
426############################################################################# 477#############################################################################
427 478
428=head2 METHODS VALID FOR ALL CORE OBJECTS 479=head2 METHODS VALID FOR ALL CORE OBJECTS
429 480
430=over 4 481=over 4
431 482
432=item $object->valid, $player->valid, $map->valid 483=item $object->valid, $player->valid, $client->valid, $map->valid
433 484
434Just 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
435C-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
436valid C counterpart anymore you get an exception at runtime. This method 487valid C counterpart anymore you get an exception at runtime. This method
437can 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
… …
441 492
442=cut 493=cut
443 494
444*cf::object::valid = 495*cf::object::valid =
445*cf::player::valid = 496*cf::player::valid =
497*cf::client::valid =
446*cf::map::valid = \&cf::_valid; 498*cf::map::valid = \&cf::_valid;
447 499
448############################################################################# 500#############################################################################
449# object support 501# object support
450 502
… …
510 unlink $filename; 562 unlink $filename;
511 unlink "$filename.pst"; 563 unlink "$filename.pst";
512 } 564 }
513} 565}
514 566
567sub object_freezer_as_string {
568 my ($rdata, $objs) = @_;
569
570 use Data::Dumper;
571
572 $$rdata . Dumper $objs
573}
574
515sub object_thawer_load { 575sub object_thawer_load {
516 my ($filename) = @_; 576 my ($filename) = @_;
517 577
518 local $/; 578 local $/;
519 579
… …
544 if exists $src->{_attachment}; 604 if exists $src->{_attachment};
545 }, 605 },
546; 606;
547 607
548############################################################################# 608#############################################################################
549# old plug-in events 609# command handling &c
550 610
551sub inject_event { 611=item cf::register_command $name => \&callback($ob,$args);
552 my $extension = shift;
553 my $event_code = shift;
554 612
555 my $cb = $hook[$event_code]{$extension} 613Register a callback for execution when the client sends the user command
556 or return; 614$name.
557 615
558 &$cb 616=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 617
580sub register_command { 618sub register_command {
581 my ($name, $time, $cb) = @_; 619 my ($name, $cb) = @_;
582 620
583 my $caller = caller; 621 my $caller = caller;
584 #warn "registering command '$name/$time' to '$caller'"; 622 #warn "registering command '$name/$time' to '$caller'";
585 623
586 push @{ $command{$name} }, [$time, $cb, $caller]; 624 push @{ $COMMAND{$name} }, [$caller, $cb];
587 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
588} 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
589 635
590sub register_extcmd { 636sub register_extcmd {
591 my ($name, $cb) = @_; 637 my ($name, $cb) = @_;
592 638
593 my $caller = caller; 639 my $caller = caller;
594 #warn "registering extcmd '$name' to '$caller'"; 640 #warn "registering extcmd '$name' to '$caller'";
595 641
596 $extcmd{$name} = [$cb, $caller]; 642 $EXTCMD{$name} = [$cb, $caller];
597} 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;
598 676
599sub register { 677sub register {
600 my ($base, $pkg) = @_; 678 my ($base, $pkg) = @_;
601 679
602 #TODO 680 #TODO
… …
621 . "#line 1 \"$path\"\n{\n" 699 . "#line 1 \"$path\"\n{\n"
622 . (do { local $/; <$fh> }) 700 . (do { local $/; <$fh> })
623 . "\n};\n1"; 701 . "\n};\n1";
624 702
625 eval $source 703 eval $source
626 or die "$path: $@"; 704 or die $@ ? "$path: $@\n"
705 : "extension disabled.\n";
627 706
628 push @exts, $pkg; 707 push @exts, $pkg;
629 $ext_pkg{$base} = $pkg; 708 $ext_pkg{$base} = $pkg;
630 709
631# no strict 'refs'; 710# no strict 'refs';
… …
644# for my $idx (0 .. $#PLUGIN_EVENT) { 723# for my $idx (0 .. $#PLUGIN_EVENT) {
645# delete $hook[$idx]{$pkg}; 724# delete $hook[$idx]{$pkg};
646# } 725# }
647 726
648 # remove commands 727 # remove commands
649 for my $name (keys %command) { 728 for my $name (keys %COMMAND) {
650 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 729 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
651 730
652 if (@cb) { 731 if (@cb) {
653 $command{$name} = \@cb; 732 $COMMAND{$name} = \@cb;
654 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
655 } else { 733 } else {
656 delete $command{$name};
657 delete $COMMAND{"$name\000"}; 734 delete $COMMAND{$name};
658 } 735 }
659 } 736 }
660 737
661 # remove extcmds 738 # remove extcmds
662 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 739 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
663 delete $extcmd{$name}; 740 delete $EXTCMD{$name};
664 } 741 }
665 742
666 if (my $cb = $pkg->can ("unload")) { 743 if (my $cb = $pkg->can ("unload")) {
667 eval { 744 eval {
668 $cb->($pkg); 745 $cb->($pkg);
… …
672 749
673 Symbol::delete_package $pkg; 750 Symbol::delete_package $pkg;
674} 751}
675 752
676sub load_extensions { 753sub load_extensions {
677 my $LIBDIR = maps_directory "perl";
678
679 for my $ext (<$LIBDIR/*.ext>) { 754 for my $ext (<$LIBDIR/*.ext>) {
680 next unless -r $ext; 755 next unless -r $ext;
681 eval { 756 eval {
682 load_extension $ext; 757 load_extension $ext;
683 1 758 1
684 } or warn "$ext not loaded: $@"; 759 } or warn "$ext not loaded: $@";
685 } 760 }
686} 761}
687 762
688############################################################################# 763#############################################################################
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 764# load/save/clean perl data associated with a map
714 765
715*cf::mapsupport::on_clean = sub { 766*cf::mapsupport::on_clean = sub {
716 my ($map) = @_; 767 my ($map) = @_;
717 768
… …
762sub cf::player::exists($) { 813sub cf::player::exists($) {
763 cf::player::find $_[0] 814 cf::player::find $_[0]
764 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;
765} 816}
766 817
767=item $player->reply ($npc, $msg[, $flags]) 818=item $player_object->reply ($npc, $msg[, $flags])
768 819
769Sends 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>
770can 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
771dialogue with the given NPC character. 822dialogue with the given NPC character.
772 823
… …
799 $msg{msgid} = $id; 850 $msg{msgid} = $id;
800 851
801 $self->send ("ext " . to_json \%msg); 852 $self->send ("ext " . to_json \%msg);
802} 853}
803 854
804=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}
805 870
806=cut 871=cut
807 872
808############################################################################# 873#############################################################################
809 874
… …
811 876
812Functions that provide a safe environment to compile and execute 877Functions that provide a safe environment to compile and execute
813snippets of perl code without them endangering the safety of the server 878snippets of perl code without them endangering the safety of the server
814itself. Looping constructs, I/O operators and other built-in functionality 879itself. Looping constructs, I/O operators and other built-in functionality
815is not available in the safe scripting environment, and the number of 880is not available in the safe scripting environment, and the number of
816functions and methods that cna be called is greatly reduced. 881functions and methods that can be called is greatly reduced.
817 882
818=cut 883=cut
819 884
820our $safe = new Safe "safe"; 885our $safe = new Safe "safe";
821our $safe_hole = new Safe::Hole; 886our $safe_hole = new Safe::Hole;
… …
828 893
829=pod 894=pod
830 895
831The following fucntions and emthods are available within a safe environment: 896The following fucntions and emthods are available within a safe environment:
832 897
833 cf::object contr pay_amount pay_player 898 cf::object contr pay_amount pay_player map
834 cf::object::player player 899 cf::object::player player
835 cf::player peaceful 900 cf::player peaceful
901 cf::map trigger
836 902
837=cut 903=cut
838 904
839for ( 905for (
840 ["cf::object" => qw(contr pay_amount pay_player)], 906 ["cf::object" => qw(contr pay_amount pay_player map)],
841 ["cf::object::player" => qw(player)], 907 ["cf::object::player" => qw(player)],
842 ["cf::player" => qw(peaceful)], 908 ["cf::player" => qw(peaceful)],
909 ["cf::map" => qw(trigger)],
843) { 910) {
844 no strict 'refs'; 911 no strict 'refs';
845 my ($pkg, @funs) = @$_; 912 my ($pkg, @funs) = @$_;
846 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 913 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
847 for @funs; 914 for @funs;
… …
912 *{"safe::$fun"} = $safe_hole->wrap ($cb); 979 *{"safe::$fun"} = $safe_hole->wrap ($cb);
913} 980}
914 981
915=back 982=back
916 983
984=cut
985
917############################################################################# 986#############################################################################
918 987
919=head2 EXTENSION DATABASE SUPPORT 988=head2 EXTENSION DATABASE SUPPORT
920 989
921Crossfire maintains a very simple database for extension use. It can 990Crossfire maintains a very simple database for extension use. It can
… …
955 1024
956Immediately write the database to disk I<if it is dirty>. 1025Immediately write the database to disk I<if it is dirty>.
957 1026
958=cut 1027=cut
959 1028
1029our $DB;
1030
960{ 1031{
961 my $db;
962 my $path = cf::localdir . "/database.pst"; 1032 my $path = cf::localdir . "/database.pst";
963 1033
964 sub db_load() { 1034 sub db_load() {
965 warn "loading database $path\n";#d# remove later 1035 warn "loading database $path\n";#d# remove later
966 $db = stat $path ? Storable::retrieve $path : { }; 1036 $DB = stat $path ? Storable::retrieve $path : { };
967 } 1037 }
968 1038
969 my $pid; 1039 my $pid;
970 1040
971 sub db_save() { 1041 sub db_save() {
972 warn "saving database $path\n";#d# remove later 1042 warn "saving database $path\n";#d# remove later
973 waitpid $pid, 0 if $pid; 1043 waitpid $pid, 0 if $pid;
974 if (0 == ($pid = fork)) { 1044 if (0 == ($pid = fork)) {
975 $db->{_meta}{version} = 1; 1045 $DB->{_meta}{version} = 1;
976 Storable::nstore $db, "$path~"; 1046 Storable::nstore $DB, "$path~";
977 rename "$path~", $path; 1047 rename "$path~", $path;
978 cf::_exit 0 if defined $pid; 1048 cf::_exit 0 if defined $pid;
979 } 1049 }
980 } 1050 }
981 1051
… …
984 sub db_sync() { 1054 sub db_sync() {
985 db_save if $dirty; 1055 db_save if $dirty;
986 undef $dirty; 1056 undef $dirty;
987 } 1057 }
988 1058
989 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 {
990 db_sync; 1060 db_sync;
991 }); 1061 });
992 1062
993 sub db_dirty() { 1063 sub db_dirty() {
994 $dirty = 1; 1064 $dirty = 1;
995 $idle->start; 1065 $idle->start;
996 } 1066 }
997 1067
998 sub db_get($;$) { 1068 sub db_get($;$) {
999 @_ >= 2 1069 @_ >= 2
1000 ? $db->{$_[0]}{$_[1]} 1070 ? $DB->{$_[0]}{$_[1]}
1001 : ($db->{$_[0]} ||= { }) 1071 : ($DB->{$_[0]} ||= { })
1002 } 1072 }
1003 1073
1004 sub db_put($$;$) { 1074 sub db_put($$;$) {
1005 if (@_ >= 3) { 1075 if (@_ >= 3) {
1006 $db->{$_[0]}{$_[1]} = $_[2]; 1076 $DB->{$_[0]}{$_[1]} = $_[2];
1007 } else { 1077 } else {
1008 $db->{$_[0]} = $_[1]; 1078 $DB->{$_[0]} = $_[1];
1009 } 1079 }
1010 db_dirty; 1080 db_dirty;
1011 } 1081 }
1012 1082
1013 attach_global 1083 attach_global
… …
1019} 1089}
1020 1090
1021############################################################################# 1091#############################################################################
1022# the server's main() 1092# the server's main()
1023 1093
1094sub cfg_load {
1095 open my $fh, "<:utf8", cf::confdir . "/config"
1096 or return;
1097
1098 local $/;
1099 *CFG = YAML::Syck::Load <$fh>;
1100}
1101
1024sub main { 1102sub main {
1103 cfg_load;
1025 db_load; 1104 db_load;
1026 load_extensions; 1105 load_extensions;
1027 Event::loop; 1106 Event::loop;
1028} 1107}
1029 1108
… …
1035 1114
1036 $msg->("reloading..."); 1115 $msg->("reloading...");
1037 1116
1038 eval { 1117 eval {
1039 # cancel all watchers 1118 # cancel all watchers
1040 $_->cancel for Event::all_watchers; 1119 for (Event::all_watchers) {
1120 $_->cancel if $_->data & WF_AUTOCANCEL;
1121 }
1041 1122
1042 # unload all extensions 1123 # unload all extensions
1043 for (@exts) { 1124 for (@exts) {
1044 $msg->("unloading <$_>"); 1125 $msg->("unloading <$_>");
1045 unload_extension $_; 1126 unload_extension $_;
… …
1081 1162
1082 # reload cf.pm 1163 # reload cf.pm
1083 $msg->("reloading cf.pm"); 1164 $msg->("reloading cf.pm");
1084 require cf; 1165 require cf;
1085 1166
1086 # load database again 1167 # load config and database again
1168 cf::cfg_load;
1087 cf::db_load; 1169 cf::db_load;
1088 1170
1089 # load extensions 1171 # load extensions
1090 $msg->("load extensions"); 1172 $msg->("load extensions");
1091 cf::load_extensions; 1173 cf::load_extensions;
… …
1104 warn $_[0]; 1186 warn $_[0];
1105 print "$_[0]\n"; 1187 print "$_[0]\n";
1106 }; 1188 };
1107} 1189}
1108 1190
1191register "<global>", __PACKAGE__;
1192
1109register_command "perl-reload", 0, sub { 1193register_command "perl-reload" => sub {
1110 my ($who, $arg) = @_; 1194 my ($who, $arg) = @_;
1111 1195
1112 if ($who->flag (FLAG_WIZ)) { 1196 if ($who->flag (FLAG_WIZ)) {
1113 _perl_reload { 1197 _perl_reload {
1114 warn $_[0]; 1198 warn $_[0];
1115 $who->message ($_[0]); 1199 $who->message ($_[0]);
1116 }; 1200 };
1117 } 1201 }
1118}; 1202};
1119 1203
1120register "<global>", __PACKAGE__;
1121
1122unshift @INC, $LIBDIR; 1204unshift @INC, $LIBDIR;
1123 1205
1124$TICK_WATCHER = Event->timer ( 1206$TICK_WATCHER = Event->timer (
1125 prio => 1, 1207 prio => 0,
1126 at => $NEXT_TICK || 1, 1208 at => $NEXT_TICK || 1,
1209 data => WF_AUTOCANCEL,
1127 cb => sub { 1210 cb => sub {
1128 cf::server_tick; # one server iteration 1211 cf::server_tick; # one server iteration
1129 1212
1130 my $NOW = Event::time; 1213 my $NOW = Event::time;
1131 $NEXT_TICK += $TICK; 1214 $NEXT_TICK += $TICK;
1132 1215
1133 # if we are delayed by four ticks, skip them all 1216 # if we are delayed by four ticks or more, skip them all
1134 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1217 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1135 1218
1136 $TICK_WATCHER->at ($NEXT_TICK); 1219 $TICK_WATCHER->at ($NEXT_TICK);
1137 $TICK_WATCHER->start; 1220 $TICK_WATCHER->start;
1138 }, 1221 },
1139); 1222);
1140 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
11411 12321
1142 1233

Diff Legend

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