--- deliantra/Deliantra-Client/DC.pm 2006/06/01 05:04:34 1.85 +++ deliantra/Deliantra-Client/DC.pm 2006/10/09 01:06:36 1.123 @@ -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,196 +12,256 @@ =cut -package CFClient; +package CFPlus; + +use Carp (); BEGIN { - $VERSION = '0.1'; + $VERSION = '0.52'; use XSLoader; - XSLoader::load "CFClient", $VERSION; + XSLoader::load "CFPlus", $VERSION; +} + +BEGIN { + $SIG{__DIE__} = sub { + return if CFPlus::in_destruct; + #CFPlus::fatal $_[0];#d# + CFPlus::error Carp::longmess $_[0];#d# + die;#d# + }; } use utf8; -use Carp (); use AnyEvent (); use BerkeleyDB; +use Pod::POM (); +use Scalar::Util (); +use Storable (); # finally -sub find_rcfile($) { - my $path; +=item guard { BLOCK } - for (grep !ref, @INC) { - $path = "$_/CFClient/resources/$_[0]"; - return $path if -r $path; - } +Returns an object that executes the given block as soon as it is destroyed. - die "FATAL: can't find required file $_[0]\n"; +=cut + +sub guard(&) { + bless \(my $cb = $_[0]), "CFPlus::Guard" } -sub read_cfg { - my ($file) = @_; +sub CFPlus::Guard::DESTROY { + ${$_[0]}->() +} - open CFG, $file - or return; +sub asxml($) { + local $_ = $_[0]; - my $CFG; + s/&/&/g; + s/>/>/g; + s/; + $_ +} - $::CFG = $CFG; +sub socketpipe() { + socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC + or die "cannot establish bidiretcional pipe: $!\n"; - close CFG; + ($fh1, $fh2) } -sub write_cfg { - my ($file) = @_; +sub background(&) { + my ($cb) = @_; - open CFG, ">$file" - or return; + my ($fh_r, $fh_w) = CFPlus::socketpipe; - { - require Data::Dumper; - local $Data::Dumper::Purity = 1; - $::CFG->{VERSION} = $::VERSION; - print CFG Data::Dumper->Dump ([$::CFG], [qw/CFG/]); + my $pid = fork; + + if (defined $pid && !$pid) { + $SIG{__DIE__} = sub { + my $msg = $_[0]; + $msg =~ s/\n+/\n/; + warn "FATAL: $msg"; + CFPlus::_exit 99; + }; + + open STDOUT, ">&", $fh_w; + open STDERR, ">&", $fh_w; + close $fh_r; + close $fh_w; + + $| = 1; + + $cb->(); + + # 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 CFG; -} + close $fh_w; -mkdir "$Crossfire::VARDIR/cfplus", 0777; + my $buffer; -our $DB_ENV; + Event->io (fd => $fh_r, poll => 'r', cb => sub { + unless (sysread $fh_r, $buffer, 4096, length $buffer) { + $_[0]->w->cancel; + $buffer .= "done\n"; + } -{ - use strict; + while ($buffer =~ s/^(.*)\n//) { + my $line = $1; + utf8::decode $line; + ::message ({ + markup => "editor($pid): " . CFPlus::asxml $line, + }); + } + }); +} - my $recover = $BerkeleyDB::db_version >= 4.4 - ? eval "DB_REGISTER | DB_RECOVER" - : 0; +package CFPlus::Database; - $DB_ENV = new BerkeleyDB::Env - -Home => "$Crossfire::VARDIR/cfplus", - -Cachesize => 1_000_000, - -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt", -# -ErrPrefix => "DATABASE", - -Verbose => 1, - -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover, - -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE, - or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error"; +our @ISA = BerkeleyDB::Btree::; + +sub get($$) { + my $data; + + $_[0]->db_get ($_[1], $data) == 0 + ? $data + : () } -sub db_table($) { - my ($table) = @_; +my %DB_SYNC; - $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; +sub put($$$) { + my ($db, $key, $data) = @_; - 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" + my $hkey = $db + 0; + Scalar::Util::weaken $db; + $DB_SYNC{$hkey} ||= AnyEvent->timer (after => 5, cb => sub { + delete $DB_SYNC{$hkey}; + $db->db_sync if $db; + }); + + $db->db_put ($key => $data) } -sub pod_to_pango($) { - my ($pom) = @_; +package CFPlus; - $pom->present ("CFClient::PodToPango") -} +sub find_rcfile($) { + my $path; -sub pod_to_pango_list($) { - my ($pom) = @_; + for (grep !ref, @INC) { + $path = "$_/CFPlus/resources/$_[0]"; + return $path if -r $path; + } - [ - map s/^(\s*)// && [40 * length $1, length $_ ? $_ : " "], - split /\n/, $pom->present ("CFClient::PodToPango") - ] + die "FATAL: can't find required file $_[0]\n"; } -package CFClient::PodToPango; +BEGIN { + use Crossfire::Protocol::Base (); + *to_json = \&Crossfire::Protocol::Base::to_json; + *from_json = \&Crossfire::Protocol::Base::from_json; +} -use base Pod::POM::View::Text; +sub read_cfg { + my ($file) = @_; -our $indent = 0; + open my $fh, $file + or return; -*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]) }; + local $/; + my $CFG = <$fh>; -sub view_seq_text { - my $text = $_[1]; - $text =~ s/\s+/ /g; - CFClient::UI::Label::escape ($text) + 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 view_item { - ("\t" x ($indent / 4)) - . $_[1]->title->present ($_[0]) - . "\n" - . $_[1]->content->present ($_[0]) -} +sub write_cfg { + my ($file) = @_; -sub view_verbatim { - (join "", - map +("\t" x ($indent / 2)) . "$_\n", - split /\n/, CFClient::UI::Label::escape ($_[1])) - . "\n" -} + $::CFG->{VERSION} = $::VERSION; -sub view_textblock { - ("\t" x ($indent / 2)) . "$_[1]\n\n" + open my $fh, ">:utf8", $file + or return; + print $fh to_json $::CFG; } -sub view_head1 { - "\n\n" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; +sub http_proxy { + my @proxy = win32_proxy_info; -sub view_head2 { - "\n" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; + 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 view_head3 { - "\n" . $_[1]->title->present ($_[0]) . "\n\n" - . $_[1]->content->present ($_[0]) -}; +sub set_proxy { + my $proxy = http_proxy + or return; -sub view_over { - local $indent = $indent + $_[1]->indent; - $_[1]->content->present ($_[0]) + $ENV{http_proxy} = $proxy; } -package CFClient::Database; +our $DB_ENV; +our $DB_STATE; -our @ISA = BerkeleyDB::Btree::; +sub db_table($) { + my ($table) = @_; -sub get($$) { - my $data; + $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge; - $_[0]->db_get ($_[1], $data) == 0 - ? $data - : () + new CFPlus::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" } -my %DB_SYNC; +{ + use strict; -sub put($$$) { - my ($db, $key, $data) = @_; + mkdir "$Crossfire::VARDIR/cfplus", 0777; + my $recover = $BerkeleyDB::db_version >= 4.4 + ? eval "DB_REGISTER | DB_RECOVER" + : 0; - $DB_SYNC{$db} = AnyEvent->timer (after => 5, cb => sub { $db->db_sync }); + $DB_ENV = new BerkeleyDB::Env + -Home => "$Crossfire::VARDIR/cfplus", + -Cachesize => 1_000_000, + -ErrFile => "$Crossfire::VARDIR/cfplus/errorlog.txt", +# -ErrPrefix => "DATABASE", + -Verbose => 1, + -Flags => DB_CREATE | DB_RECOVER | DB_INIT_MPOOL | DB_INIT_LOCK | DB_INIT_TXN | $recover, + -SetFlags => DB_AUTO_COMMIT | DB_LOG_AUTOREMOVE, + or die "unable to create/open database home $Crossfire::VARDIR/cfplus: $BerkeleyDB::Error"; - $db->db_put ($key => $data) + $DB_STATE = db_table "state"; } -package CFClient::Item; +package CFPlus::Layout; + +$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub { + reset_glyph_cache; +}; + +package CFPlus::Item; use strict; use Crossfire::Protocol::Constants; @@ -245,27 +305,36 @@ sub do_n_dialog { my ($cb) = @_; - my $w = new CFClient::UI::FancyFrame; - $w->add (my $vb = new CFClient::UI::VBox x => "center", y => "center"); - $vb->add (new CFClient::UI::Label text => "Enter item count:"); - $vb->add (my $entry = new CFClient::UI::Entry + my $w = new CFPlus::UI::Toplevel + on_delete => sub { $_[0]->destroy; 1 }, + has_close_button => 1, + ; + + $w->add (my $vb = new CFPlus::UI::VBox x => "center", y => "center"); + $vb->add (new CFPlus::UI::Label text => "Enter item count:"); + $vb->add (my $entry = new CFPlus::UI::Entry text => $last_enter_count, on_activate => sub { my ($entry) = @_; $last_enter_count = $entry->get_text; $cb->($last_enter_count); $w->hide; - $w = undef; - } + $w->destroy; + + 0 + }, + on_escape => sub { $w->destroy; 1 }, ); - $entry->focus_in; + $entry->grab_focus; $w->show; - } sub update_widgets { my ($self) = @_; + # necessary to avoid cyclic references + Scalar::Util::weaken $self; + my $button_cb = sub { my (undef, $ev, $x, $y) = @_; @@ -275,17 +344,51 @@ $targ = $::CONN->{open_container}; } - if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) { + if (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 1) { $::CONN->send ("move $targ $self->{tag} 0") if $targ || !($self->{flags} & F_LOCKED); + } elsif (($ev->{mod} & CFPlus::KMOD_SHIFT) && $ev->{button} == 2) { + $self->{flags} & F_LOCKED + ? $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) + : $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) } elsif ($ev->{button} == 1) { $::CONN->send ("examine $self->{tag}"); } elsif ($ev->{button} == 2) { $::CONN->send ("apply $self->{tag}"); } elsif ($ev->{button} == 3) { + my $move_prefix = $::CONN->{open_container} ? 'put' : 'drop'; + if ($self->{container} == $::CONN->{open_container}) { + $move_prefix = "take"; + } + my @menu_items = ( ["examine", sub { $::CONN->send ("examine $self->{tag}") }], ["mark", sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }], + ["ignite/thaw", # first try of an easier use of flint&steel + sub { + $::CONN->send ("mark ". pack "N", $self->{tag}); + $::CONN->send ("command apply flint and steel"); + } + ], + ["inscribe", # first try of an easier use of flint&steel + sub { + &::open_string_query ("Text to inscribe", sub { + my ($entry, $txt) = @_; + $::CONN->send ("mark ". pack "N", $self->{tag}); + $::CONN->send ("command use_skill inscription $txt"); + }); + } + ], + ["rename", # first try of an easier use of flint&steel + sub { + &::open_string_query ("Rename item to:", sub { + my ($entry, $txt) = @_; + $::CONN->send ("mark ". pack "N", $self->{tag}); + $::CONN->send ("command rename to <$txt>"); + }, $self->{name}, + "If you input no name or erase the current custom name, the custom name will be unset"); + } + ], ["apply", sub { $::CONN->send ("apply $self->{tag}") }], ( $self->{flags} & F_LOCKED @@ -294,8 +397,8 @@ ) : ( ["lock", sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }], - ["drop", sub { $::CONN->send ("move $::CONN->{open_container} $self->{tag} 0") }], - ["move n", + ["$move_prefix all", sub { $::CONN->send ("move $targ $self->{tag} 0") }], + ["$move_prefix <n>", sub { do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") }) } @@ -304,7 +407,7 @@ ), ); - CFClient::UI::Menu->new (items => \@menu_items)->popup ($ev); + CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev); } 1 @@ -314,16 +417,22 @@ . "Left click - examine item\n" . "Shift-Left click - " . ($self->{container} ? "move or drop" : "take") . " item\n" . "Middle click - apply\n" + . "Shift-Middle click - lock/unlock\n" . "Right click - further options" . "\n"; - $self->{face_widget} ||= new CFClient::UI::Face + my $bg = $self->{flags} & F_CURSED ? [1 , 0 , 0, 0.5] + : $self->{flags} & F_MAGIC ? [0.2, 0.2, 1, 0.5] + : undef; + + $self->{face_widget} ||= new CFPlus::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}{bg} = $bg; $self->{face_widget}{face} = $self->{face}; $self->{face_widget}{anim} = $self->{anim}; $self->{face_widget}{animspeed} = $self->{animspeed}; @@ -334,26 +443,27 @@ . "\n\n$tooltip_std" ); - $self->{desc_widget} ||= new CFClient::UI::Label + $self->{desc_widget} ||= new CFPlus::UI::Label can_events => 1, can_hover => 1, ellipsise => 2, align => -1, on_button_down => $button_cb, ; - my $desc = CFClient::Item::desc_string $self; + my $desc = CFPlus::Item::desc_string $self; + $self->{desc_widget}{bg} = $bg; $self->{desc_widget}->set_text ($desc); $self->{desc_widget}->set_tooltip ("$desc.\n$tooltip_std"); - $self->{weight_widget} ||= new CFClient::UI::Label + $self->{weight_widget} ||= new CFPlus::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}{bg} = $bg; + $self->{weight_widget}->set_text (CFPlus::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. ") @@ -362,113 +472,6 @@ ); } -package CFClient::Binder; - -my @ALLOWED_MODIFIER_KEYS = ( - CFClient::SDLK_LSHIFT, - CFClient::SDLK_LCTRL , - CFClient::SDLK_LALT , - CFClient::SDLK_LMETA , - - CFClient::SDLK_RSHIFT, - CFClient::SDLK_RCTRL , - CFClient::SDLK_RALT , - CFClient::SDLK_RMETA , -); - -my %ALLOWED_MODIFIERS = ( - CFClient::KMOD_LSHIFT => "LSHIFT", - CFClient::KMOD_LCTRL => "LCTRL", - CFClient::KMOD_LALT => "LALT", - CFClient::KMOD_LMETA => "LMETA", - - CFClient::KMOD_RSHIFT => "RSHIFT", - CFClient::KMOD_RCTRL => "RCTRL", - CFClient::KMOD_RALT => "RALT", - CFClient::KMOD_RMETA => "RMETA", -); - -my %DIRECT_BIND_CHARS = map { $_ => 1 } qw/0 1 2 3 4 5 6 7 8 9/; -my @DIRECT_BIND_KEYS = ( - CFClient::SDLK_F1, - CFClient::SDLK_F2, - CFClient::SDLK_F3, - CFClient::SDLK_F4, - CFClient::SDLK_F5, - CFClient::SDLK_F6, - CFClient::SDLK_F7, - CFClient::SDLK_F8, - CFClient::SDLK_F9, - CFClient::SDLK_F10, - CFClient::SDLK_F11, - CFClient::SDLK_F12, - CFClient::SDLK_F13, - CFClient::SDLK_F14, - CFClient::SDLK_F15, -); - -# this binding dialog asks for a key-combo to be pressed -# and if successful it calls the $cb with $mod and $sym as args. -sub open_binding_dialog { - my ($cb) = @_; - - my $w = new CFClient::UI::FancyFrame - title => "Bind Action", - x => "center", - y => "center"; - - $w->add (my $vb = new CFClient::UI::VBox); - $vb->add (new CFClient::UI::Label - text => "Press a modifier (CTRL, ALT and/or SHIFT) and a key." - ."You can only bind 0-9 and F1-F15 without modifiers." - ); - $vb->add (my $entry = new CFClient::UI::Entry - text => "", - on_key_down => sub { - my ($entry, $ev) = @_; - - my $mod = $ev->{mod}; - my $sym = $ev->{sym}; - - # XXX: This seems a little bit hackisch to me, but i have to ignore them - if (grep { $_ == $sym } @ALLOWED_MODIFIER_KEYS) { - return; - } - - if ($mod == CFClient::KMOD_NONE - and not $DIRECT_BIND_CHARS{chr ($ev->{unicode})} - and not grep { $sym == $_ } @DIRECT_BIND_KEYS) - { - $::STATUSBOX->add ( - "Can't bind key ".CFClient::SDL_GetKeyName ($sym) - ." directly without modifier! It would damage the completer handling." - ); - return; - } - - $entry->focus_out; - - $cb->($mod, $sym); - - $w->destroy - }); - - $entry->focus_in; - $w->show; -} - -sub keycombo_to_name { - my ($mod, $sym) = @_; - - my $mods = join '+', - map { $ALLOWED_MODIFIERS{$_} } - grep { ($_ + 0) & ($mod + 0) } - keys %ALLOWED_MODIFIERS; - $mods .= "+" if $mods ne ''; - - return $mods . CFClient::SDL_GetKeyName ($sym); -} - 1; =back