deliantra/Deliantra-Client/DC.pm

=head1 NAME

DC - undocumented utility garbage for our deliantra client

=head1 SYNOPSIS

 use DC;

=head1 DESCRIPTION

=over 4

=cut

package DC;

use Carp ();

our $VERSION;

BEGIN {
   $VERSION = '3.0';

   use XSLoader;
   XSLoader::load "Deliantra::Client", $VERSION;
}

use utf8;
use strict qw(vars subs);

use Socket ();
use AnyEvent ();
use AnyEvent::Util ();
use Pod::POM ();
use File::Path ();
use Storable (); # finally
use Fcntl ();
use JSON::XS qw(encode_json decode_json);
use Guard qw(guard);

# modules to support other DC::* packages
use List::Util ();
use IO::AIO ();
use Coro::AIO ();
use AnyEvent::AIO ();

use Deliantra::Util ();
use Deliantra::Protocol::Constants ();

=item shorten $string[, $maxlength]

=cut

sub shorten($;$) {
   my ($str, $len) = @_;
   substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
   $str
}

sub asxml($) {
   local $_ = $_[0];

   s/&/&amp;/g;
   s/>/&gt;/g;
   s/</&lt;/g;

   $_
}

sub sanitise_cfxml($) {
   local $_ = shift;

   # we now weed out all tags we do not support
   s{ <(?! /?i> | /?u> | /?b> | /?big | /?small | /?s | /?tt | fg\ | /fg>)
   }{
      "&lt;"
   }gex;

   # now all entities
   s/&(?!amp;|lt;|gt;|apos;|quot;|#[0-9]+;|#x[0-9a-fA-F]+;)/&amp;/g;

   # handle some elements
   s/<fg name='([^']*)'>(.*?)<\/fg>/<span foreground='$1'>$2<\/span>/gs;
   s/<fg name="([^"]*)">(.*?)<\/fg>/<span foreground="$1">$2<\/span>/gs;

   s/\s+$//;

   $_
}

sub background(&;&) {
   my ($bg, $cb) = @_;

   my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
     or die "unable to create background socketpair: $!";

   my $pid = fork;

   if (defined $pid && !$pid) {
      local $SIG{__DIE__};

      open STDOUT, ">&", $fh_w;
      open STDERR, ">&", $fh_w;
      close $fh_r;
      close $fh_w;

      $| = 1;

      eval { $bg->() };

      if ($@) {
         my $msg = $@;
         $msg =~ s/\n+/\n/;
         warn "FATAL: $msg";
         DC::_exit 1;
      }

      # win32 is fucked up, of course. exit will clean stuff up,
      # which destroys our database etc. _exit will exit ALL
      # forked processes, because of the dreaded fork emulation.
      DC::_exit 0;
   }

   close $fh_w;

   my $buffer;

   my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
      unless (sysread $fh_r, $buffer, 4096, length $buffer) {
         undef $w;
         $cb->();
         return;
      }

      while ($buffer =~ s/^(.*)\n//) {
         my $line = $1;
         $line =~ s/\s+$//;
         utf8::decode $line;
         if ($line =~ /^\x{e877}json_msg (.*)$/s) {
            $cb->(JSON::XS->new->allow_nonref->decode ($1));
         } else {
            ::message ({
               markup => "background($pid): " . DC::asxml $line,
            });
         }
      }
   });
}

sub background_msg {
   my ($msg) = @_;

   $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
   $msg =~ s/\n//g;
   utf8::encode $msg;
   print $msg, "\n";
}

package DC;

our $RC_THEME;
our %THEME;
our @RC_PATH;
our $RC_BASE;

for (grep !ref, @INC) {
   $RC_BASE = "$_/Deliantra/Client/private/resources";
   last if -d $RC_BASE;
}

sub find_rcfile($) {
   my $path;

   for (@RC_PATH, "") {
      $path = "$RC_BASE/$_/$_[0]";
      return $path if -e $path;
   }

   die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
}

sub load_json($) {
   my ($file) = @_;

   open my $fh, $file
      or return;

   local $/;
   eval { JSON::XS->new->utf8->relaxed->decode (<$fh>) }
}

