--- deliantra/Deliantra-Client/DC.pm 2006/05/27 20:46:54 1.72 +++ deliantra/Deliantra-Client/DC.pm 2008/12/12 15:06:00 1.198 @@ -1,10 +1,10 @@ =head1 NAME -CFClient - undocumented utility garbage for our crossfire client +DC - undocumented utility garbage for our deliantra client =head1 SYNOPSIS - use CFClient; + use DC; =head1 DESCRIPTION @@ -12,315 +12,269 @@ =cut -package CFClient; +package DC; + +use Carp (); + +our $VERSION; BEGIN { - $VERSION = '0.1'; + $VERSION = '2.01'; use XSLoader; - XSLoader::load "CFClient", $VERSION; + XSLoader::load "Deliantra::Client", $VERSION; } use utf8; +use strict qw(vars subs); -use Carp (); use AnyEvent (); -use BerkeleyDB; - -sub find_rcfile($) { - my $path; +use Pod::POM (); +use File::Path (); +use Storable (); # finally +use Fcntl (); +use JSON::XS qw(encode_json decode_json); - for (grep !ref, @INC) { - $path = "$_/CFClient/resources/$_[0]"; - return $path if -r $path; - } +=item guard { BLOCK } - die "FATAL: can't find required file $_[0]\n"; -} +Returns an object that executes the given block as soon as it is destroyed. -sub read_cfg { - my ($file) = @_; +=cut - open CFG, $file - or return; +sub guard(&) { + bless \(my $cb = $_[0]), "DC::Guard" +} - my $CFG; +sub DC::Guard::DESTROY { + ${$_[0]}->() +} - local $/; - $CFG = eval ; +=item shorten $string[, $maxlength] - $::CFG = $CFG; +=cut - close CFG; +sub shorten($;$) { + my ($str, $len) = @_; + substr $str, $len, (length $str), "..." if $len + 3 <= length $str; + $str } -sub write_cfg { - my ($file) = @_; +sub asxml($) { + local $_ = $_[0]; - open CFG, ">$file" - or return; + s/&/&/g; + s/>/>/g; + s/{VERSION} = $::VERSION; - print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]); - } + $_ +} + +sub socketpipe() { + socketpair my $fh1, my $fh2, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC + or die "cannot establish bidirectional pipe: $!\n"; - close CFG; + ($fh1, $fh2) } -mkdir "$Crossfire::VARDIR/pclient", 0777; +sub background(&;&) { + my ($bg, $cb) = @_; -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"; + my ($fh_r, $fh_w) = DC::socketpipe; -sub db_table($) { - my ($table) = @_; + my $pid = fork; - $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"; -} + if (defined $pid && !$pid) { + local $SIG{__DIE__}; -sub pod_to_pango($) { - my ($pom) = @_; + open STDOUT, ">&", $fh_w; + open STDERR, ">&", $fh_w; + close $fh_r; + close $fh_w; - $pom->present ("CFClient::PodToPango") -} + $| = 1; -sub pod_to_pango_list($) { - my ($pom) = @_; + eval { $bg->() }; - [ - map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], - split /\n/, $pom->present ("CFClient::PodToPango") - ] -} + if ($@) { + my $msg = $@; + $msg =~ s/\n+/\n/; + warn "FATAL: $msg"; + DC::_exit 1; + } -package CFClient::PodToPango; + # 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; + } -use base Pod::POM::View::Text; + close $fh_w; -our $indent = 0; + my $buffer; -*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]) }; + my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub { + unless (sysread $fh_r, $buffer, 4096, length $buffer) { + undef $w; + $cb->(); + return; + } -sub view_seq_text { - my $text = $_[1]; - $text =~ s/\s+/ /g; - CFClient::UI::Label::escape ($text) + 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 view_item { - ("\t" x ($indent / 4)) - . $_[1]->title->present ($_[0]) - . "\n" - . $_[1]->content->present ($_[0]) -} +sub background_msg { + my ($msg) = @_; -sub view_verbatim { - (join "", - map +("\t" x ($indent / 2)) . "$_\n", - split /\n/, CFClient::UI::Label::escape ($_[1])) - . "\n" + $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg); + $msg =~ s/\n//g; + utf8::encode $msg; + print $msg, "\n"; } -sub view_textblock { - ("\t" x ($indent / 2)) . "$_[1]\n\n" -} +package DC; -sub view_head1 { - "\n\n" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; +our $RC_THEME; +our %THEME; +our @RC_PATH; +our $RC_BASE; -sub view_head2 { - "\n" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; +for (grep !ref, @INC) { + $RC_BASE = "$_/Deliantra/Client/private/resources"; + last if -d $RC_BASE; +} -sub view_head3 { - "\n" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; +sub find_rcfile($) { + my $path; -sub view_over { - local $indent = $indent + $_[1]->indent; - $_[1]->content->present ($_[0]) -} + for (@RC_PATH, "") { + $path = "$RC_BASE/$_/$_[0]"; + return $path if -r $path; + } -package CFClient::Database; + die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n"; +} -our @ISA = BerkeleyDB::Btree::; +sub load_json($) { + my ($file) = @_; -sub get($$) { - my $data; + open my $fh, $file + or return; - $_[0]->db_get ($_[1], $data) == 0 - ? $data - : () + local $/; + JSON::XS->new->utf8->relaxed->decode (<$fh>) } -my %DB_SYNC; +sub set_theme($) { + return if $RC_THEME eq $_[0]; + $RC_THEME = $_[0]; -sub put($$$) { - my ($db, $key, $data) = @_; + # kind of hacky, find the main theme file, then load all theme files and merge them - $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync }); + %THEME = (); + @RC_PATH = "theme-$RC_THEME"; - $db->db_put ($key => $data) + 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 ); + } } -package CFClient::Item; +sub read_cfg { + my ($file) = @_; + + $::CFG = load_json $file; +} -use strict; -use Crossfire::Protocol::Constants; +sub write_cfg { + my $file = "$Deliantra::VARDIR/client.cf"; -sub desc_string { - my ($self) = @_; + $::CFG->{VERSION} = $::VERSION; - my $desc = - $self->{nrof} < 2 - ? $self->{name} - : "$self->{nrof} × $self->{name_pl}"; + open my $fh, ">:utf8", $file + or return; + print $fh JSON::XS->new->utf8->pretty->encode ($::CFG); +} - $self->{flags} & F_OPEN - and $desc .= " (open)"; - $self->{flags} & F_APPLIED - and $desc .= " (applied)"; - $self->{flags} & F_UNPAID - and $desc .= " (unpaid)"; - $self->{flags} & F_MAGIC - and $desc .= " (magic)"; - $self->{flags} & F_CURSED - and $desc .= " (cursed)"; - $self->{flags} & F_DAMNED - and $desc .= " (damned)"; - $self->{flags} & F_LOCKED - and $desc .= " *"; +sub http_proxy { + my @proxy = win32_proxy_info; - $desc + 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 weight_string { - my ($self) = @_; +sub set_proxy { + my $proxy = http_proxy + or return; + + $ENV{http_proxy} = $proxy; +} - my $weight = ($self->{nrof} || 1) * $self->{weight}; +sub lwp_useragent { + require LWP::UserAgent; + + DC::set_proxy; - $weight < 0 ? "?" : $weight * 0.001 + my $ua = LWP::UserAgent->new ( + agent => "deliantra $VERSION", + keep_alive => 1, + env_proxy => 1, + timeout => 30, + ); } -sub update_widgets { - my ($self) = @_; +sub lwp_check($) { + my ($res) = @_; - my $button_cb = sub { - my (undef, $ev, $x, $y) = @_; + $res->is_error + and die $res->status_line; - if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { - my $targ = $::CONN->{player}{tag}; + $res +} - if ($self->{container} == $::CONN->{player}{tag}) { - $targ = $::CONN->{open_container}; - } +sub fh_nonblocking($$) { + my ($fh, $nb) = @_; - $::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} & 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 $::CONN->{open_container} $self->{tag} 0") }], - ) - ), - ); + if ($^O eq "MSWin32") { + $nb = (! ! $nb) + 0; + ioctl $fh, 0x8004667e, \$nb; # FIONBIO + } else { + fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0; + } +} - CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); - } +package DC::Layout; - 1 - }; +$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub { + glyph_cache_restore; +}; - 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, - anim => $self->{anim}, - animspeed => $self->{animspeed}, # TODO# must be set at creation time - on_button_down => $button_cb, - ; - $self->{face_widget}{face} = $self->{face}; - $self->{face_widget}{anim} = $self->{anim}; - $self->{face_widget}{animspeed} = $self->{animspeed}; - $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, - align => -1, - on_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, - align => 0, - on_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" - ); -} +$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub { + glyph_cache_backup; +}; 1;