deliantra/Deliantra-Client/DC.pm

=head1 NAME

CFPlus - undocumented utility garbage for our crossfire client

=head1 SYNOPSIS

 use CFPlus;

=head1 DESCRIPTION

=over 4

=cut

package CFPlus;

use Carp ();

BEGIN {
   $VERSION = '0.97';

   use XSLoader;
   XSLoader::load "CFPlus", $VERSION;
}

use utf8;

use AnyEvent ();
use Pod::POM ();
use File::Path ();
use Storable (); # finally

BEGIN {
   use Crossfire::Protocol::Base ();
   *to_json   = \&Crossfire::Protocol::Base::to_json;
   *from_json = \&Crossfire::Protocol::Base::from_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]), "CFPlus::Guard"
}

sub CFPlus::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 socketpipe() {
   socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
      or die "cannot establish bidirectional pipe: $!\n";

   ($fh1, $fh2)
}

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

   my ($fh_r, $fh_w) = CFPlus::socketpipe;

   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";
         CFPlus::_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.
      CFPlus::_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): " . CFPlus::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 CFPlus;

sub find_rcfile($) {
   my $path;

   for (grep !ref, @INC) {
      $path = "$_/CFPlus/resources/$_[0]";
      return $path if -r $path;
   }

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

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

   open my $fh, $file
      or return;

   local $/;
   my $CFG = <$fh>;

   if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
      require YAML;
      utf8::decode $CFG;
      $::CFG = YAML::Load ($CFG);
   } elsif ($CFG =~ /^\{/) {
      $::CFG = from_json $CFG;
   } else {
      $::CFG = eval $CFG; ## todo comaptibility cruft
   }
}

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

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

   open my $fh, ">:utf8", $file
      or return;
   print $fh to_json $::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;
   
   CFPlus::set_proxy;

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

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

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

   $res
}

package CFPlus::Layout;

$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
   reset_glyph_cache;
};

1;

=back

=head1 AUTHOR

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

=cut

Revision:	1.140
Committed:	Fri Apr 6 07:45:33 2007 UTC (17 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.139:	+1 -77 lines
Log Message:	- changed most db accesses to be asynchronous (this was way more difficult than anticipated) - face id allocation is still synchronous (and has to be as long as we want to allow multiple instances running in parallel) - facemap is cached locally, so subsequent accesses are fast - the alternative would be to store faceids, not tileids, in the in-memory map, but then mapcache tiles are non-displayable unless the server already sent them. - tile loading and map cache load/store are fully asynchronous - replaced 32x32 dialogue and noface images by 64 bit versions - properly scale special dialogue/noface textures to tilesize
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3	root	1.108	CFPlus - undocumented utility garbage for our crossfire client
4	root	1.1
5			=head1 SYNOPSIS
6
7	root	1.108	use CFPlus;
8	root	1.1
9			=head1 DESCRIPTION
10
11			=over 4
12
13			=cut
14
15	root	1.108	package CFPlus;
16	root	1.1
17	root	1.121	use Carp ();
18
19	root	1.1	BEGIN {
20	root	1.130	$VERSION = '0.97';
21	root	1.1
22	root	1.2	use XSLoader;
23	root	1.108	XSLoader::load "CFPlus", $VERSION;
24	root	1.1	}
25
26	root	1.62	use utf8;
27
28	root	1.52	use AnyEvent ();
29	root	1.89	use Pod::POM ();
30	root	1.135	use File::Path ();
31	root	1.89	use Storable (); # finally
32
33	root	1.127	BEGIN {
34			use Crossfire::Protocol::Base ();
35			*to_json = \&Crossfire::Protocol::Base::to_json;
36			*from_json = \&Crossfire::Protocol::Base::from_json;
37			}
38
39	root	1.103	=item guard { BLOCK }
40
41			Returns an object that executes the given block as soon as it is destroyed.
42
43			=cut
44
45			sub guard(&) {
46	root	1.108	bless \(my $cb = $_[0]), "CFPlus::Guard"
47	root	1.103	}
48
49	root	1.108	sub CFPlus::Guard::DESTROY {
50	root	1.103	${$_[0]}->()
51			}
52
53	root	1.133	=item shorten $string[, $maxlength]
54
55			=cut
56
57			sub shorten($;$) {
58			my ($str, $len) = @_;
59			substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
60			$str
61			}
62
63	root	1.105	sub asxml($) {
64			local $_ = $_[0];
65	root	1.89
66	root	1.105	s/&/&/g;
67			s/>/>/g;
68			s/</</g;
69	root	1.89
70	root	1.105	$_
71	root	1.89	}
72
73	root	1.123	sub socketpipe() {
74			socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
75	root	1.140	or die "cannot establish bidirectional pipe: $!\n";
76	root	1.123
77			($fh1, $fh2)
78			}
79
80	root	1.127	sub background(&;&) {
81			my ($bg, $cb) = @_;
82	root	1.123
83			my ($fh_r, $fh_w) = CFPlus::socketpipe;
84
85			my $pid = fork;
86
87			if (defined $pid && !$pid) {
88	root	1.124	local $SIG{__DIE__};
89	root	1.123
90			open STDOUT, ">&", $fh_w;
91			open STDERR, ">&", $fh_w;
92			close $fh_r;
93			close $fh_w;
94
95			$\| = 1;
96
97	root	1.127	eval { $bg->() };
98	root	1.124
99			if ($@) {
100			my $msg = $@;
101			$msg =~ s/\n+/\n/;
102			warn "FATAL: $msg";
103			CFPlus::_exit 1;
104			}
105	root	1.123
106			# win32 is fucked up, of course. exit will clean stuff up,
107			# which destroys our database etc. _exit will exit ALL
108			# forked processes, because of the dreaded fork emulation.
109	root	1.124	CFPlus::_exit 0;
110	root	1.123	}
111
112			close $fh_w;
113
114			my $buffer;
115
116	root	1.126	my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
117	root	1.123	unless (sysread $fh_r, $buffer, 4096, length $buffer) {
118	root	1.126	undef $w;
119	root	1.127	$cb->();
120			return;
121	root	1.123	}
122
123			while ($buffer =~ s/^(.*)\n//) {
124			my $line = $1;
125	root	1.124	$line =~ s/\s+$//;
126	root	1.123	utf8::decode $line;
127	root	1.127	if ($line =~ /^\x{e877}json_msg (.*)$/s) {
128	root	1.139	$cb->(JSON::XS->new->allow_nonref->decode ($1));
129	root	1.127	} else {
130			::message ({
131			markup => "background($pid): " . CFPlus::asxml $line,
132			});
133			}
134	root	1.123	}
135			});
136			}
137
138	root	1.127	sub background_msg {
139			my ($msg) = @_;
140
141	root	1.139	$msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
142	root	1.127	$msg =~ s/\n//g;
143			utf8::encode $msg;
144			print $msg, "\n";
145			}
146
147	root	1.108	package CFPlus;
148	root	1.52
149	root	1.5	sub find_rcfile($) {
150			my $path;
151
152	root	1.46	for (grep !ref, @INC) {
153	root	1.108	$path = "$_/CFPlus/resources/$_[0]";
154	root	1.5	return $path if -r $path;
155			}
156
157			die "FATAL: can't find required file $_[0]\n";
158			}
159
160			sub read_cfg {
161			my ($file) = @_;
162
163	root	1.107	open my $fh, $file
164	root	1.5	or return;
165
166			local $/;
167	root	1.107	my $CFG = <$fh>;
168	root	1.5
169	root	1.108	if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
170			require YAML;
171			utf8::decode $CFG;
172			$::CFG = YAML::Load ($CFG);
173			} elsif ($CFG =~ /^\{/) {
174			$::CFG = from_json $CFG;
175	root	1.107	} else {
176	root	1.108	$::CFG = eval $CFG; ## todo comaptibility cruft
177	root	1.107	}
178	root	1.5	}
179
180			sub write_cfg {
181			my ($file) = @_;
182
183	root	1.107	$::CFG->{VERSION} = $::VERSION;
184
185			open my $fh, ">:utf8", $file
186	root	1.5	or return;
187	root	1.108	print $fh to_json $::CFG;
188	root	1.5	}
189
190	root	1.122	sub http_proxy {
191			my @proxy = win32_proxy_info;
192
193			if (@proxy) {
194			"http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
195			} elsif (exists $ENV{http_proxy}) {
196			$ENV{http_proxy}
197			} else {
198			()
199			}
200			}
201
202			sub set_proxy {
203			my $proxy = http_proxy
204			or return;
205
206			$ENV{http_proxy} = $proxy;
207			}
208
209	root	1.127	sub lwp_useragent {
210			require LWP::UserAgent;
211
212			CFPlus::set_proxy;
213
214			my $ua = LWP::UserAgent->new (
215			agent => "cfplus $VERSION",
216			keep_alive => 1,
217			env_proxy => 1,
218			timeout => 30,
219			);
220			}
221
222			sub lwp_check($) {
223			my ($res) = @_;
224
225			$res->is_error
226			and die $res->status_line;
227
228			$res
229			}
230
231	root	1.108	package CFPlus::Layout;
232	root	1.97
233	root	1.108	$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
234	root	1.98	reset_glyph_cache;
235	root	1.97	};
236
237	root	1.1	1;
238
239			=back
240
241			=head1 AUTHOR
242
243			Marc Lehmann <schmorp@schmorp.de>
244			http://home.schmorp.de/
245
246			=cut
247