sub set_theme($) {
   return if $RC_THEME eq $_[0];
   $RC_THEME = $_[0];

   # kind of hacky, find the main theme file, then load all theme files and merge them

   %THEME = ();
   @RC_PATH = "theme-$RC_THEME";

   my $theme = load_json find_rcfile "theme.json"
      or die "FATAL: theme resource file not found";

   @RC_PATH = @{ $theme->{path} } if $theme->{path};

   for (@RC_PATH, "") {
      my $theme = load_json "$RC_BASE/$_/theme.json"
         or next;

      %THEME = ( %$theme, %THEME );
   }
}

sub read_cfg($) {
   my ($file) = @_;

   $::CFG = (load_json $file) || (load_json "$file.bak");
}

sub write_cfg($) {
   my $file = "$Deliantra::VARDIR/client.cf";

   $::CFG->{VERSION} = $::VERSION;
   $::CFG->{layout}  = DC::UI::get_layout ();

   open my $fh, ">:utf8", "$file~"
      or return;
   print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
   close $fh;

   rename $file, "$file.bak";
   rename "$file~", $file;
}

sub load_cfg() {
   if (-e "$Deliantra::VARDIR/client.cf") {
      DC::read_cfg "$Deliantra::VARDIR/client.cf";
   } else {
      $::CFG = { cfg_schema => 1, db_schema => 1 };
   }
}

sub save_cfg() {
   write_cfg "$Deliantra::VARDIR/client.cf";
}

sub upgrade_cfg() {
   my %DEF_CFG = (
      config_autosave     => 1,
      sdl_mode            => undef,
      fullscreen          => 1,
      fast                => 0,
      force_opengl11      => undef,
      disable_alpha       => 0,
      smooth_movement     => 1,
      smooth_transitions  => 1,
      texture_compression => 1,
      map_scale           => 1,
      fow_enable          => 1,
      fow_intensity       => 0,
      fow_texture         => 0,
      map_smoothing       => 1,
      gui_fontsize        => 1,
      log_fontsize        => 0.7,
      gauge_fontsize      => 1,
      gauge_size          => 0.35,
      stat_fontsize       => 0.7,
      mapsize             => 100,
      audio_enable        => 1,
      audio_hw_channels   => 0,
      audio_hw_frequency  => 0,
      audio_hw_chunksize  => 0,
      audio_mix_channels  => 8,
      effects_enable      => 1,
      effects_volume      => 1,
      bgm_enable          => 1,
      bgm_volume          => 0.5,
      output_rate         => "",
      pickup              => Deliantra::Protocol::Constants::PICKUP_SPELLBOOK
                           | Deliantra::Protocol::Constants::PICKUP_SKILLSCROLL
                           | Deliantra::Protocol::Constants::PICKUP_VALUABLES,
      inv_sort            => "mtime",
      default             => "profile", # default profile
      show_tips           => 1,
      logview_max_par     => 1000,
      shift_fire_stop     => 0,
      uitheme             => "wood",
      map_shift_x         => -24, # arbitrary
      map_shift_y         => +24, # arbitrary
   );

   while (my ($k, $v) = each %DEF_CFG) {
      $::CFG->{$k} = $v unless exists $::CFG->{$k};
   }

   if ($::CFG->{cfg_schema} < 1) {
      for my $profile (values %{ $::CFG->{profile} }) {
         $profile->{password} = unpack "H*", Deliantra::Util::hash_pw $profile->{password};
      }
      $::CFG->{cfg_schema} = 1;
   }
}

sub http_proxy {
   my @proxy = win32_proxy_info;

   if (@proxy) {
      "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
   } elsif (exists $ENV{http_proxy}) {
      $ENV{http_proxy}
   } else {
     ()
   }
}

sub set_proxy {
   my $proxy = http_proxy
      or return;

   $ENV{http_proxy} = $proxy;
}

sub lwp_useragent {
   require LWP::UserAgent;
   
   DC::set_proxy;

   my $ua = LWP::UserAgent->new (
      agent      => "deliantra $VERSION",
      keep_alive => 1,
      env_proxy  => 1,
      timeout    => 30,
   );
}

