--- deliantra/Deliantra-Client/DC.pm 2006/04/11 13:05:11 1.21 +++ deliantra/Deliantra-Client/DC.pm 2006/05/25 16:24:43 1.62 @@ -1,10 +1,10 @@ =head1 NAME -Crossfire::Client - undocumented utility garbage for our crossfire client +CFClient - undocumented utility garbage for our crossfire client =head1 SYNOPSIS - use Crossfire::Client; + use CFClient; =head1 DESCRIPTION @@ -12,34 +12,60 @@ =cut -package Crossfire::Client; +package CFClient; BEGIN { $VERSION = '0.1'; use XSLoader; - XSLoader::load "Crossfire::Client", $VERSION; + XSLoader::load "CFClient", $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; - Crossfire::Client::Texture::restore_state (); + if (my $error = glGetError) { + my ($format, @args) = @_; + Carp::cluck sprintf "opengl error %x while $format", $error, @args; + } } sub find_rcfile($) { my $path; - for (@INC) { - $path = "$_/Crossfire/resources/$_[0]"; + for (grep !ref, @INC) { + $path = "$_/CFClient/resources/$_[0]"; return $path if -r $path; } @@ -78,13 +104,201 @@ close CFG; } -package Crossfire::Client::Texture; +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"; +} + +sub pod_to_pango($) { + my ($pom) = @_; + + $pom->present ("CFClient::PodToPango") +} + +sub pod_to_pango_list($) { + my ($pom) = @_; + + [ + map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], + split /\n/, $pom->present ("CFClient::PodToPango") + ] +} + +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 view_item { + ("\t" x ($indent / 4)) + . $_[1]->title->present ($_[0]) + . "\n" + . $_[1]->content->present ($_[0]) +} + +sub view_verbatim { + (join "", + map +("\t" x ($indent / 2)) . "$_\n", + split /\n/, CFClient::UI::Label::escape ($_[1])) + . "\n" +} + +sub view_textblock { + ("\t" x ($indent / 2)) . "$_[1]\n\n" +} + +sub view_head1 { + "" . $_[1]->title->present ($_[0]) . "\n\n" + . $_[1]->content->present ($_[0]) +}; + +sub view_head2 { + "" . $_[1]->title->present ($_[0]) . "\n\n" + . $_[1]->content->present ($_[0]) +}; + +sub view_over { + local $indent = $indent + $_[1]->indent; + $_[1]->content->present ($_[0]) +} + +package CFClient::Database; + +our @ISA = BerkeleyDB::Btree::; + +sub get($$) { + my $data; + + $_[0]->db_get ($_[1], $data) == 0 + ? $data + : () +} + +my %DB_SYNC; + +sub put($$$) { + my ($db, $key, $data) = @_; + + $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync }); + + $db->db_put ($key => $data) +} + +package CFClient::Item; + +sub desc_string { + my ($self) = @_; + + my $desc = + $self->{nrof} < 2 + ? $self->{name} + : "$self->{nrof} × $self->{name_pl}"; + + $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 .= " *"; + + $desc +} + +sub weight_string { + my ($self) = @_; + + my $weight = ($self->{nrof} || 1) * $self->{weight}; + + $weight < 0 ? "?" : $weight * 0.001 +} + +sub update_widgets { + my ($self) = @_; + + 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; + $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 ellipsise => 2, can_events => 1, can_hover => 1; + $self->{desc_widget}->set_text (CFClient::Item::desc_string $self); + + $self->{weight_widget} ||= new CFClient::UI::Label ellipsise => 0, can_events => 1, can_hover => 1, align => 0.5; + $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 SDL::OpenGL; +use CFClient::OpenGL; -my @textures; +my %TEXTURES; sub new { my ($class, %data) = @_; @@ -92,11 +306,11 @@ my $self = bless { internalformat => GL_RGBA, format => GL_RGBA, + type => GL_UNSIGNED_BYTE, %data, }, $class; - push @textures, $self; - Scalar::Util::weaken $textures[-1]; + Scalar::Util::weaken ($TEXTURES{$self+0} = $self); $self->upload; @@ -104,19 +318,19 @@ } sub new_from_image { - my ($class, $image) = @_; + my ($class, $image, %arg) = @_; - $class->new (image => $image) + $class->new (image => $image, %arg) } sub new_from_file { - my ($class, $path) = @_; + my ($class, $path, %arg) = @_; open my $fh, "<:raw", $path or die "$path: $!"; local $/; - $class->new_from_image (<$fh>) + $class->new_from_image (<$fh>, %arg) } #sub new_from_surface { @@ -126,29 +340,31 @@ # # $class->new ( # data => $surface->pixels, -# width => $surface->width, -# height => $surface->height, +# w => $surface->width, +# h => $surface->height, # ) #} sub new_from_layout { - my ($class, $layout) = @_; + my ($class, $layout, %arg) = @_; - my ($w, $h, $data) = $layout->render; + my ($w, $h, $data, $format, $internalformat) = $layout->render; $class->new ( - width => $w, - height => $h, + w => $w, + h => $h, data => $data, - internalformat => GL_ALPHA4, - format => GL_ALPHA, + format => $format, + internalformat => $format, + type => GL_UNSIGNED_BYTE, + %arg, ) } sub new_from_opengl { my ($class, $w, $h, $cb) = @_; - $class->new (width => $w, height => $h, rendercb => $cb) + $class->new (w => $w || 1, h => $h || 1, render_cb => $cb) } sub topot { @@ -158,95 +374,112 @@ sub upload { my ($self) = @_; - return unless $SDL::App::USING_OPENGL; + return unless $GL_VERSION; my $data; if (exists $self->{data}) { $data = $self->{data}; - } elsif (exists $self->{rendercb}) { - glViewport 0, 0, $self->{width}, $self->{height}; + + } elsif (exists $self->{render_cb}) { + glViewport 0, 0, $self->{w}, $self->{h}; glMatrixMode GL_PROJECTION; glLoadIdentity; - glOrtho 0, $self->{width}, 0, $self->{height}, -10000, 10000; + glOrtho 0, $self->{w}, 0, $self->{h}, -10000, 10000; glMatrixMode GL_MODELVIEW; - glPushmatrix; glLoadIdentity; - glClear GL_COLOR_BUFFER_BIT; + $self->{render_cb}->($self, $self->{w}, $self->{h}); - $self->{rendercb}->($self, $self->{width}, $self->{height}); } else { - my $pb = new Gtk2::Gdk::PixbufLoader; - $pb->write ($self->{image}); - $pb->close; - - $pb = $pb->get_pixbuf; - $pb = $pb->add_alpha (0, 0, 0, 0); + ($self->{w}, $self->{h}, $data, $self->{internalformat}, $self->{format}, $self->{type}) + = CFClient::load_image_inline $self->{image}; + } - $self->{width} = $pb->get_width; - $self->{height} = $pb->get_height; + my ($tw, $th) = @$self{qw(w h)}; - $data = $pb->get_pixels; + unless ($tw > 0 && $th > 0) { + $tw = $th = 1; + $data = "\x00" x 64; } - my ($tw, $th) = @$self{qw(width height)}; + $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 (defined $data) { - my $bpp = (length $data) / ($self->{width} * $self->{height}); + 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->{width} * $bpp) . ")*", $data; - $data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{height}); + unpack "(a" . ($self->{w} * $bpp) . ")*", $data; + $data .= ("\x00" x ($tw * $bpp)) x ($th - $self->{h}); } } - $self->{s} = $self->{width} / $tw; - $self->{t} = $self->{height} / $th; + $self->{s} = $self->{w} / $tw; + $self->{t} = $self->{h} / $th; - $self->{name} ||= (glGenTextures 1)->[0]; + $self->{name} ||= glGenTexture; glBindTexture GL_TEXTURE_2D, $self->{name}; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR; - glTexParameter GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR;#_MIPMAP_LINEAR; 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; + } glGetError; + if (defined $data) { glTexImage2D GL_TEXTURE_2D, 0, $self->{internalformat}, - $tw, $th, # need to pad texture first + $tw, $th, 0, $self->{format}, - GL_UNSIGNED_BYTE, + $self->{type}, $data; - glGetError and die; + 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; - glPopmatrix; + CFClient::gl_check "copying to texture %dx%d if=%x", + $tw, $th, $self->{internalformat}; } + + glBindTexture GL_TEXTURE_2D, 0; # just to be on the safe side } sub DESTROY { my ($self) = @_; - return unless exists $self->{name}; + delete $TEXTURES{$self+0}; - glDeleteTextures delete $self->{name}; + glDeleteTexture delete $self->{name} + if $self->{name}; } -sub restore_state{ +sub restore_state { $_->upload - for grep $_, @textures; -}; + for values %TEXTURES; +} 1;