--- deliantra/Deliantra-Client/DC.pm 2006/05/25 16:35:42 1.63 +++ deliantra/Deliantra-Client/DC.pm 2007/04/06 07:45:33 1.140 @@ -1,10 +1,10 @@ =head1 NAME -CFClient - undocumented utility garbage for our crossfire client +CFPlus - undocumented utility garbage for our crossfire client =head1 SYNOPSIS - use CFClient; + use CFPlus; =head1 DESCRIPTION @@ -12,530 +12,227 @@ =cut -package CFClient; +package CFPlus; + +use Carp (); BEGIN { - $VERSION = '0.1'; + $VERSION = '0.97'; use XSLoader; - XSLoader::load "CFClient", $VERSION; + XSLoader::load "CFPlus", $VERSION; } use utf8; -use Carp (); use AnyEvent (); -use BerkeleyDB; - -use CFClient::OpenGL; - -our %GL_EXT; -our $GL_VERSION; - -our $GL_NPOT; -our $GL_DEBUG = 1; - -sub gl_init { - $GL_VERSION = gl_version * 1; - %GL_EXT = map +($_ => 1), split /\s+/, gl_extensions; - - $GL_NPOT = $GL_EXT{GL_ARB_texture_non_power_of_two} || $GL_VERSION >= 2; - $GL_NPOT = 0 if gl_vendor =~ /ATI Technologies/; # ATI doesn't get it right... - - glDisable GL_COLOR_MATERIAL; - glShadeModel GL_FLAT; - glDisable GL_DITHER; - glDisable GL_DEPTH_TEST; - glDepthMask 0; - glHint GL_PERSPECTIVE_CORRECTION_HINT, GL_FASTEST; - - CFClient::Texture::restore_state (); -} - -sub gl_check { - return unless $GL_DEBUG; - - if (my $error = glGetError) { - my ($format, @args) = @_; - Carp::cluck sprintf "opengl error %x while $format", $error, @args; - } -} - -sub find_rcfile($) { - my $path; - - for (grep !ref, @INC) { - $path = "$_/CFClient/resources/$_[0]"; - return $path if -r $path; - } - - die "FATAL: can't find required file $_[0]\n"; -} - -sub read_cfg { - my ($file) = @_; - - open CFG, $file - or return; - - my $CFG; - - local $/; - $CFG = eval ; +use Pod::POM (); +use File::Path (); +use Storable (); # finally - $::CFG = $CFG; - - close CFG; -} - -sub write_cfg { - my ($file) = @_; - - open CFG, ">$file" - or return; - - { - require Data::Dumper; - local $Data::Dumper::Purity = 1; - $::CFG->{VERSION} = $::VERSION; - print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]); - } - - close CFG; -} - -mkdir "$Crossfire::VARDIR/pclient", 0777; - -our $DB_ENV = new BerkeleyDB::Env - -Home => "$Crossfire::VARDIR/pclient", - -Cachesize => 1_000_000, - -ErrFile => "$Crossfire::VARDIR/pclient/errorlog.txt", -# -ErrPrefix => "DATABASE", - -Verbose => 1, - -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN, - or die "unable to create/open database home $Crossfire::VARDIR/pclient: $BerkeleyDB::Error"; - -sub db_table($) { - my ($table) = @_; - - $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; - - new CFClient::Database - -Env => $DB_ENV, - -Filename => $table, -# -Filename => "database", -# -Subname => $table, - -Property => DB_CHKSUM, - -Flags => DB_CREATE | DB_UPGRADE, - or die "unable to create/open database table $_[0]: $BerkeleyDB::Error"; +BEGIN { + use Crossfire::Protocol::Base (); + *to_json = \&Crossfire::Protocol::Base::to_json; + *from_json = \&Crossfire::Protocol::Base::from_json; } -sub pod_to_pango($) { - my ($pom) = @_; +=item guard { BLOCK } - $pom->present ("CFClient::PodToPango") -} +Returns an object that executes the given block as soon as it is destroyed. -sub pod_to_pango_list($) { - my ($pom) = @_; +=cut - [ - map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], - split /\n/, $pom->present ("CFClient::PodToPango") - ] +sub guard(&) { + bless \(my $cb = $_[0]), "CFPlus::Guard" } -package CFClient::PodToPango; - -use base Pod::POM::View::Text; - -our $indent = 0; - -*view_seq_code = -*view_seq_bold = sub { "$_[1]" }; -*view_seq_italic = sub { "$_[1]" }; -*view_seq_space = -*view_seq_link = -*view_seq_index = sub { CFClient::UI::Label::escape ($_[1]) }; - -sub view_seq_text { - my $text = $_[1]; - $text =~ s/\s+/ /g; - CFClient::UI::Label::escape ($text) +sub CFPlus::Guard::DESTROY { + ${$_[0]}->() } -sub view_item { - ("\t" x ($indent / 4)) - . $_[1]->title->present ($_[0]) - . "\n" - . $_[1]->content->present ($_[0]) -} +=item shorten $string[, $maxlength] -sub view_verbatim { - (join "", - map +("\t" x ($indent / 2)) . "$_\n", - split /\n/, CFClient::UI::Label::escape ($_[1])) - . "\n" -} +=cut -sub view_textblock { - ("\t" x ($indent / 2)) . "$_[1]\n\n" +sub shorten($;$) { + my ($str, $len) = @_; + substr $str, $len, (length $str), "..." if $len + 3 <= length $str; + $str } -sub view_head1 { - "" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; +sub asxml($) { + local $_ = $_[0]; -sub view_head2 { - "" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; + s/&/&/g; + s/>/>/g; + s/indent; - $_[1]->content->present ($_[0]) + $_ } -package CFClient::Database; +sub socketpipe() { + socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC + or die "cannot establish bidirectional pipe: $!\n"; -our @ISA = BerkeleyDB::Btree::; - -sub get($$) { - my $data; - - $_[0]->db_get ($_[1], $data) == 0 - ? $data - : () + ($fh1, $fh2) } -my %DB_SYNC; - -sub put($$$) { - my ($db, $key, $data) = @_; - - $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync }); +sub background(&;&) { + my ($bg, $cb) = @_; - $db->db_put ($key => $data) -} - -package CFClient::Item; + my ($fh_r, $fh_w) = CFPlus::socketpipe; -sub desc_string { - my ($self) = @_; + my $pid = fork; - my $desc = - $self->{nrof} < 2 - ? $self->{name} - : "$self->{nrof} × $self->{name_pl}"; + if (defined $pid && !$pid) { + local $SIG{__DIE__}; - $self->{flags} & Crossfire::Protocol::F_OPEN - and $desc .= " (open)"; - $self->{flags} & Crossfire::Protocol::F_APPLIED - and $desc .= " (applied)"; - $self->{flags} & Crossfire::Protocol::F_UNPAID - and $desc .= " (unpaid)"; - $self->{flags} & Crossfire::Protocol::F_MAGIC - and $desc .= " (magic)"; - $self->{flags} & Crossfire::Protocol::F_CURSED - and $desc .= " (cursed)"; - $self->{flags} & Crossfire::Protocol::F_DAMNED - and $desc .= " (damned)"; - $self->{flags} & Crossfire::Protocol::F_LOCKED - and $desc .= " *"; + open STDOUT, ">&", $fh_w; + open STDERR, ">&", $fh_w; + close $fh_r; + close $fh_w; - $desc -} + $| = 1; -sub weight_string { - my ($self) = @_; + eval { $bg->() }; - my $weight = ($self->{nrof} || 1) * $self->{weight}; + if ($@) { + my $msg = $@; + $msg =~ s/\n+/\n/; + warn "FATAL: $msg"; + CFPlus::_exit 1; + } - $weight < 0 ? "?" : $weight * 0.001 -} + # 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; + } -sub update_widgets { - my ($self) = @_; + close $fh_w; - my $button_cb = sub { - my (undef, $ev, $x, $y) = @_; + my $buffer; - if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { - my $targ = $::CONN->{player}{tag}; + my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub { + unless (sysread $fh_r, $buffer, 4096, length $buffer) { + undef $w; + $cb->(); + return; + } - if ($self->{container} == $::CONN->{player}{tag}) { - $targ = $main::OPENCONT; + 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, + }); } - - $::CONN->send ("move $targ $self->{tag} 0"); - } elsif ($ev->{button} == 1) { - $::CONN->send ("examine $self->{tag}"); - } elsif ($ev->{button} == 2) { - $::CONN->send ("apply $self->{tag}"); - } elsif ($ev->{button} == 3) { - my @menu_items = ( - ["examine", sub { $::CONN->send ("examine $self->{tag}") }], - ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }], - ["apply", sub { $::CONN->send ("apply $self->{tag}") }], - ( - $self->{flags} & Crossfire::Protocol::F_LOCKED - ? ( - ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }], - ) - : ( - ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], - ["drop", sub { $::CONN->send ("move $main::OPENCONT $self->{tag} 0") }], - ) - ), - ); - - CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); } - - 1 - }; - - my $tooltip_std = "" - . "Left click - examine item\n" - . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" - . "Middle click - apply\n" - . "Right click - further options" - . "\n"; - - $self->{face_widget} ||= new CFClient::UI::Face - can_events => 1, - can_hover => 1, - connect_button_down => $button_cb, - ; - $self->{face_widget}{face} = $self->{face}; - $self->{face_widget}{anim} = $self->{anim}; - $self->{face_widget}{animspeed} = $self->{animespeed}; - $self->{face_widget}->set_tooltip ( - "Face/Animation.\n" - . "Item uses face #$self->{face}. " - . ($self->{animspeed} ? "Item uses animation #$self->{anim} at " . (1 / $self->{animspeed}) . "fps. " : "Item is not animated. ") - . "\n\n$tooltip_std" - ); - - $self->{desc_widget} ||= new CFClient::UI::Label - can_events => 1, - can_hover => 1, - ellipsise => 2, - xalign => 0, - connect_button_down => $button_cb, - ; - my $desc = CFClient::Item::desc_string $self; - $self->{desc_widget}->set_text ($desc); - $self->{desc_widget}->set_tooltip ("$desc.\n$tooltip_std"); - - $self->{weight_widget} ||= new CFClient::UI::Label - can_events => 1, - can_hover => 1, - ellipsise => 0, - xalign => 0.5, - connect_button_down => $button_cb, - ; - $self->{weight_widget}->set_text (CFClient::Item::weight_string $self); - - $self->{weight_widget}->set_tooltip ( - "Weight.\n" - . ($self->{weight} >= 0 ? "One item weighs $self->{weight}g. " : "You have no idea how much this weighs. ") - . ($self->{nrof} ? "You have $self->{nrof} of it. " : "Item cannot stack with others of it's kind. ") - . "\n\n$tooltip_std" - ); + }); } -package CFClient::Texture; - -use strict; - -use Scalar::Util; - -use CFClient::OpenGL; +sub background_msg { + my ($msg) = @_; -my %TEXTURES; - -sub new { - my ($class, %data) = @_; - - my $self = bless { - internalformat => GL_RGBA, - format => GL_RGBA, - type => GL_UNSIGNED_BYTE, - %data, - }, $class; - - Scalar::Util::weaken ($TEXTURES{$self+0} = $self); - - $self->upload; - - $self + $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg); + $msg =~ s/\n//g; + utf8::encode $msg; + print $msg, "\n"; } -sub new_from_image { - my ($class, $image, %arg) = @_; - - $class->new (image => $image, %arg) -} +package CFPlus; -sub new_from_file { - my ($class, $path, %arg) = @_; +sub find_rcfile($) { + my $path; - open my $fh, "<:raw", $path - or die "$path: $!"; + for (grep !ref, @INC) { + $path = "$_/CFPlus/resources/$_[0]"; + return $path if -r $path; + } - local $/; - $class->new_from_image (<$fh>, %arg) + die "FATAL: can't find required file $_[0]\n"; } -#sub new_from_surface { -# my ($class, $surface) = @_; -# -# $surface->rgba; -# -# $class->new ( -# data => $surface->pixels, -# w => $surface->width, -# h => $surface->height, -# ) -#} +sub read_cfg { + my ($file) = @_; -sub new_from_layout { - my ($class, $layout, %arg) = @_; + open my $fh, $file + or return; - my ($w, $h, $data, $format, $internalformat) = $layout->render; + local $/; + my $CFG = <$fh>; - $class->new ( - w => $w, - h => $h, - data => $data, - format => $format, - internalformat => $format, - type => GL_UNSIGNED_BYTE, - %arg, - ) + 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 new_from_opengl { - my ($class, $w, $h, $cb) = @_; +sub write_cfg { + my ($file) = @_; - $class->new (w => $w || 1, h => $h || 1, render_cb => $cb) -} + $::CFG->{VERSION} = $::VERSION; -sub topot { - (grep $_ >= $_[0], 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768)[0] + open my $fh, ">:utf8", $file + or return; + print $fh to_json $::CFG; } -sub upload { - my ($self) = @_; - - return unless $GL_VERSION; - - my $data; - - if (exists $self->{data}) { - $data = $self->{data}; - - } elsif (exists $self->{render_cb}) { - glViewport 0, 0, $self->{w}, $self->{h}; - glMatrixMode GL_PROJECTION; - glLoadIdentity; - glOrtho 0, $self->{w}, 0, $self->{h}, -10000, 10000; - glMatrixMode GL_MODELVIEW; - glLoadIdentity; - $self->{render_cb}->($self, $self->{w}, $self->{h}); +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 { - ($self->{w}, $self->{h}, $data, $self->{internalformat}, $self->{format}, $self->{type}) - = CFClient::load_image_inline $self->{image}; - } - - my ($tw, $th) = @$self{qw(w h)}; - - unless ($tw > 0 && $th > 0) { - $tw = $th = 1; - $data = "\x00" x 64; - } - - $self->{minified} = [CFClient::average $tw, $th, $data] - if $self->{minify}; - - unless ($GL_NPOT) { - # TODO: does not work for zero-sized textures - $tw = topot $tw; - $th = topot $th; - - if (($tw != $self->{w} || $th != $self->{h}) && defined $data) { - my $bpp = (length $data) / ($self->{w} * $self->{h}); - $data = pack "(a" . ($tw * $bpp) . ")*", - unpack "(a" . ($self->{w} * $bpp) . ")*", $data; - $data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{h}); - } + () } +} - $self->{s} = $self->{w} / $tw; - $self->{t} = $self->{h} / $th; - - $self->{name} ||= glGenTexture; +sub set_proxy { + my $proxy = http_proxy + or return; - glBindTexture GL_TEXTURE_2D, $self->{name}; + $ENV{http_proxy} = $proxy; +} - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP; - - if ($::FAST) { - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST; - } elsif ($self->{mipmap} && $GL_VERSION >= 1.4) { - # alternatively check for 0x8191 - glTexParameter GL_TEXTURE_2D, GL_GENERATE_MIPMAP, 1; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR; - } else { - glTexParameter GL_TEXTURE_2D, GL_GENERATE_MIPMAP, $self->{mipmap}; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR; - } +sub lwp_useragent { + require LWP::UserAgent; - glGetError; - - if (defined $data) { - glTexImage2D GL_TEXTURE_2D, 0, - $self->{internalformat}, - $tw, $th, - 0, - $self->{format}, - $self->{type}, - $data; - CFClient::gl_check "uploading texture %dx%d if=%x f=%x t=%x", - $tw, $th, $self->{internalformat}, $self->{format}, $self->{type}; - } else { - glCopyTexImage2D GL_TEXTURE_2D, 0, - $self->{internalformat}, - 0, 0, - $tw, $th, - 0; - CFClient::gl_check "copying to texture %dx%d if=%x", - $tw, $th, $self->{internalformat}; - } + CFPlus::set_proxy; - glBindTexture GL_TEXTURE_2D, 0; # just to be on the safe side + my $ua = LWP::UserAgent->new ( + agent => "cfplus $VERSION", + keep_alive => 1, + env_proxy => 1, + timeout => 30, + ); } -sub DESTROY { - my ($self) = @_; +sub lwp_check($) { + my ($res) = @_; - delete $TEXTURES{$self+0}; + $res->is_error + and die $res->status_line; - glDeleteTexture delete $self->{name} - if $self->{name}; + $res } -sub restore_state { - $_->upload - for values %TEXTURES; -} +package CFPlus::Layout; + +$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { + reset_glyph_cache; +}; 1;