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.59 by root, Wed Aug 30 16:30:37 2006 UTC vs.
Revision 1.87 by root, Thu Dec 14 22:45:40 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
16_reload_1; 21sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
17 22
18our %COMMAND = (); 23our %COMMAND = ();
24our %COMMAND_TIME = ();
25our %EXTCMD = ();
26
27_init_vars;
28
19our @EVENT; 29our @EVENT;
20our %PROP_TYPE;
21our %PROP_IDX;
22our $LIBDIR = maps_directory "perl"; 30our $LIBDIR = maps_directory "perl";
23 31
24our $TICK = MAX_TIME * 1e-6; 32our $TICK = MAX_TIME * 1e-6;
25our $TICK_WATCHER; 33our $TICK_WATCHER;
26our $NEXT_TICK; 34our $NEXT_TICK;
35
36our %CFG;
37
38our $UPTIME; $UPTIME ||= time;
39
40#############################################################################
41
42=head2 GLOBAL VARIABLES
43
44=over 4
45
46=item $cf::UPTIME
47
48The timestamp of the server start (so not actually an uptime).
49
50=item $cf::LIBDIR
51
52The perl library directory, where extensions and cf-specific modules can
53be found. It will be added to C<@INC> automatically.
54
55=item $cf::TICK
56
57The interval between server ticks, in seconds.
58
59=item %cf::CFG
60
61Configuration for the server, loaded from C</etc/crossfire/config>, or
62from wherever your confdir points to.
63
64=back
65
66=cut
27 67
28BEGIN { 68BEGIN {
29 *CORE::GLOBAL::warn = sub { 69 *CORE::GLOBAL::warn = sub {
30 my $msg = join "", @_; 70 my $msg = join "", @_;
31 $msg .= "\n" 71 $msg .= "\n"
… …
34 print STDERR "cfperl: $msg"; 74 print STDERR "cfperl: $msg";
35 LOG llevError, "cfperl: $msg"; 75 LOG llevError, "cfperl: $msg";
36 }; 76 };
37} 77}
38 78
39my %ignore_set = (MAP_PROP_PATH => 1); # I hate the plug-in api. Deeply!
40
41# generate property mutators
42sub prop_gen {
43 my ($prefix, $class) = @_;
44
45 no strict 'refs';
46
47 for my $prop (keys %PROP_TYPE) {
48 $prop =~ /^\Q$prefix\E_(.*$)/ or next;
49 my $sub = lc $1;
50
51 my $type = $PROP_TYPE{$prop};
52 my $idx = $PROP_IDX {$prop};
53
54 *{"$class\::get_$sub"} = *{"$class\::$sub"} = sub {
55 $_[0]->get_property ($type, $idx)
56 };
57
58 *{"$class\::set_$sub"} = sub {
59 $_[0]->set_property ($type, $idx, $_[1]);
60 } unless $ignore_set{$prop};
61 }
62}
63
64# auto-generate most of the API
65
66prop_gen OBJECT_PROP => "cf::object";
67# CFAPI_OBJECT_ANIMATION?
68prop_gen PLAYER_PROP => "cf::object::player";
69
70prop_gen MAP_PROP => "cf::map";
71prop_gen ARCH_PROP => "cf::arch";
72
73@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 79@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object';
74 80
75# 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
76# within the Safe compartment. 82# within the Safe compartment.
77for 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_socket cf::player
86 cf::arch cf::living
87 cf::map cf::party cf::region
88)) {
78 no strict 'refs'; 89 no strict 'refs';
79 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 90 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
80} 91}
81 92
82$Event::DIED = sub { 93$Event::DIED = sub {
… …
84}; 95};
85 96
86my %ext_pkg; 97my %ext_pkg;
87my @exts; 98my @exts;
88my @hook; 99my @hook;
89my %command;
90my %extcmd;
91 100
92############################################################################# 101=head2 UTILITY FUNCTIONS
93# utility functions 102
103=over 4
104
105=cut
94 106
95use JSON::Syck (); # TODO# replace by JSON::PC once working 107use JSON::Syck (); # TODO# replace by JSON::PC once working
108
109=item $ref = cf::from_json $json
110
111Converts a JSON string into the corresponding perl data structure.
112
113=cut
96 114
97sub from_json($) { 115sub from_json($) {
98 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs 116 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
99 JSON::Syck::Load $_[0] 117 JSON::Syck::Load $_[0]
100} 118}
101 119
120=item $json = cf::to_json $ref
121
122Converts a perl data structure into its JSON representation.
123
124=cut
125
102sub to_json($) { 126sub to_json($) {
103 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 127 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
104 JSON::Syck::Dump $_[0] 128 JSON::Syck::Dump $_[0]
105} 129}
106 130
131=back
132
133=cut
134
107############################################################################# 135#############################################################################
108# "new" plug-in system
109 136
110=head3 EVENTS AND OBJECT ATTACHMENTS 137=head2 EVENTS AND OBJECT ATTACHMENTS
111 138
112=over 4 139=over 4
113 140
114=item $object->attach ($attachment, key => $value...) 141=item $object->attach ($attachment, key => $value...)
115 142
… …
389 for (@$callbacks) { 416 for (@$callbacks) {
390 eval { &{$_->[1]} }; 417 eval { &{$_->[1]} };
391 418
392 if ($@) { 419 if ($@) {
393 warn "$@"; 420 warn "$@";
394 warn "... while processing $EVENT[$event][0] event, skipping processing altogether.\n"; 421 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
395 override; 422 override;
396 } 423 }
397 424
398 return 1 if $override; 425 return 1 if $override;
399 } 426 }
… …
415removed in future versions), and there is no public API to access override 442removed in future versions), and there is no public API to access override
416results (if you must, access C<@cf::invoke_results> directly). 443results (if you must, access C<@cf::invoke_results> directly).
417 444
418=back 445=back
419 446
420=head2 methods valid for all pointers 447=cut
448
449#############################################################################
450
451=head2 METHODS VALID FOR ALL CORE OBJECTS
421 452
422=over 4 453=over 4
423 454
424=item $object->valid 455=item $object->valid, $player->valid, $map->valid
425
426=item $player->valid
427
428=item $map->valid
429 456
430Just because you have a perl object does not mean that the corresponding 457Just because you have a perl object does not mean that the corresponding
431C-level object still exists. If you try to access an object that has no 458C-level object still exists. If you try to access an object that has no
432valid C counterpart anymore you get an exception at runtime. This method 459valid C counterpart anymore you get an exception at runtime. This method
433can be used to test for existence of the C object part without causing an 460can be used to test for existence of the C object part without causing an
… …
478} 505}
479 506
480sub object_freezer_save { 507sub object_freezer_save {
481 my ($filename, $rdata, $objs) = @_; 508 my ($filename, $rdata, $objs) = @_;
482 509
510 if (length $$rdata) {
511 warn sprintf "saving %s (%d,%d)\n",
512 $filename, length $$rdata, scalar @$objs;
513
483 if (open my $fh, ">:raw", "$filename~") { 514 if (open my $fh, ">:raw", "$filename~") {
484 chmod SAVE_MODE, $fh;
485 syswrite $fh, $$rdata;
486 close $fh;
487
488 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
489 chmod SAVE_MODE, $fh; 515 chmod SAVE_MODE, $fh;
490 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 516 syswrite $fh, $$rdata;
491 close $fh; 517 close $fh;
518
519 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
520 chmod SAVE_MODE, $fh;
521 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs };
522 close $fh;
492 rename "$filename.pst~", "$filename.pst"; 523 rename "$filename.pst~", "$filename.pst";
524 } else {
525 unlink "$filename.pst";
526 }
527
528 rename "$filename~", $filename;
493 } else { 529 } else {
494 unlink "$filename.pst"; 530 warn "FATAL: $filename~: $!\n";
495 } 531 }
496
497 rename "$filename~", $filename;
498 } else { 532 } else {
499 warn "FATAL: $filename~: $!\n"; 533 unlink $filename;
534 unlink "$filename.pst";
500 } 535 }
536}
537
538sub object_freezer_as_string {
539 my ($rdata, $objs) = @_;
540
541 use Data::Dumper;
542
543 $$rdata . Dumper $objs
501} 544}
502 545
503sub object_thawer_load { 546sub object_thawer_load {
504 my ($filename) = @_; 547 my ($filename) = @_;
505 548
549 local $/;
550
551 my $av;
552
553 #TODO: use sysread etc.
554 if (open my $data, "<:raw:perlio", $filename) {
555 $data = <$data>;
506 open my $fh, "<:raw:perlio", "$filename.pst" 556 if (open my $pst, "<:raw:perlio", "$filename.pst") {
507 or return; 557 $av = eval { (Storable::thaw <$pst>)->{objs} };
558 }
559 return ($data, $av);
560 }
508 561
509 eval { local $/; (Storable::thaw <$fh>)->{objs} } 562 ()
510} 563}
511 564
512attach_to_objects 565attach_to_objects
513 prio => -1000000, 566 prio => -1000000,
514 on_clone => sub { 567 on_clone => sub {
… …
522 if exists $src->{_attachment}; 575 if exists $src->{_attachment};
523 }, 576 },
524; 577;
525 578
526############################################################################# 579#############################################################################
527# old plug-in events 580# command handling &c
528 581
529sub inject_event { 582=item cf::register_command $name => \&callback($ob,$args);
530 my $extension = shift;
531 my $event_code = shift;
532 583
533 my $cb = $hook[$event_code]{$extension} 584Register a callback for execution when the client sends the user command
534 or return; 585$name.
535 586
536 &$cb 587=cut
537}
538
539sub inject_global_event {
540 my $event = shift;
541
542 my $cb = $hook[$event]
543 or return;
544
545 List::Util::max map &$_, values %$cb
546}
547
548sub inject_command {
549 my ($name, $obj, $params) = @_;
550
551 for my $cmd (@{ $command{$name} }) {
552 $cmd->[1]->($obj, $params);
553 }
554
555 -1
556}
557 588
558sub register_command { 589sub register_command {
559 my ($name, $time, $cb) = @_; 590 my ($name, $cb) = @_;
560 591
561 my $caller = caller; 592 my $caller = caller;
562 #warn "registering command '$name/$time' to '$caller'"; 593 #warn "registering command '$name/$time' to '$caller'";
563 594
564 push @{ $command{$name} }, [$time, $cb, $caller]; 595 push @{ $COMMAND{$name} }, [$caller, $cb];
565 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @{ $command{$name} };
566} 596}
597
598=item cf::register_extcmd $name => \&callback($pl,$packet);
599
600Register a callbackf ro execution when the client sends an extcmd packet.
601
602If the callback returns something, it is sent back as if reply was being
603called.
604
605=cut
567 606
568sub register_extcmd { 607sub register_extcmd {
569 my ($name, $cb) = @_; 608 my ($name, $cb) = @_;
570 609
571 my $caller = caller; 610 my $caller = caller;
572 #warn "registering extcmd '$name' to '$caller'"; 611 #warn "registering extcmd '$name' to '$caller'";
573 612
574 $extcmd{$name} = [$cb, $caller]; 613 $EXTCMD{$name} = [$cb, $caller];
575} 614}
615
616attach_to_players
617 on_command => sub {
618 my ($pl, $name, $params) = @_;
619
620 my $cb = $COMMAND{$name}
621 or return;
622
623 for my $cmd (@$cb) {
624 $cmd->[1]->($pl->ob, $params);
625 }
626
627 cf::override;
628 },
629 on_extcmd => sub {
630 my ($pl, $buf) = @_;
631
632 my $msg = eval { from_json $buf };
633
634 if (ref $msg) {
635 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
636 if (my %reply = $cb->[0]->($pl, $msg)) {
637 $pl->ext_reply ($msg->{msgid}, %reply);
638 }
639 }
640 } else {
641 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
642 }
643
644 cf::override;
645 },
646;
576 647
577sub register { 648sub register {
578 my ($base, $pkg) = @_; 649 my ($base, $pkg) = @_;
579 650
580 #TODO 651 #TODO
… …
599 . "#line 1 \"$path\"\n{\n" 670 . "#line 1 \"$path\"\n{\n"
600 . (do { local $/; <$fh> }) 671 . (do { local $/; <$fh> })
601 . "\n};\n1"; 672 . "\n};\n1";
602 673
603 eval $source 674 eval $source
604 or die "$path: $@"; 675 or die $@ ? "$path: $@\n"
676 : "extension disabled.\n";
605 677
606 push @exts, $pkg; 678 push @exts, $pkg;
607 $ext_pkg{$base} = $pkg; 679 $ext_pkg{$base} = $pkg;
608 680
609# no strict 'refs'; 681# no strict 'refs';
… …
622# for my $idx (0 .. $#PLUGIN_EVENT) { 694# for my $idx (0 .. $#PLUGIN_EVENT) {
623# delete $hook[$idx]{$pkg}; 695# delete $hook[$idx]{$pkg};
624# } 696# }
625 697
626 # remove commands 698 # remove commands
627 for my $name (keys %command) { 699 for my $name (keys %COMMAND) {
628 my @cb = grep $_->[2] ne $pkg, @{ $command{$name} }; 700 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
629 701
630 if (@cb) { 702 if (@cb) {
631 $command{$name} = \@cb; 703 $COMMAND{$name} = \@cb;
632 $COMMAND{"$name\000"} = List::Util::max map $_->[0], @cb;
633 } else { 704 } else {
634 delete $command{$name};
635 delete $COMMAND{"$name\000"}; 705 delete $COMMAND{$name};
636 } 706 }
637 } 707 }
638 708
639 # remove extcmds 709 # remove extcmds
640 for my $name (grep $extcmd{$_}[1] eq $pkg, keys %extcmd) { 710 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
641 delete $extcmd{$name}; 711 delete $EXTCMD{$name};
642 } 712 }
643 713
644 if (my $cb = $pkg->can ("unload")) { 714 if (my $cb = $pkg->can ("unload")) {
645 eval { 715 eval {
646 $cb->($pkg); 716 $cb->($pkg);
… …
661 1 731 1
662 } or warn "$ext not loaded: $@"; 732 } or warn "$ext not loaded: $@";
663 } 733 }
664} 734}
665 735
666sub _perl_reload(&) {
667 my ($msg) = @_;
668
669 $msg->("reloading...");
670
671 eval {
672 # 1. cancel all watchers
673 $_->cancel for Event::all_watchers;
674
675 # 2. unload all extensions
676 for (@exts) {
677 $msg->("unloading <$_>");
678 unload_extension $_;
679 }
680
681 # 3. unload all modules loaded from $LIBDIR
682 while (my ($k, $v) = each %INC) {
683 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
684
685 $msg->("removing <$k>");
686 delete $INC{$k};
687
688 $k =~ s/\.pm$//;
689 $k =~ s/\//::/g;
690
691 if (my $cb = $k->can ("unload_module")) {
692 $cb->();
693 }
694
695 Symbol::delete_package $k;
696 }
697
698 # 4. get rid of safe::, as good as possible
699 Symbol::delete_package "safe::$_"
700 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
701
702 # 5. remove register_script_function callbacks
703 # TODO
704
705 # 6. unload cf.pm "a bit"
706 delete $INC{"cf.pm"};
707
708 # don't, removes xs symbols, too,
709 # and global variables created in xs
710 #Symbol::delete_package __PACKAGE__;
711
712 # 7. reload cf.pm
713 $msg->("reloading cf.pm");
714 require cf;
715 };
716 $msg->($@) if $@;
717
718 $msg->("reloaded");
719};
720
721sub perl_reload() {
722 _perl_reload {
723 warn $_[0];
724 print "$_[0]\n";
725 };
726}
727
728register_command "perl-reload", 0, sub {
729 my ($who, $arg) = @_;
730
731 if ($who->flag (FLAG_WIZ)) {
732 _perl_reload {
733 warn $_[0];
734 $who->message ($_[0]);
735 };
736 }
737};
738
739#############################################################################
740# extcmd framework, basically convert ext <msg>
741# into pkg::->on_extcmd_arg1 (...) while shortcutting a few
742
743attach_to_players
744 on_extcmd => sub {
745 my ($pl, $buf) = @_;
746
747 my $msg = eval { from_json $buf };
748
749 if (ref $msg) {
750 if (my $cb = $extcmd{$msg->{msgtype}}) {
751 if (my %reply = $cb->[0]->($pl, $msg)) {
752 $pl->ext_reply ($msg->{msgid}, %reply);
753 }
754 }
755 } else {
756 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
757 }
758
759 cf::override;
760 },
761;
762
763############################################################################# 736#############################################################################
764# load/save/clean perl data associated with a map 737# load/save/clean perl data associated with a map
765 738
766*cf::mapsupport::on_clean = sub { 739*cf::mapsupport::on_clean = sub {
767 my ($map) = @_; 740 my ($map) = @_;
… …
779 752
780sub all_objects(@) { 753sub all_objects(@) {
781 @_, map all_objects ($_->inv), @_ 754 @_, map all_objects ($_->inv), @_
782} 755}
783 756
757# TODO: compatibility cruft, remove when no longer needed
784attach_to_players 758attach_to_players
785 on_load => sub { 759 on_load => sub {
786 my ($pl, $path) = @_; 760 my ($pl, $path) = @_;
787 761
788 for my $o (all_objects $pl->ob) { 762 for my $o (all_objects $pl->ob) {
… …
794 } 768 }
795 }, 769 },
796; 770;
797 771
798############################################################################# 772#############################################################################
799# core extensions - in perl 773
774=head2 CORE EXTENSIONS
775
776Functions and methods that extend core crossfire objects.
777
778=over 4
800 779
801=item cf::player::exists $login 780=item cf::player::exists $login
802 781
803Returns true when the given account exists. 782Returns true when the given account exists.
804 783
… …
807sub cf::player::exists($) { 786sub cf::player::exists($) {
808 cf::player::find $_[0] 787 cf::player::find $_[0]
809 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 788 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
810} 789}
811 790
812=item $player->reply ($npc, $msg[, $flags]) 791=item $player_object->reply ($npc, $msg[, $flags])
813 792
814Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 793Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
815can be C<undef>. Does the right thing when the player is currently in a 794can be C<undef>. Does the right thing when the player is currently in a
816dialogue with the given NPC character. 795dialogue with the given NPC character.
817 796
… …
844 $msg{msgid} = $id; 823 $msg{msgid} = $id;
845 824
846 $self->send ("ext " . to_json \%msg); 825 $self->send ("ext " . to_json \%msg);
847} 826}
848 827
828=item $player_object->may ("access")
829
830Returns wether the given player is authorized to access resource "access"
831(e.g. "command_wizcast").
832
833=cut
834
835sub cf::object::player::may {
836 my ($self, $access) = @_;
837
838 $self->flag (cf::FLAG_WIZ) ||
839 (ref $cf::CFG{"may_$access"}
840 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
841 : $cf::CFG{"may_$access"})
842}
843
844=cut
845
849############################################################################# 846#############################################################################
850# map scripting support 847
848=head2 SAFE SCRIPTING
849
850Functions that provide a safe environment to compile and execute
851snippets of perl code without them endangering the safety of the server
852itself. Looping constructs, I/O operators and other built-in functionality
853is not available in the safe scripting environment, and the number of
854functions and methods that can be called is greatly reduced.
855
856=cut
851 857
852our $safe = new Safe "safe"; 858our $safe = new Safe "safe";
853our $safe_hole = new Safe::Hole; 859our $safe_hole = new Safe::Hole;
854 860
855$SIG{FPE} = 'IGNORE'; 861$SIG{FPE} = 'IGNORE';
856 862
857$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 863$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));
858 864
859# here we export the classes and methods available to script code 865# here we export the classes and methods available to script code
866
867=pod
868
869The following fucntions and emthods are available within a safe environment:
870
871 cf::object contr pay_amount pay_player
872 cf::object::player player
873 cf::player peaceful
874
875=cut
860 876
861for ( 877for (
862 ["cf::object" => qw(contr pay_amount pay_player)], 878 ["cf::object" => qw(contr pay_amount pay_player)],
863 ["cf::object::player" => qw(player)], 879 ["cf::object::player" => qw(player)],
864 ["cf::player" => qw(peaceful)], 880 ["cf::player" => qw(peaceful)],
… …
867 my ($pkg, @funs) = @$_; 883 my ($pkg, @funs) = @$_;
868 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 884 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
869 for @funs; 885 for @funs;
870} 886}
871 887
888=over 4
889
890=item @retval = safe_eval $code, [var => value, ...]
891
892Compiled and executes the given perl code snippet. additional var/value
893pairs result in temporary local (my) scalar variables of the given name
894that are available in the code snippet. Example:
895
896 my $five = safe_eval '$first + $second', first => 1, second => 4;
897
898=cut
899
872sub safe_eval($;@) { 900sub safe_eval($;@) {
873 my ($code, %vars) = @_; 901 my ($code, %vars) = @_;
874 902
875 my $qcode = $code; 903 my $qcode = $code;
876 $qcode =~ s/"/‟/g; # not allowed in #line filenames 904 $qcode =~ s/"/‟/g; # not allowed in #line filenames
… …
898 } 926 }
899 927
900 wantarray ? @res : $res[0] 928 wantarray ? @res : $res[0]
901} 929}
902 930
931=item cf::register_script_function $function => $cb
932
933Register a function that can be called from within map/npc scripts. The
934function should be reasonably secure and should be put into a package name
935like the extension.
936
937Example: register a function that gets called whenever a map script calls
938C<rent::overview>, as used by the C<rent> extension.
939
940 cf::register_script_function "rent::overview" => sub {
941 ...
942 };
943
944=cut
945
903sub register_script_function { 946sub register_script_function {
904 my ($fun, $cb) = @_; 947 my ($fun, $cb) = @_;
905 948
906 no strict 'refs'; 949 no strict 'refs';
907 *{"safe::$fun"} = $safe_hole->wrap ($cb); 950 *{"safe::$fun"} = $safe_hole->wrap ($cb);
908} 951}
909 952
953=back
954
955=cut
956
957#############################################################################
958
959=head2 EXTENSION DATABASE SUPPORT
960
961Crossfire maintains a very simple database for extension use. It can
962currently store anything that can be serialised using Storable, which
963excludes objects.
964
965The parameter C<$family> should best start with the name of the extension
966using it, it should be unique.
967
968=over 4
969
970=item $hashref = cf::db_get $family
971
972Return a hashref for use by the extension C<$family>, which can be
973modified. After modifications, you have to call C<cf::db_dirty> or
974C<cf::db_sync>.
975
976=item $value = cf::db_get $family => $key
977
978Returns a single value from the database
979
980=item cf::db_put $family => $hashref
981
982Stores the given family hashref into the database. Updates are delayed, if
983you want the data to be synced to disk immediately, use C<cf::db_sync>.
984
985=item cf::db_put $family => $key => $value
986
987Stores the given C<$value> in the family hash. Updates are delayed, if you
988want the data to be synced to disk immediately, use C<cf::db_sync>.
989
990=item cf::db_dirty
991
992Marks the database as dirty, to be updated at a later time.
993
994=item cf::db_sync
995
996Immediately write the database to disk I<if it is dirty>.
997
998=cut
999
1000our $DB;
1001
1002{
1003 my $path = cf::localdir . "/database.pst";
1004
1005 sub db_load() {
1006 warn "loading database $path\n";#d# remove later
1007 $DB = stat $path ? Storable::retrieve $path : { };
1008 }
1009
1010 my $pid;
1011
1012 sub db_save() {
1013 warn "saving database $path\n";#d# remove later
1014 waitpid $pid, 0 if $pid;
1015 if (0 == ($pid = fork)) {
1016 $DB->{_meta}{version} = 1;
1017 Storable::nstore $DB, "$path~";
1018 rename "$path~", $path;
1019 cf::_exit 0 if defined $pid;
1020 }
1021 }
1022
1023 my $dirty;
1024
1025 sub db_sync() {
1026 db_save if $dirty;
1027 undef $dirty;
1028 }
1029
1030 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1031 db_sync;
1032 });
1033
1034 sub db_dirty() {
1035 $dirty = 1;
1036 $idle->start;
1037 }
1038
1039 sub db_get($;$) {
1040 @_ >= 2
1041 ? $DB->{$_[0]}{$_[1]}
1042 : ($DB->{$_[0]} ||= { })
1043 }
1044
1045 sub db_put($$;$) {
1046 if (@_ >= 3) {
1047 $DB->{$_[0]}{$_[1]} = $_[2];
1048 } else {
1049 $DB->{$_[0]} = $_[1];
1050 }
1051 db_dirty;
1052 }
1053
1054 attach_global
1055 prio => 10000,
1056 on_cleanup => sub {
1057 db_sync;
1058 },
1059 ;
1060}
1061
910############################################################################# 1062#############################################################################
911# the server's main() 1063# the server's main()
912 1064
1065sub cfg_load {
1066 open my $fh, "<:utf8", cf::confdir . "/config"
1067 or return;
1068
1069 local $/;
1070 *CFG = YAML::Syck::Load <$fh>;
1071}
1072
913sub main { 1073sub main {
1074 cfg_load;
1075 db_load;
1076 load_extensions;
914 Event::loop; 1077 Event::loop;
915} 1078}
916 1079
917############################################################################# 1080#############################################################################
918# initialisation 1081# initialisation
919 1082
1083sub _perl_reload(&) {
1084 my ($msg) = @_;
1085
1086 $msg->("reloading...");
1087
1088 eval {
1089 # cancel all watchers
1090 for (Event::all_watchers) {
1091 $_->cancel if $_->data & WF_AUTOCANCEL;
1092 }
1093
1094 # unload all extensions
1095 for (@exts) {
1096 $msg->("unloading <$_>");
1097 unload_extension $_;
1098 }
1099
1100 # unload all modules loaded from $LIBDIR
1101 while (my ($k, $v) = each %INC) {
1102 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1103
1104 $msg->("removing <$k>");
1105 delete $INC{$k};
1106
1107 $k =~ s/\.pm$//;
1108 $k =~ s/\//::/g;
1109
1110 if (my $cb = $k->can ("unload_module")) {
1111 $cb->();
1112 }
1113
1114 Symbol::delete_package $k;
1115 }
1116
1117 # sync database to disk
1118 cf::db_sync;
1119
1120 # get rid of safe::, as good as possible
1121 Symbol::delete_package "safe::$_"
1122 for qw(cf::object cf::object::player cf::player cf::map cf::party cf::region);
1123
1124 # remove register_script_function callbacks
1125 # TODO
1126
1127 # unload cf.pm "a bit"
1128 delete $INC{"cf.pm"};
1129
1130 # don't, removes xs symbols, too,
1131 # and global variables created in xs
1132 #Symbol::delete_package __PACKAGE__;
1133
1134 # reload cf.pm
1135 $msg->("reloading cf.pm");
1136 require cf;
1137
1138 # load config and database again
1139 cf::cfg_load;
1140 cf::db_load;
1141
1142 # load extensions
1143 $msg->("load extensions");
1144 cf::load_extensions;
1145
1146 # reattach attachments to objects
1147 $msg->("reattach");
1148 _global_reattach;
1149 };
1150 $msg->($@) if $@;
1151
1152 $msg->("reloaded");
1153};
1154
1155sub perl_reload() {
1156 _perl_reload {
1157 warn $_[0];
1158 print "$_[0]\n";
1159 };
1160}
1161
920register "<global>", __PACKAGE__; 1162register "<global>", __PACKAGE__;
921 1163
1164register_command "perl-reload" => sub {
1165 my ($who, $arg) = @_;
1166
1167 if ($who->flag (FLAG_WIZ)) {
1168 _perl_reload {
1169 warn $_[0];
1170 $who->message ($_[0]);
1171 };
1172 }
1173};
1174
922unshift @INC, $LIBDIR; 1175unshift @INC, $LIBDIR;
923 1176
924load_extensions;
925
926$TICK_WATCHER = Event->timer ( 1177$TICK_WATCHER = Event->timer (
927 prio => 1, 1178 prio => 1,
1179 async => 1,
928 at => $NEXT_TICK || 1, 1180 at => $NEXT_TICK || 1,
1181 data => WF_AUTOCANCEL,
929 cb => sub { 1182 cb => sub {
930 cf::server_tick; # one server iteration 1183 cf::server_tick; # one server iteration
931 1184
932 my $NOW = Event::time; 1185 my $NOW = Event::time;
933 $NEXT_TICK += $TICK; 1186 $NEXT_TICK += $TICK;
934 1187
935 # if we are delayed by four ticks, skip them all 1188 # if we are delayed by four ticks or more, skip them all
936 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 1189 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
937 1190
938 $TICK_WATCHER->at ($NEXT_TICK); 1191 $TICK_WATCHER->at ($NEXT_TICK);
939 $TICK_WATCHER->start; 1192 $TICK_WATCHER->start;
940 }, 1193 },
941); 1194);
942 1195
943_reload_2; 1196IO::AIO::max_poll_time $TICK * 0.2;
1197
1198Event->io (fd => IO::AIO::poll_fileno,
1199 poll => 'r',
1200 prio => 5,
1201 data => WF_AUTOCANCEL,
1202 cb => \&IO::AIO::poll_cb);
944 1203
9451 12041
946 1205

Diff Legend

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