--- deliantra/Deliantra-Client/DC.pm	2006/08/19 02:49:53	1.117
+++ deliantra/Deliantra-Client/DC.pm	2009/01/11 03:19:47	1.201
@@ -1,10 +1,10 @@
 =head1 NAME
 
-CFPlus - undocumented utility garbage for our crossfire client
+DC - undocumented utility garbage for our deliantra client
 
 =head1 SYNOPSIS
 
- use CFPlus;
+ use DC;
 
 =head1 DESCRIPTION
 
@@ -12,23 +12,30 @@
 
 =cut
 
-package CFPlus;
+package DC;
+
+use Carp ();
+
+our $VERSION;
 
 BEGIN {
-   $VERSION = '0.2';
+   $VERSION = '2.02';
 
    use XSLoader;
-   XSLoader::load "CFPlus", $VERSION;
+   XSLoader::load "Deliantra::Client", $VERSION;
 }
 
 use utf8;
+use strict qw(vars subs);
 
-use Carp ();
+use Socket ();
 use AnyEvent ();
-use BerkeleyDB;
+use AnyEvent::Util ();
 use Pod::POM ();
-use Scalar::Util ();
+use File::Path ();
 use Storable (); # finally
+use Fcntl ();
+use JSON::XS qw(encode_json decode_json);
 
 =item guard { BLOCK }
 
@@ -37,13 +44,23 @@
 =cut
 
 sub guard(&) {
-   bless \(my $cb = $_[0]), "CFPlus::Guard"
+   bless \(my $cb = $_[0]), "DC::Guard"
 }
 
-sub CFPlus::Guard::DESTROY {
+sub DC::Guard::DESTROY {
    ${$_[0]}->()
 }
 
+=item shorten $string[, $maxlength]
+
+=cut
+
+sub shorten($;$) {
+   my ($str, $len) = @_;
+   substr $str, $len, (length $str), "..." if $len + 3 <= length $str;
+   $str
+}
+
 sub asxml($) {
    local $_ = $_[0];
 
@@ -54,335 +71,212 @@
    $_
 }
 
-package CFPlus::Database;
+sub background(&;&) {
+   my ($bg, $cb) = @_;
 
-our @ISA = BerkeleyDB::Btree::;
+   my ($fh_r, $fh_w) = AnyEvent::Util::portable_socketpair
+     or die "unable to create background socketpair: $!";
 
-sub get($$) {
-   my $data;
+   my $pid = fork;
 
-   $_[0]->db_get ($_[1], $data) == 0
-      ? $data
-      : ()
-}
+   if (defined $pid && !$pid) {
+      local $SIG{__DIE__};
+
+      open STDOUT, ">&", $fh_w;
+      open STDERR, ">&", $fh_w;
+      close $fh_r;
+      close $fh_w;
 
-my %DB_SYNC;
+      $| = 1;
 
-sub put($$$) {
-   my ($db, $key, $data) = @_;
+      eval { $bg->() };
 
-   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;
+      if ($@) {
+         my $msg = $@;
+         $msg =~ s/\n+/\n/;
+         warn "FATAL: $msg";
+         DC::_exit 1;
+      }
+
+      # 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;
+   }
+
+   close $fh_w;
+
+   my $buffer;
+
+   my $w; $w = AnyEvent->io (fh => $fh_r, poll => 'r', cb => sub {
+      unless (sysread $fh_r, $buffer, 4096, length $buffer) {
+         undef $w;
+         $cb->();
+         return;
+      }
+
+      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 background_msg {
+   my ($msg) = @_;
 
-   $db->db_put ($key => $data)
+   $msg = "\x{e877}json_msg " . JSON::XS->new->allow_nonref->encode ($msg);
+   $msg =~ s/\n//g;
+   utf8::encode $msg;
+   print $msg, "\n";
 }
 
-package CFPlus;
+package DC;
+
+our $RC_THEME;
+our %THEME;
+our @RC_PATH;
+our $RC_BASE;
+
+for (grep !ref, @INC) {
+   $RC_BASE = "$_/Deliantra/Client/private/resources";
+   last if -d $RC_BASE;
+}
 
 sub find_rcfile($) {
    my $path;
 
-   for (grep !ref, @INC) {
-      $path = "$_/CFPlus/resources/$_[0]";
+   for (@RC_PATH, "") {
+      $path = "$RC_BASE/$_/$_[0]";
       return $path if -r $path;
    }
 
-   die "FATAL: can't find required file $_[0]\n";
+   die "FATAL: can't find required file \"$_[0]\" in \"$RC_BASE\"\n";
 }
 
-BEGIN {
-   use Crossfire::Protocol::Base ();
-   *to_json   = \&Crossfire::Protocol::Base::to_json;
-   *from_json = \&Crossfire::Protocol::Base::from_json;
-}
-
-sub read_cfg {
+sub load_json($) {
    my ($file) = @_;
 
    open my $fh, $file
       or return;
 
    local $/;
-   my $CFG = <$fh>;
-
-   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
-   }
+   JSON::XS->new->utf8->relaxed->decode (<$fh>)
 }
 
-sub write_cfg {
-   my ($file) = @_;
+sub set_theme($) {
+   return if $RC_THEME eq $_[0];
+   $RC_THEME = $_[0];
 
-   $::CFG->{VERSION} = $::VERSION;
+   # kind of hacky, find the main theme file, then load all theme files and merge them
 
-   open my $fh, ">:utf8", $file
-      or return;
-   print $fh to_json $::CFG;
-}
+   %THEME = ();
+   @RC_PATH = "theme-$RC_THEME";
 
-our $DB_ENV;
+   my $theme = load_json find_rcfile "theme.json"
+      or die "FATAL: theme resource file not found";
 
-{
-   use strict;
+   @RC_PATH = @{ $theme->{path} } if $theme->{path};
 
-   mkdir "$Crossfire::VARDIR/cfplus", 0777;
-   my $recover = $BerkeleyDB::db_version >= 4.4 
-                 ? eval "DB_REGISTER | DB_RECOVER"
-                 : 0;
+   for (@RC_PATH, "") {
+      my $theme = load_json "$RC_BASE/$_/theme.json"
+         or next;
 
-   $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";
+      %THEME = ( %$theme, %THEME );
+   }
 }
 
-sub db_table($) {
-   my ($table) = @_;
-
-   $table =~ s/([^a-zA-Z0-9_\-])/sprintf "=%x=", ord $1/ge;
+sub read_cfg {
+   my ($file) = @_;
 
-   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"
+   $::CFG = (load_json $file) || (load_json "$file.bak");
 }
 
-package CFPlus::Layout;
+sub write_cfg {
+   my $file = "$Deliantra::VARDIR/client.cf";
 
-$CFPlus::OpenGL::SHUTDOWN_HOOK{"CFPlus::Layout"} = sub {
-   reset_glyph_cache;
-};
+   $::CFG->{VERSION} = $::VERSION;
+   $::CFG->{layout}  = DC::UI::get_layout ();
 
-package CFPlus::Item;
+   open my $fh, ">:utf8", "$file~"
+      or return;
+   print $fh JSON::XS->new->utf8->pretty->encode ($::CFG);
+   close $fh;
 
-use strict;
-use Crossfire::Protocol::Constants;
+   rename $file, "$file.bak";
+   rename "$file~", $file;
+}
 
-my $last_enter_count = 1;
+sub http_proxy {
+   my @proxy = win32_proxy_info;
 
-sub desc_string {
-   my ($self) = @_;
-
-   my $desc =
-      $self->{nrof} < 2
-         ? $self->{name}
-         : "$self->{nrof} × $self->{name_pl}";
-
-   $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 .= " *";
-
-   $desc
-}
-
-sub weight_string {
-   my ($self) = @_;
-
-   my $weight = ($self->{nrof} || 1) * $self->{weight};
-
-   $weight < 0 ? "?" : $weight * 0.001
-}
-
-sub do_n_dialog {
-   my ($cb) = @_;
-
-   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->destroy;
-
-         0
-      },
-      on_escape => sub { $w->destroy; 1 },
-   );
-   $entry->grab_focus;
-   $w->show;
+   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 update_widgets {
-   my ($self) = @_;
-
-   # necessary to avoid cyclic references
-   Scalar::Util::weaken $self;
+sub set_proxy {
+   my $proxy = http_proxy
+      or return;
 
-   my $button_cb = sub {
-      my (undef, $ev, $x, $y) = @_;
+   $ENV{http_proxy} = $proxy;
+}
 
-      my $targ = $::CONN->{player}{tag};
+sub lwp_useragent {
+   require LWP::UserAgent;
+   
+   DC::set_proxy;
 
-      if ($self->{container} == $::CONN->{player}{tag}) {
-         $targ = $::CONN->{open_container};
-      }
+   my $ua = LWP::UserAgent->new (
+      agent      => "deliantra $VERSION",
+      keep_alive => 1,
+      env_proxy  => 1,
+      timeout    => 30,
+   );
+}
 
-      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";
-         }
+sub lwp_check($) {
+   my ($res) = @_;
 
-         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
-               ? (
-                  ["unlock", sub { $::CONN->send ("lock " . pack "CN", 0, $self->{tag}) }],
-                 )
-               : (
-                  ["lock",   sub { $::CONN->send ("lock " . pack "CN", 1, $self->{tag}) }],
-                  ["$move_prefix all",   sub { $::CONN->send ("move $targ $self->{tag} 0") }],
-                  ["$move_prefix &lt;n&gt;", 
-                     sub {
-                        do_n_dialog (sub { $::CONN->send ("move $targ $self->{tag} $_[0]") })
-                     }
-                  ]
-               )
-            ),
-         );
+   $res->is_error
+      and die $res->status_line;
 
-         CFPlus::UI::Menu->new (items => \@menu_items)->popup ($ev);
-      }
+   $res
+}
 
-      1
-   };
+sub fh_nonblocking($$) {
+   my ($fh, $nb) = @_;
 
-   my $tooltip_std = "<small>"
-                   . "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";
-
-   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};
-   $self->{face_widget}->set_tooltip (
-      "<b>Face/Animation.</b>\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 CFPlus::UI::Label
-      can_events => 1,
-      can_hover  => 1,
-      ellipsise  => 2,
-      align      => -1,
-      on_button_down => $button_cb,
-   ;
-   my $desc = CFPlus::Item::desc_string $self;
-   $self->{desc_widget}{bg} = $bg;
-   $self->{desc_widget}->set_text ($desc);
-   $self->{desc_widget}->set_tooltip ("<b>$desc</b>.\n$tooltip_std");
-
-   $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}{bg} = $bg;
-   $self->{weight_widget}->set_text (CFPlus::Item::weight_string $self);
-   $self->{weight_widget}->set_tooltip (
-      "<b>Weight</b>.\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"
-   );
+   if ($^O eq "MSWin32") {
+      $nb = (! ! $nb) + 0;
+      ioctl $fh, 0x8004667e, \$nb; # FIONBIO
+   } else {
+      fcntl $fh, &Fcntl::F_SETFL, $nb ? &Fcntl::O_NONBLOCK : 0;
+   }
 }
 
+package DC::Layout;
+
+$DC::OpenGL::INIT_HOOK{"DC::Layout"} = sub {
+   glyph_cache_restore;
+};
+
+$DC::OpenGL::SHUTDOWN_HOOK{"DC::Layout"} = sub {
+   glyph_cache_backup;
+};
+
 1;
 
 =back