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 = '2.02';

   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);

=item guard { BLOCK }

Returns an object that executes the given block as soon as it is destroyed.

=cut

sub guard(&) {
   bless \(my $cb = $_[0]), "DC::Guard"
}

sub DC::Guard::DESTROY {
   ${$_[0]}->()
}

=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 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 -r $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 $/;
   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;
}

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

   $::CFG->{VERSION} = $::VERSION;

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

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.200
Committed:	Sun Jan 4 10:22:19 2009 UTC (15 years, 4 months ago) by root
Branch:	MAIN
Changes since 1.199:	+4 -8 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.199	$VERSION = '2.02';
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.127
40	root	1.103	=item guard { BLOCK }
41
42			Returns an object that executes the given block as soon as it is destroyed.
43
44			=cut
45
46			sub guard(&) {
47	root	1.169	bless \(my $cb = $_[0]), "DC::Guard"
48	root	1.103	}
49
50	root	1.169	sub DC::Guard::DESTROY {
51	root	1.103	${$_[0]}->()
52			}
53
54	root	1.133	=item shorten $string[, $maxlength]
55
56			=cut
57
58			sub shorten($;$) {
59			my ($str, $len) = @_;
60			substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
61			$str
62			}
63
64	root	1.105	sub asxml($) {
65			local $_ = $_[0];
66	root	1.89
67	root	1.105	s/&/&/g;
68			s/>/>/g;
69			s/</</g;
70	root	1.89
71	root	1.105	$_
72	root	1.89	}
73
74	root	1.127	sub background(&;&) {
75			my ($bg, $cb) = @_;
76	root	1.123
77	root	1.200	my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
78			or die "unable to create background socketpair: $!";
79	root	1.123
80			my $pid = fork;
81
82			if (defined $pid && !$pid) {
83	root	1.124	local $SIG{__DIE__};
84	root	1.123
85			open STDOUT, ">&", $fh_w;
86			open STDERR, ">&", $fh_w;
87			close $fh_r;
88			close $fh_w;
89
90			$\| = 1;
91
92	root	1.127	eval { $bg->() };
93	root	1.124
94			if ($@) {
95			my $msg = $@;
96			$msg =~ s/\n+/\n/;
97			warn "FATAL: $msg";
98	root	1.169	DC::_exit 1;
99	root	1.124	}
100	root	1.123
101			# win32 is fucked up, of course. exit will clean stuff up,
102			# which destroys our database etc. _exit will exit ALL
103			# forked processes, because of the dreaded fork emulation.
104	root	1.169	DC::_exit 0;
105	root	1.123	}
106
107			close $fh_w;
108
109			my $buffer;
110
111	root	1.126	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
112	root	1.123	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
113	root	1.126	undef $w;
114	root	1.127	$cb->();
115			return;
116	root	1.123	}
117
118			while ($buffer =~ s/^(.*)\n//) {
119			my $line = $1;
120	root	1.124	$line =~ s/\s+$//;
121	root	1.123	utf8::decode $line;
122	root	1.127	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
123	root	1.139	$cb->(JSON::XS->new->allow_nonref->decode ($1));
124	root	1.127	} else {
125			::message ({
126	root	1.169	markup => "background($pid): " . DC::asxml $line,
127	root	1.127	});
128			}
129	root	1.123	}
130			});
131			}
132
133	root	1.127	sub background_msg {
134			my ($msg) = @_;
135
136	root	1.139	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
137	root	1.127	$msg =~ s/\n//g;
138			utf8::encode $msg;
139			print $msg, "\n";
140			}
141
142	root	1.169	package DC;
143	root	1.52
144	root	1.191	our $RC_THEME;
145	root	1.192	our %THEME;
146	root	1.191	our @RC_PATH;
147	root	1.187	our $RC_BASE;
148
149			for (grep !ref, @INC) {
150			$RC_BASE = "$_/Deliantra/Client/private/resources";
151			last if -d $RC_BASE;
152			}
153
154	root	1.5	sub find_rcfile($) {
155			my $path;
156
157	root	1.191	for (@RC_PATH, "") {
158	root	1.189	$path = "$RC_BASE/$_/$_[0]";
159			return $path if -r $path;
160			}
161	root	1.5
162	root	1.187	die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
163	root	1.5	}
164
165	root	1.192	sub load_json($) {
166			my ($file) = @_;
167
168			open my $fh, $file
169			or return;
170
171			local $/;
172			JSON::XS->new->utf8->relaxed->decode (<$fh>)
173			}
174
175	root	1.191	sub set_theme($) {
176			return if $RC_THEME eq $_[0];
177			$RC_THEME = $_[0];
178
179	root	1.192	# kind of hacky, find the main theme file, then load all theme files and merge them
180
181			%THEME = ();
182	root	1.191	@RC_PATH = "theme-$RC_THEME";
183
184	root	1.192	my $theme = load_json find_rcfile "theme.json"
185			or die "FATAL: theme resource file not found";
186	root	1.191
187	root	1.192	@RC_PATH = @{ $theme->{path} } if $theme->{path};
188
189			for (@RC_PATH, "") {
190			my $theme = load_json "$RC_BASE/$_/theme.json"
191			or next;
192
193			%THEME = ( %$theme, %THEME );
194	root	1.191	}
195			}
196
197	root	1.5	sub read_cfg {
198			my ($file) = @_;
199
200	root	1.192	$::CFG = load_json $file;
201	root	1.5	}
202
203			sub write_cfg {
204	root	1.178	my $file = "$Deliantra::VARDIR/client.cf";
205	root	1.5
206	root	1.107	$::CFG->{VERSION} = $::VERSION;
207
208			open my $fh, ">:utf8", $file
209	root	1.5	or return;
210	root	1.180	print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
211	root	1.5	}
212
213	root	1.122	sub http_proxy {
214			my @proxy = win32_proxy_info;
215
216			if (@proxy) {
217			"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
218			} elsif (exists $ENV{http_proxy}) {
219			$ENV{http_proxy}
220			} else {
221			()
222			}
223			}
224
225			sub set_proxy {
226			my $proxy = http_proxy
227			or return;
228
229			$ENV{http_proxy} = $proxy;
230			}
231
232	root	1.127	sub lwp_useragent {
233			require LWP::UserAgent;
234
235	root	1.169	DC::set_proxy;
236	root	1.127
237			my $ua = LWP::UserAgent->new (
238	root	1.171	agent => "deliantra $VERSION",
239	root	1.127	keep_alive => 1,
240			env_proxy => 1,
241			timeout => 30,
242			);
243			}
244
245			sub lwp_check($) {
246			my ($res) = @_;
247
248			$res->is_error
249			and die $res->status_line;
250
251			$res
252			}
253
254	root	1.141	sub fh_nonblocking($$) {
255			my ($fh, $nb) = @_;
256
257	root	1.142	if ($^O eq "MSWin32") {
258			$nb = (! ! $nb) + 0;
259	root	1.143	ioctl $fh, 0x8004667e, \$nb; # FIONBIO
260	root	1.141	} else {
261			fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
262			}
263			}
264
265	root	1.169	package DC::Layout;
266	root	1.97
267	root	1.169	$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
268	root	1.164	glyph_cache_restore;
269			};
270
271	root	1.169	$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
272	root	1.164	glyph_cache_backup;
273	root	1.97	};
274
275	root	1.1	1;
276
277			=back
278
279			=head1 AUTHOR
280
281			Marc Lehmann <schmorp@schmorp.de>
282			http://home.schmorp.de/
283
284			=cut
285