--- deliantra/Deliantra-Client/DC.pm	2006/05/26 18:28:23	1.70
+++ deliantra/Deliantra-Client/DC.pm	2006/07/02 13:57:57	1.95
@@ -26,95 +26,16 @@
 use Carp ();
 use AnyEvent ();
 use BerkeleyDB;
-
-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 <CFG>;
-
-   $::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";
-}
-
-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")
-   ]
-}
+use Pod::POM ();
+use Scalar::Util ();
+use Storable (); # finally
 
 package CFClient::PodToPango;
 
 use base Pod::POM::View::Text;
 
+our $VERSION = 1; # bump if resultant formatting changes
+
 our $indent = 0;
 
 *view_seq_code   =
@@ -133,7 +54,7 @@
 sub view_item {
    ("\t" x ($indent / 4))
    . $_[1]->title->present ($_[0])
-   . "\n"
+   . "\n\n"
    . $_[1]->content->present ($_[0])
 }
 
@@ -190,8 +111,139 @@
    $db->db_put ($key => $data)
 }
 
+package CFClient;
+
+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 <CFG>;
+
+   $::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;
+}
+
+our $DB_ENV;
+
+{
+   use strict;
+
+   mkdir "$Crossfire::VARDIR/cfplus", 0777;
+   my $recover = $BerkeleyDB::db_version >= 4.4 
+                 ? eval "DB_REGISTER | DB_RECOVER"
+                 : 0;
+
+   $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";
+}
+
+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"
+}
+
+my $pod_cache = db_table "pod_cache";
+
+sub load_pod($$$$) {
+   my ($path, $filtertype, $filterversion, $filtercb) = @_;
+
+   stat $path
+      or die "$path: $!";
+
+   my $phash = join ",", $filterversion, $CFClient::PodToPango::VERSION, (stat _)[7,9];
+
+   my ($chash, $pom) = eval { @{ Storable::thaw $pod_cache->get ("$path/$filtertype") } };
+
+   return $pom if $chash eq $phash;
+
+   my $pod = do {
+      local $/;
+      open my $pod, "<:utf8", $_[0]
+         or die "$_[0]: $!";
+      <$pod>
+   };
+
+   #utf8::downgrade $pod;
+
+   $pom = $filtercb-> (Pod::POM->new->parse_text ($pod));
+
+   $pod_cache->put ("$path/$filtertype" => Storable::nfreeze [$phash, $pom]);
+
+   $pom
+}
+
+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::Item;
 
+use strict;
+use Crossfire::Protocol::Constants;
+
+my $last_enter_count = 1;
+
 sub desc_string {
    my ($self) = @_;
 
@@ -200,19 +252,19 @@
          ? $self->{name}
          : "$self->{nrof} × $self->{name_pl}";
 
-   $self->{flags} & Crossfire::Protocol::F_OPEN
+   $self->{flags} & F_OPEN
       and $desc .= " (open)";
-   $self->{flags} & Crossfire::Protocol::F_APPLIED
+   $self->{flags} & F_APPLIED
       and $desc .= " (applied)";
-   $self->{flags} & Crossfire::Protocol::F_UNPAID
+   $self->{flags} & F_UNPAID
       and $desc .= " (unpaid)";
-   $self->{flags} & Crossfire::Protocol::F_MAGIC
+   $self->{flags} & F_MAGIC
       and $desc .= " (magic)";
-   $self->{flags} & Crossfire::Protocol::F_CURSED
+   $self->{flags} & F_CURSED
       and $desc .= " (cursed)";
-   $self->{flags} & Crossfire::Protocol::F_DAMNED
+   $self->{flags} & F_DAMNED
       and $desc .= " (damned)";
-   $self->{flags} & Crossfire::Protocol::F_LOCKED
+   $self->{flags} & F_LOCKED
       and $desc .= " *";
 
    $desc
@@ -226,20 +278,49 @@
    $weight < 0 ? "?" : $weight * 0.001
 }
 
+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
+      text => $last_enter_count,
+      on_activate => sub {
+         my ($entry) = @_;
+         $last_enter_count = $entry->get_text;
+         $cb->($last_enter_count);
+         $w->hide;
+         $w = undef;
+      }
+   );
+   $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) = @_;
 
-      if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
-         my $targ = $::CONN->{player}{tag};
+      my $targ = $::CONN->{player}{tag};
 
-         if ($self->{container} == $::CONN->{player}{tag}) {
-            $targ = $::CONN->{open_container};
-         }
+      if ($self->{container} == $::CONN->{player}{tag}) {
+         $targ = $::CONN->{open_container};
+      }
 
-         $::CONN->send ("move $targ $self->{tag} 0");
+      if (($ev->{mod} & CFClient::KMOD_SHIFT) && $ev->{button} == 1) {
+         $::CONN->send ("move $targ $self->{tag} 0")
+            if $targ || !($self->{flags} & F_LOCKED);
+      } elsif (($ev->{mod} & CFClient::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) {
@@ -250,13 +331,18 @@
             ["mark",    sub { $::CONN->send ("mark ". pack "N", $self->{tag}) }],
             ["apply",   sub { $::CONN->send ("apply $self->{tag}") }],
             (
-               $self->{flags} & Crossfire::Protocol::F_LOCKED
+               $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") }],
+                  ["move n", 
+                     sub {
+                        do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
+                     }
+                  ]
                )
             ),
          );
@@ -271,6 +357,7 @@
                    . "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"
                    . "</small>\n";
 
@@ -279,7 +366,7 @@
       can_hover  => 1,
       anim       => $self->{anim},
       animspeed  => $self->{animspeed}, # TODO# must be set at creation time
-      connect_button_down => $button_cb,
+      on_button_down => $button_cb,
    ;
    $self->{face_widget}{face}      = $self->{face};
    $self->{face_widget}{anim}      = $self->{anim};
@@ -296,7 +383,7 @@
       can_hover  => 1,
       ellipsise  => 2,
       align      => -1,
-      connect_button_down => $button_cb,
+      on_button_down => $button_cb,
    ;
    my $desc = CFClient::Item::desc_string $self;
    $self->{desc_widget}->set_text ($desc);
@@ -307,7 +394,7 @@
       can_hover  => 1,
       ellipsise  => 0,
       align      => 0,
-      connect_button_down => $button_cb,
+      on_button_down => $button_cb,
    ;
    $self->{weight_widget}->set_text (CFClient::Item::weight_string $self);
 
@@ -319,6 +406,115 @@
    );
 }
 
+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",
+      z     => 1000,
+      has_close_button => 1;
+
+   $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->grab_focus;
+
+         $cb->($mod, $sym);
+
+         $w->destroy
+      });
+
+   $entry->grab_focus;
+   $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