sub lwp_check($) {
   my ($res) = @_;

   $res->is_error
      and die $res->status_line;

   $res
}

sub fh_nonblocking($$) {
   my ($fh, $nb) = @_;

   if ($^O eq "MSWin32") {
      $nb = (! ! $nb) + 0;
      ioctl $fh, 0x8004667e, \$nb; # FIONBIO
   } else {
      fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
   }
}

package DC::Layout;

$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
   glyph_cache_restore;
};

$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
   glyph_cache_backup;
};

1;

=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

Revision:	1.217
Committed:	Wed Nov 21 13:23:10 2012 UTC (11 years, 5 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.216:	+21 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3	root	1.169	DC - undocumented utility garbage for our deliantra client
4	root	1.1
5			=head1 SYNOPSIS
6
7	root	1.169	use DC;
8	root	1.1
9			=head1 DESCRIPTION
10
11			=over 4
12
13			=cut
14
15	root	1.169	package DC;
16	root	1.1
17	root	1.121	use Carp ();
18
19	root	1.187	our $VERSION;
20
21	root	1.1	BEGIN {
22	root	1.213	$VERSION = '3.0';
23	root	1.1
24	root	1.2	use XSLoader;
25	root	1.168	XSLoader::load "Deliantra::Client", $VERSION;
26	root	1.1	}
27
28	root	1.62	use utf8;
29	root	1.187	use strict qw(vars subs);
30	root	1.62
31	root	1.200	use Socket ();
32	root	1.52	use AnyEvent ();
33	root	1.200	use AnyEvent::Util ();
34	root	1.89	use Pod::POM ();
35	root	1.135	use File::Path ();
36	root	1.89	use Storable (); # finally
37	root	1.141	use Fcntl ();
38	root	1.159	use JSON::XS qw(encode_json decode_json);
39	root	1.202	use Guard qw(guard);
40	root	1.103
41	root	1.212	# modules to support other DC::* packages
42			use List::Util ();
43			use IO::AIO ();
44			use Coro::AIO ();
45			use AnyEvent::AIO ();
46
47	root	1.216	use Deliantra::Util ();
48	root	1.214	use Deliantra::Protocol::Constants ();
49
50	root	1.133	=item shorten $string[, $maxlength]
51
52			=cut
53
54			sub shorten($;$) {
55			my ($str, $len) = @_;
56			substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
57			$str
58			}
59
60	root	1.105	sub asxml($) {
61			local $_ = $_[0];
62	root	1.89
63	root	1.105	s/&/&/g;
64			s/>/>/g;
65			s/</</g;
66	root	1.89
67	root	1.105	$_
68	root	1.89	}
69
70	root	1.217	sub sanitise_cfxml($) {
71			local $_ = shift;
72
73			# we now weed out all tags we do not support
74			s{ <(?! /?i> \| /?u> \| /?b> \| /?big \| /?small \| /?s \| /?tt \| fg\ \| /fg>)
75			}{
76			"<"
77			}gex;
78
79			# now all entities
80			s/&(?!amp;\|lt;\|gt;\|apos;\|quot;\|#[0-9]+;\|#x[0-9a-fA-F]+;)/&/g;
81
82			# handle some elements
83			s/<fg name='([^'])'>(.?)<\/fg>/<span foreground='$1'>$2<\/span>/gs;
84			s/<fg name="([^"])">(.?)<\/fg>/<span foreground="$1">$2<\/span>/gs;
85
86			s/\s+$//;
87
88			$_
89			}
90
91	root	1.127	sub background(&;&) {
92			my ($bg, $cb) = @_;
93	root	1.123
94	root	1.200	my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
95			or die "unable to create background socketpair: $!";
96	root	1.123
97			my $pid = fork;
98
99			if (defined $pid && !$pid) {
100	root	1.124	local $SIG{__DIE__};
101	root	1.123
102			open STDOUT, ">&", $fh_w;
103			open STDERR, ">&", $fh_w;
104			close $fh_r;
105			close $fh_w;
106
107			$\| = 1;
108
109	root	1.127	eval { $bg->() };
110	root	1.124
111			if ($@) {
112			my $msg = $@;
113			$msg =~ s/\n+/\n/;
114			warn "FATAL: $msg";
115	root	1.169	DC::_exit 1;
116	root	1.124	}
117	root	1.123
118			# win32 is fucked up, of course. exit will clean stuff up,
119			# which destroys our database etc. _exit will exit ALL
120			# forked processes, because of the dreaded fork emulation.
121	root	1.169	DC::_exit 0;
122	root	1.123	}
123
124			close $fh_w;
125
126			my $buffer;
127
128	root	1.126	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
129	root	1.123	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
130	root	1.126	undef $w;
131	root	1.127	$cb->();
132			return;
133	root	1.123	}
134
135			while ($buffer =~ s/^(.*)\n//) {
136			my $line = $1;
137	root	1.124	$line =~ s/\s+$//;
138	root	1.123	utf8::decode $line;
139	root	1.127	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
140	root	1.139	$cb->(JSON::XS->new->allow_nonref->decode ($1));
141	root	1.127	} else {
142			::message ({
143	root	1.169	markup => "background($pid): " . DC::asxml $line,
144	root	1.127	});
145			}
146	root	1.123	}
147			});
148			}
149
150	root	1.127	sub background_msg {
151			my ($msg) = @_;
152
153	root	1.139	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
154	root	1.127	$msg =~ s/\n//g;
155			utf8::encode $msg;
156			print $msg, "\n";
157			}
158
159	root	1.169	package DC;
160	root	1.52
161	root	1.191	our $RC_THEME;
162	root	1.192	our %THEME;
163	root	1.191	our @RC_PATH;
164	root	1.187	our $RC_BASE;
165
166			for (grep !ref, @INC) {
167			$RC_BASE = "$_/Deliantra/Client/private/resources";
168			last if -d $RC_BASE;
169			}
170
171	root	1.5	sub find_rcfile($) {
172			my $path;
173
174	root	1.191	for (@RC_PATH, "") {
175	root	1.189	$path = "$RC_BASE/$_/$_[0]";
176	root	1.205	return $path if -e $path;
177	root	1.189	}
178	root	1.5
179	root	1.187	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
180	root	1.5	}
181
182	root	1.192	sub load_json($) {
183			my ($file) = @_;
184
185			open my $fh, $file
186			or return;
187
188			local $/;
189	root	1.203	eval { JSON::XS->new->utf8->relaxed->decode (<$fh>) }
190	root	1.192	}
191
192	root	1.191	sub set_theme($) {
193			return if $RC_THEME eq $_[0];
194			$RC_THEME = $_[0];
195
196	root	1.192	# kind of hacky, find the main theme file, then load all theme files and merge them
197
198			%THEME = ();
199	root	1.191	@RC_PATH = "theme-$RC_THEME";
200
201	root	1.192	my $theme = load_json find_rcfile "theme.json"
202			or die "FATAL: theme resource file not found";
203	root	1.191
204	root	1.192	@RC_PATH = @{ $theme->{path} } if $theme->{path};
205
206			for (@RC_PATH, "") {
207			my $theme = load_json "$RC_BASE/$_/theme.json"
208			or next;
209
210			%THEME = ( %$theme, %THEME );
211	root	1.191	}
212			}
213
214	root	1.215	sub read_cfg($) {
215	root	1.5	my ($file) = @_;
216
217	root	1.201	$::CFG = (load_json $file) \|\| (load_json "$file.bak");
218	root	1.5	}
219
220	root	1.215	sub write_cfg($) {
221	root	1.178	my $file = "$Deliantra::VARDIR/client.cf";
222	root	1.5
223	root	1.107	$::CFG->{VERSION} = $::VERSION;
224	root	1.201	$::CFG->{layout} = DC::UI::get_layout ();
225	root	1.107
226	root	1.201	open my $fh, ">:utf8", "$file~"
227	root	1.5	or return;
228	root	1.180	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
229	root	1.201	close $fh;
230
231			rename $file, "$file.bak";
232			rename "$file~", $file;
233	root	1.5	}
234
235	root	1.215	sub load_cfg() {
236			if (-e "$Deliantra::VARDIR/client.cf") {
237			DC::read_cfg "$Deliantra::VARDIR/client.cf";
238			} else {
239	root	1.216	$::CFG = { cfg_schema => 1, db_schema => 1 };
240	root	1.215	}
241			}
242
243			sub save_cfg() {
244			write_cfg "$Deliantra::VARDIR/client.cf";
245			}
246
247	root	1.214	sub upgrade_cfg() {
248			my %DEF_CFG = (
249			config_autosave => 1,
250			sdl_mode => undef,
251			fullscreen => 1,
252			fast => 0,
253			force_opengl11 => undef,
254			disable_alpha => 0,
255			smooth_movement => 1,
256			smooth_transitions => 1,
257			texture_compression => 1,
258			map_scale => 1,
259			fow_enable => 1,
260			fow_intensity => 0,
261			fow_texture => 0,
262			map_smoothing => 1,
263			gui_fontsize => 1,
264			log_fontsize => 0.7,
265			gauge_fontsize => 1,
266			gauge_size => 0.35,
267			stat_fontsize => 0.7,
268			mapsize => 100,
269			audio_enable => 1,
270			audio_hw_channels => 0,
271			audio_hw_frequency => 0,
272			audio_hw_chunksize => 0,
273			audio_mix_channels => 8,
274			effects_enable => 1,
275			effects_volume => 1,
276			bgm_enable => 1,
277			bgm_volume => 0.5,
278			output_rate => "",
279			pickup => Deliantra::Protocol::Constants::PICKUP_SPELLBOOK
280			\| Deliantra::Protocol::Constants::PICKUP_SKILLSCROLL
281			\| Deliantra::Protocol::Constants::PICKUP_VALUABLES,
282			inv_sort => "mtime",
283			default => "profile", # default profile
284			show_tips => 1,
285			logview_max_par => 1000,
286			shift_fire_stop => 0,
287			uitheme => "wood",
288			map_shift_x => -24, # arbitrary
289			map_shift_y => +24, # arbitrary
290			);
291
292			while (my ($k, $v) = each %DEF_CFG) {
293			$::CFG->{$k} = $v unless exists $::CFG->{$k};
294			}
295	root	1.216
296			if ($::CFG->{cfg_schema} < 1) {
297			for my $profile (values %{ $::CFG->{profile} }) {
298			$profile->{password} = unpack "H*", Deliantra::Util::hash_pw $profile->{password};
299			}
300			$::CFG->{cfg_schema} = 1;
301			}
302	root	1.214	}
303
304	root	1.122	sub http_proxy {
305			my @proxy = win32_proxy_info;
306
307			if (@proxy) {
308			"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
309			} elsif (exists $ENV{http_proxy}) {
310			$ENV{http_proxy}
311			} else {
312			()
313			}
314			}
315
316			sub set_proxy {
317			my $proxy = http_proxy
318			or return;
319
320			$ENV{http_proxy} = $proxy;
321			}
322
323	root	1.127	sub lwp_useragent {
324			require LWP::UserAgent;
325
326	root	1.169	DC::set_proxy;
327	root	1.127
328			my $ua = LWP::UserAgent->new (
329	root	1.171	agent => "deliantra $VERSION",
330	root	1.127	keep_alive => 1,
331			env_proxy => 1,
332			timeout => 30,
333			);
334			}
335
336			sub lwp_check($) {
337			my ($res) = @_;
338
339			$res->is_error
340			and die $res->status_line;
341
342			$res
343			}
344
345	root	1.141	sub fh_nonblocking($$) {
346			my ($fh, $nb) = @_;
347
348	root	1.142	if ($^O eq "MSWin32") {
349			$nb = (! ! $nb) + 0;
350	root	1.143	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
351	root	1.141	} else {
352			fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
353			}
354			}
355
356	root	1.169	package DC::Layout;
357	root	1.97
358	root	1.169	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
359	root	1.164	glyph_cache_restore;
360			};
361
362	root	1.169	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
363	root	1.164	glyph_cache_backup;
364	root	1.97	};
365
366	root	1.1	1;
367
368			=back
369
370			=head1 AUTHOR
371
372			Marc Lehmann <schmorp@schmorp.de>
373			http://home.schmorp.de/
374
375			=cut
376