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.461 by root, Fri Dec 19 22:47:29 2008 UTC vs.
Revision 1.468 by root, Thu Jan 8 19:23:44 2009 UTC

21 21
22package cf; 22package cf;
23 23
24use 5.10.0; 24use 5.10.0;
25use utf8; 25use utf8;
26use strict "vars", "subs"; 26use strict qw(vars subs);
27 27
28use Symbol; 28use Symbol;
29use List::Util; 29use List::Util;
30use Socket; 30use Socket;
31use EV; 31use EV;
112our $BDB_DEADLOCK_WATCHER; 112our $BDB_DEADLOCK_WATCHER;
113our $BDB_CHECKPOINT_WATCHER; 113our $BDB_CHECKPOINT_WATCHER;
114our $BDB_TRICKLE_WATCHER; 114our $BDB_TRICKLE_WATCHER;
115our $DB_ENV; 115our $DB_ENV;
116 116
117our @EXTRA_MODULES = qw(pod mapscript);
118
117our %CFG; 119our %CFG;
118 120
119our $UPTIME; $UPTIME ||= time; 121our $UPTIME; $UPTIME ||= time;
120our $RUNTIME; 122our $RUNTIME;
121our $NOW; 123our $NOW;
143unless ($RUNTIME || !-e $RUNTIMEFILE) { 145unless ($RUNTIME || !-e $RUNTIMEFILE) {
144 open my $fh, "<", $RUNTIMEFILE 146 open my $fh, "<", $RUNTIMEFILE
145 or die "unable to read $RUNTIMEFILE file: $!"; 147 or die "unable to read $RUNTIMEFILE file: $!";
146 $RUNTIME = <$fh> + 0.; 148 $RUNTIME = <$fh> + 0.;
147} 149}
150
151eval "sub TICK() { $TICK } 1" or die;
148 152
149mkdir $_ 153mkdir $_
150 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 154 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
151 155
152our $EMERGENCY_POSITION; 156our $EMERGENCY_POSITION;
1862 1866
1863 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1867 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1864 "$UNIQUEDIR/$path" 1868 "$UNIQUEDIR/$path"
1865} 1869}
1866 1870
1867# and all this just because we cannot iterate over
1868# all maps in C++...
1869sub change_all_map_light {
1870 my ($change) = @_;
1871
1872 $_->change_map_light ($change)
1873 for grep $_->outdoor, values %cf::MAP;
1874}
1875
1876sub decay_objects { 1871sub decay_objects {
1877 my ($self) = @_; 1872 my ($self) = @_;
1878 1873
1879 return if $self->{deny_reset}; 1874 return if $self->{deny_reset};
1880 1875
2042 2037
2043 unless ($self->{deny_activate}) { 2038 unless ($self->{deny_activate}) {
2044 $self->decay_objects; 2039 $self->decay_objects;
2045 $self->fix_auto_apply; 2040 $self->fix_auto_apply;
2046 $self->update_buttons; 2041 $self->update_buttons;
2047 cf::cede_to_tick;
2048 $self->set_darkness_map;
2049 cf::cede_to_tick; 2042 cf::cede_to_tick;
2050 $self->activate; 2043 $self->activate;
2051 } 2044 }
2052 2045
2053 $self->{last_save} = $cf::RUNTIME; 2046 $self->{last_save} = $cf::RUNTIME;
2395 2388
2396our $SAY_CHANNEL = { 2389our $SAY_CHANNEL = {
2397 id => "say", 2390 id => "say",
2398 title => "Map", 2391 title => "Map",
2399 reply => "say ", 2392 reply => "say ",
2400 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2393 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2401}; 2394};
2402 2395
2403our $CHAT_CHANNEL = { 2396our $CHAT_CHANNEL = {
2404 id => "chat", 2397 id => "chat",
2405 title => "Chat", 2398 title => "Chat",
2780 id => "infobox", 2773 id => "infobox",
2781 title => "Body Parts", 2774 title => "Body Parts",
2782 reply => undef, 2775 reply => undef,
2783 tooltip => "Shows which body parts you posess and are available", 2776 tooltip => "Shows which body parts you posess and are available",
2784 }, 2777 },
2778 "c/statistics" => {
2779 id => "infobox",
2780 title => "Statistics",
2781 reply => undef,
2782 tooltip => "Shows your primary statistics",
2783 },
2785 "c/skills" => { 2784 "c/skills" => {
2786 id => "infobox", 2785 id => "infobox",
2787 title => "Skills", 2786 title => "Skills",
2788 reply => undef, 2787 reply => undef,
2789 tooltip => "Shows your experience per skill and item power", 2788 tooltip => "Shows your experience per skill and item power",
2789 },
2790 "c/resistances" => {
2791 id => "infobox",
2792 title => "Resistances",
2793 reply => undef,
2794 tooltip => "Shows your resistances",
2795 },
2796 "c/pets" => {
2797 id => "infobox",
2798 title => "Pets",
2799 reply => undef,
2800 tooltip => "Shows information abotu your pets/a specific pet",
2790 }, 2801 },
2791 "c/uptime" => { 2802 "c/uptime" => {
2792 id => "infobox", 2803 id => "infobox",
2793 title => "Uptime", 2804 title => "Uptime",
2794 reply => undef, 2805 reply => undef,
2804 id => "party", 2815 id => "party",
2805 title => "Party", 2816 title => "Party",
2806 reply => "gsay ", 2817 reply => "gsay ",
2807 tooltip => "Messages and chat related to your party", 2818 tooltip => "Messages and chat related to your party",
2808 }, 2819 },
2820 "c/death" => {
2821 id => "death",
2822 title => "Death",
2823 reply => undef,
2824 tooltip => "Reason for and more info about your most recent death",
2825 },
2826 "c/say" => $SAY_CHANNEL,
2827 "c/chat" => $CHAT_CHANNEL,
2809); 2828);
2810 2829
2811sub cf::client::send_msg { 2830sub cf::client::send_msg {
2812 my ($self, $channel, $msg, $color, @extra) = @_; 2831 my ($self, $channel, $msg, $color, @extra) = @_;
2813 2832
2818 2837
2819 # check predefined channels, for the benefit of C 2838 # check predefined channels, for the benefit of C
2820 if ($CHANNEL{$channel}) { 2839 if ($CHANNEL{$channel}) {
2821 $channel = $CHANNEL{$channel}; 2840 $channel = $CHANNEL{$channel};
2822 2841
2823 $self->ext_msg (channel_info => $channel) 2842 $self->ext_msg (channel_info => $channel);
2824 if $self->can_msg;
2825
2826 $channel = $channel->{id}; 2843 $channel = $channel->{id};
2827 2844
2828 } elsif (ref $channel) { 2845 } elsif (ref $channel) {
2829 # send meta info to client, if not yet sent 2846 # send meta info to client, if not yet sent
2830 unless (exists $self->{channel}{$channel->{id}}) { 2847 unless (exists $self->{channel}{$channel->{id}}) {
2831 $self->{channel}{$channel->{id}} = $channel; 2848 $self->{channel}{$channel->{id}} = $channel;
2832 $self->ext_msg (channel_info => $channel) 2849 $self->ext_msg (channel_info => $channel);
2833 if $self->can_msg;
2834 } 2850 }
2835 2851
2836 $channel = $channel->{id}; 2852 $channel = $channel->{id};
2837 } 2853 }
2838 2854
2839 return unless @extra || length $msg; 2855 return unless @extra || length $msg;
2840 2856
2841 if ($self->can_msg) {
2842 # default colour, mask it out 2857 # default colour, mask it out
2843 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2858 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2844 if $color & cf::NDI_DEF; 2859 if $color & cf::NDI_DEF;
2845 2860
2846 my $pkt = "msg " 2861 my $pkt = "msg "
2847 . $self->{json_coder}->encode ( 2862 . $self->{json_coder}->encode (
2848 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 2863 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2849 ); 2864 );
2850 2865
2851 # try lzf for large packets 2866 # try lzf for large packets
2852 $pkt = "lzf " . Compress::LZF::compress $pkt 2867 $pkt = "lzf " . Compress::LZF::compress $pkt
2853 if 1024 <= length $pkt and $self->{can_lzf}; 2868 if 1024 <= length $pkt and $self->{can_lzf};
2854 2869
2855 # split very large packets 2870 # split very large packets
2856 if (8192 < length $pkt and $self->{can_lzf}) { 2871 if (8192 < length $pkt and $self->{can_lzf}) {
2857 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt; 2872 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2858 $pkt = "frag"; 2873 $pkt = "frag";
2859 } 2874 }
2860 2875
2861 $self->send_packet ($pkt); 2876 $self->send_packet ($pkt);
2862 } else {
2863 if ($color >= 0) {
2864 # replace some tags by gcfclient-compatible ones
2865 for ($msg) {
2866 1 while
2867 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2868 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2869 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2870 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2871 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2872 }
2873
2874 $color &= cf::NDI_COLOR_MASK;
2875
2876 utf8::encode $msg;
2877
2878 if (0 && $msg =~ /\[/) {
2879 # COMMAND/INFO
2880 $self->send_packet ("drawextinfo $color 10 8 $msg")
2881 } else {
2882 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2883 $self->send_packet ("drawinfo $color $msg")
2884 }
2885 }
2886 }
2887} 2877}
2888 2878
2889=item $client->ext_msg ($type, @msg) 2879=item $client->ext_msg ($type, @msg)
2890 2880
2891Sends an ext event to the client. 2881Sends an ext event to the client.
3066The following functions and methods are available within a safe environment: 3056The following functions and methods are available within a safe environment:
3067 3057
3068 cf::object 3058 cf::object
3069 contr pay_amount pay_player map x y force_find force_add destroy 3059 contr pay_amount pay_player map x y force_find force_add destroy
3070 insert remove name archname title slaying race decrease split 3060 insert remove name archname title slaying race decrease split
3061 value
3071 3062
3072 cf::object::player 3063 cf::object::player
3073 player 3064 player
3074 3065
3075 cf::player 3066 cf::player
3081=cut 3072=cut
3082 3073
3083for ( 3074for (
3084 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3075 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3085 insert remove inv nrof name archname title slaying race 3076 insert remove inv nrof name archname title slaying race
3086 decrease split destroy change_exp)], 3077 decrease split destroy change_exp value msg lore send_msg)],
3087 ["cf::object::player" => qw(player)], 3078 ["cf::object::player" => qw(player)],
3088 ["cf::player" => qw(peaceful)], 3079 ["cf::player" => qw(peaceful send_msg)],
3089 ["cf::map" => qw(trigger)], 3080 ["cf::map" => qw(trigger)],
3090) { 3081) {
3091 no strict 'refs'; 3082 no strict 'refs';
3092 my ($pkg, @funs) = @$_; 3083 my ($pkg, @funs) = @$_;
3093 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3084 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3110 my ($code, %vars) = @_; 3101 my ($code, %vars) = @_;
3111 3102
3112 my $qcode = $code; 3103 my $qcode = $code;
3113 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3104 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3114 $qcode =~ s/\n/\\n/g; 3105 $qcode =~ s/\n/\\n/g;
3106
3107 %vars = (_dummy => 0) unless %vars;
3115 3108
3116 local $_; 3109 local $_;
3117 local @safe::cf::_safe_eval_args = values %vars; 3110 local @safe::cf::_safe_eval_args = values %vars;
3118 3111
3119 my $eval = 3112 my $eval =
3707 clear_package "safe::$_" 3700 clear_package "safe::$_"
3708 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3701 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3709 3702
3710 warn "unloading cf.pm \"a bit\""; 3703 warn "unloading cf.pm \"a bit\"";
3711 delete $INC{"cf.pm"}; 3704 delete $INC{"cf.pm"};
3712 delete $INC{"cf/pod.pm"}; 3705 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3713 3706
3714 # don't, removes xs symbols, too, 3707 # don't, removes xs symbols, too,
3715 # and global variables created in xs 3708 # and global variables created in xs
3716 #clear_package __PACKAGE__; 3709 #clear_package __PACKAGE__;
3717 3710
3934 LOG llevInfo, "[ABT] [suppressed]\n"; 3927 LOG llevInfo, "[ABT] [suppressed]\n";
3935 } 3928 }
3936} 3929}
3937 3930
3938# load additional modules 3931# load additional modules
3939use cf::pod; 3932require "cf/$_.pm" for @EXTRA_MODULES;
3940 3933
3941END { cf::emergency_save } 3934END { cf::emergency_save }
3942 3935
39431 39361
3944 3937

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines