ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/Deliantra-Client/DC.pm
(Generate patch)

Comparing deliantra/Deliantra-Client/DC.pm (file contents):
Revision 1.3 by root, Fri Apr 7 18:20:13 2006 UTC vs.
Revision 1.154 by root, Sun Oct 14 20:08:38 2007 UTC

1=head1 NAME 1=head1 NAME
2 2
3Crossfire::Client - undocumented utility garbage for our crossfire client 3CFPlus - undocumented utility garbage for our crossfire client
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use Crossfire::Client; 7 use CFPlus;
8 8
9=head1 DESCRIPTION 9=head1 DESCRIPTION
10 10
11=over 4 11=over 4
12 12
13=cut 13=cut
14 14
15package Crossfire::Client; 15package CFPlus;
16
17use Carp ();
16 18
17BEGIN { 19BEGIN {
18 $VERSION = '0.1'; 20 $VERSION = '0.993';
19 21
20 use XSLoader; 22 use XSLoader;
21 XSLoader::load "Crossfire::Client", $VERSION; 23 XSLoader::load "CFPlus", $VERSION;
22} 24}
23 25
24package Crossfire::Client::Texture; 26use utf8;
25 27
26use Scalar::Util; 28use AnyEvent ();
29use Pod::POM ();
30use File::Path ();
31use Storable (); # finally
32use Fcntl ();
33use JSON::XS qw(to_json from_json);
27 34
28use SDL::OpenGL; 35=item guard { BLOCK }
29 36
30my @textures; 37Returns an object that executes the given block as soon as it is destroyed.
31 38
32sub new_from_file { 39=cut
33 my ($class, $path) = @_;
34 40
35 open my $fh, "<:raw", $path 41sub guard(&) {
36 or die "$path: $!"; 42 bless \(my $cb = $_[0]), "CFPlus::Guard"
43}
44
45sub CFPlus::Guard::DESTROY {
46 ${$_[0]}->()
47}
48
49=item shorten $string[, $maxlength]
50
51=cut
52
53sub shorten($;$) {
54 my ($str, $len) = @_;
55 substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
56 $str
57}
58
59sub asxml($) {
60 local $_ = $_[0];
61
62 s/&/&amp;/g;
63 s/>/&gt;/g;
64 s/</&lt;/g;
65
66 $_
67}
68
69sub socketpipe() {
70 socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
71 or die "cannot establish bidirectional pipe: $!\n";
72
73 ($fh1, $fh2)
74}
75
76sub background(&;&) {
77 my ($bg, $cb) = @_;
78
79 my ($fh_r, $fh_w) = CFPlus::socketpipe;
80
81 my $pid = fork;
82
83 if (defined $pid && !$pid) {
84 local $SIG{__DIE__};
85
86 open STDOUT, ">&", $fh_w;
87 open STDERR, ">&", $fh_w;
88 close $fh_r;
89 close $fh_w;
90
91 $| = 1;
92
93 eval { $bg->() };
94
95 if ($@) {
96 my $msg = $@;
97 $msg =~ s/\n+/\n/;
98 warn "FATAL: $msg";
99 CFPlus::_exit 1;
100 }
101
102 # win32 is fucked up, of course. exit will clean stuff up,
103 # which destroys our database etc. _exit will exit ALL
104 # forked processes, because of the dreaded fork emulation.
105 CFPlus::_exit 0;
106 }
107
108 close $fh_w;
109
110 my $buffer;
111
112 my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
113 unless (sysread $fh_r, $buffer, 4096, length $buffer) {
114 undef $w;
115 $cb->();
116 return;
117 }
118
119 while ($buffer =~ s/^(.*)\n//) {
120 my $line = $1;
121 $line =~ s/\s+$//;
122 utf8::decode $line;
123 if ($line =~ /^\x{e877}json_msg (.*)$/s) {
124 $cb->(JSON::XS->new->allow_nonref->decode ($1));
125 } else {
126 ::message ({
127 markup => "background($pid): " . CFPlus::asxml $line,
128 });
129 }
130 }
131 });
132}
133
134sub background_msg {
135 my ($msg) = @_;
136
137 $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
138 $msg =~ s/\n//g;
139 utf8::encode $msg;
140 print $msg, "\n";
141}
142
143package CFPlus;
144
145sub find_rcfile($) {
146 my $path;
147
148 for (grep !ref, @INC) {
149 $path = "$_/CFPlus/resources/$_[0]";
150 return $path if -r $path;
151 }
152
153 die "FATAL: can't find required file $_[0]\n";
154}
155
156sub read_cfg {
157 my ($file) = @_;
158
159 open my $fh, $file
160 or return;
37 161
38 local $/; 162 local $/;
39 $class->new_from_data (<$fh>) 163 my $CFG = <$fh>;
40}
41 164
42sub new_from_image { 165 if ($CFG =~ /^---/) { ## TODO compatibility cruft, remove
43 my ($class, $image) = @_; 166 require YAML;
44 167 utf8::decode $CFG;
45 my $self = bless { 168 $::CFG = YAML::Load ($CFG);
46 image => $data, 169 } elsif ($CFG =~ /^\{/) {
47 }; 170 $::CFG = from_json $CFG;
48
49 push @textures, $self;
50 Scalar::Util::weaken $textures[-1];
51
52 $self->upload;
53
54 $self
55}
56
57sub upload {
58 my ($self) = @_;
59
60 return unless $SDL::App::USING_OPENGL;
61
62 my ($data, $width, $height);
63
64 if (exists $self->{data}) {
65 ($data, $width, $height) = ($self->{data}, $self->{width}, $self->{height});
66 } else { 171 } else {
67 my $pb = new Gtk2::Gdk::PixbufLoader; 172 $::CFG = eval $CFG; ## todo comaptibility cruft
68 $pb->write ($self->{data});
69 $pb->close;
70
71 $pb = $pb->get_pixbuf;
72 $pb = $pb->add_alpha (0, 0, 0, 0);
73
74 ($data, $width, $height) = ($pb->get_pixels, $pb->get_width, $pb->get_height);
75 } 173 }
174}
76 175
77 ($self->{name}) = @{glGenTextures 1}; 176sub write_cfg {
177 my ($file) = @_;
78 178
79 glBindTexture GL_TEXTURE_2D, $self->{name}; 179 $::CFG->{VERSION} = $::VERSION;
80 180
81 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR; 181 open my $fh, ">:utf8", $file
82 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;#_MIPMAP_LINEAR; 182 or return;
83 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP; 183 print $fh to_json $::CFG;
84 glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP; 184}
185
186sub http_proxy {
187 my @proxy = win32_proxy_info;
188
189 if (@proxy) {
190 "http://" . (@proxy < 2 ? "" : @proxy < 3 ? "$proxy[1]\@" : "$proxy[1]:$proxy[2]\@") . $proxy[0]
191 } elsif (exists $ENV{http_proxy}) {
192 $ENV{http_proxy}
193 } else {
194 ()
195 }
196}
197
198sub set_proxy {
199 my $proxy = http_proxy
200 or return;
201
202 $ENV{http_proxy} = $proxy;
203}
204
205sub lwp_useragent {
206 require LWP::UserAgent;
85 207
86 glTexImage2D GL_TEXTURE_2D, 0, 208 CFPlus::set_proxy;
87 GL_RGBA8,
88 $width, $height,
89 0,
90 GL_RGBA,
91 GL_UNSIGNED_BYTE,
92 $data;
93}
94 209
95sub DESTROY { 210 my $ua = LWP::UserAgent->new (
211 agent => "cfplus $VERSION",
212 keep_alive => 1,
213 env_proxy => 1,
214 timeout => 30,
215 );
216}
217
218sub lwp_check($) {
96 my ($self) = @_; 219 my ($res) = @_;
97 220
98 return unless exists $self->{name}; 221 $res->is_error
222 and die $res->status_line;
99 223
100 glDeleteTextures delete $self->{name}; 224 $res
101} 225}
102 226
103push @::GLINIT, sub { 227sub fh_nonblocking($$) {
104 $_->upload 228 my ($fh, $nb) = @_;
105 for grep $_, @textures; 229
230 if ($^O eq "MSWin32") {
231 $nb = (! ! $nb) + 0;
232 ioctl $fh, 0x8004667e, \$nb; # FIONBIO
233 } else {
234 fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
235 }
236
237}
238
239package CFPlus::Layout;
240
241$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
242 reset_glyph_cache;
106}; 243};
107 244
1081; 2451;
109 246
110=back 247=back

Diff Legend

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