#########################################################################
## All portions of this code are copyright (c) 2003,2004 nethype GmbH   ##
##########################################################################
## Using, reading, modifying or copying this code requires a LICENSE    ##
## from nethype GmbH, Franz-Werfel-Str. 11, 74078 Heilbronn,            ##
## Germany. If you happen to have questions, feel free to contact us at ##
## license@nethype.de.                                                  ##
##########################################################################

package Agni;

=encoding utf-8

=head1 NAME

Agni - persistent data and objects

=head1 SYNOPSIS

I<This module requires the PApp module to be installed and working. Please
read the LICENSE file: this version of Agni is neither GPL nor BSD
licensed).>

=head1 DESCRIPTION

Agni is the God of the Sun and Fire. The rest is obvious...

Most of these functions are low-level stuff. Better look at the methods
of the agni root object (本) first, which has most of the functionality
packaged in a nicer way.

=head2 FUNCTIONS

=over 4

=cut

use strict qw(vars subs);

use utf8;

use Carp;

use PApp::Config qw(DBH $DBH $Database); DBH;

use PApp ();
use PApp::Env;
use PApp::SQL;
use PApp::Event;
use PApp::Preprocessor;
use PApp::PCode qw(pxml2pcode perl2pcode pcode2perl);
use PApp::Callback ();
use PApp::Exception;
use PApp::I18n ();

# load these so their callbacks can be registered
# TODO: should be done by papp proper
use PApp::EditForm ();
use PApp::XPCSE ();

use Convert::Scalar ":utf8";

use base Exporter::;

our $app; # current application object
our $env; # current content::environment

our %temporary; # used by the "temporary" attribute type

BEGIN {
   *DEVEL_TRACE = sub () { 0 }
      unless defined &DEVEL_TRACE;
}

BEGIN {
   # I was lazy, all the util xs functions are in PApp.xs
   require XSLoader;
   XSLoader::load PApp, $PApp::VERSION unless defined &PApp::bootstrap;
}

our @EXPORT = qw(
      require_path new_objectid

      %obj_cache

      path_obj_by_gid gid obj_of obj_by_name

      %pathid @pathname @pathmask @subpathmask @parpathmask @parpath

      agni_exec agni_refresh
);

our @EXPORT_OK = (@EXPORT, qw(
      *app *env
));

# packages used to provide useful compilation environment
use PApp::HTML;

our %obj_cache; # obj_cache{$gid}[$pathid]

my @agni_bootns; # boot package objects
my %ns_cache;    # the package object cache

our %pathid;      # name => id
our @parpath;     # id => id
our @pathname;    # id => name
our @pathmask;    # id => maskbit
our @subpathmask; # id => subpath mask (|| of path + all subpaths)
our @parpathmask; # id => parent path mask (|| of all parents, sans path itself)

our $last_compile_status;

# reserved object gids
# <20 == must only use string types and perl methods, for bootstrapping.

our $OID_OBJECT			= 1;
our $OID_ATTR			= 2;
our $OID_ATTR_NAMED		= 3;
our $OID_METHOD			= 4;
our $OID_METHOD_ARGS		= 5;
our $OID_DATA			= 6;
our $OID_DATA_STRING		= 7;
our $OID_METHOD_PERL		= 8;
our $OID_ATTR_SQLCOL		= 9;

our $OID_METHOD_PXML		= 20;
our $OID_META			= 21;
our $OID_META_DESC		= 22;
our $OID_META_NAME		= 23;
our $OID_ATTR_NAME		= 24;
our $OID_ATTR_CONTAINER		= 25;
our $OID_DATA_REF		= 26;
our $OID_IFACE_CONTAINER	= 27; # object has a gc_enum, + obj_enum methods (NYI)
our $OID_META_NOTE		= 28; # notes/flags for objects
our $OID_ATTR_TAG		= 29; # objects used as tags for containers
our $OID_META_PACKAGE		= 30; # perl package name
our $OID_INTERFACE		= 31; # class interface
our $OID_ROOTSET		= 32; # a container containing all objects that are alive "by default"
our $OID_ISA			= 33; # the data/method parent for lookups
our $OID_ISA_METHOD		= 5100001742; # the gids start to get ugly here
our $OID_ISA_DATA		= 5100001741;
our $OID_CMDLINE_HANDLER	= 21474836484; # util::cmdline
our $OID_META_PACKAGE		= 4295048763;
our $OID_PACKAGE_DEFAULT	= 4295049779; # lots of special-casing for that one
our $OID_META_PARCEL		= 5100000280;
our $OID_NAMESPACES		= 5100003444; # circular reference of namespace_base to namespace
our $OID_ISA_NAMESPACE		= 5100003446;
our $OID_COMMITINFO		= 5100004671; # used in split_obj, the committer, and more

our %BOOTSTRAP_LEVEL; # indexed by {gid}

sub UPDATE_PATHID() { 0x01 }
sub UPDATE_ATTR()   { 0x02 }
sub UPDATE_CLASS()  { 0x04 }
sub UPDATE_PATHS()  { 0x08 }
sub UPDATE_ALL()    { 0x10 }

sub init_paths {
   %pathid =
   @pathname =
   @pathmask =
   @subpathmask =
   @parpathmask = ();

   # all paths, shorter ones first
   my $st = sql_exec \my($id, $mask, $name), "select id, (1 << id), path from obj_path order by path";
   while ($st->fetch) {
      $pathid{$name} = $id;
      $pathname[$id] = $name;
      $pathmask[$id] = $mask;
      $parpathmask[$id] = sql_fetch "select coalesce(sum(1 << id), 0) from obj_path
                                     where left(?, length(path)) = path and ? != path",
                                     $name, $name;
      $subpathmask[$id] = sql_fetch "select coalesce(sum(1 << id), 0) from obj_path
                                     where path like ?",
                                     "$name%";
      $parpath[$id] = $pathid{$name} if $name =~ s/[^\/]+\/$//;
   }

   for (values %obj_cache) {
      for (@$_) {
         $_
            and $_->{_paths} =
               sql_fetch "select paths from obj where gid = ? and paths & (1 << ?) <> 0",
                         $_->{_gid}, $_->{_path};
      }
   }
}

sub top_path {
   my $paths = $_[0];
   for (sort { (length $a) <=> (length $b) } keys %pathid) {
      return $pathid{$_} if and64 $paths, $pathmask[$pathid{$_}];
   }
   croak "top_path called with illegal paths mask ($paths)";
}

our @sqlcol = (
   "d_int",
   "d_double",
   "d_string",
   "d_blob",
   "d_fulltext",
);

our %sqlcol = map +($_ => 1), @sqlcol;

our %fetch_sqlcol;
our %storefetch_sqlcol;
our %storeupdate_sqlcol;

our %sqlcol_is_numeric = (
   d_double => 1,
   d_int    => 1,
);

our %sqlcol_dbi_type = (
  d_int      => DBI::SQL_INTEGER,
  d_double   => DBI::SQL_NUMERIC,
  d_string   => DBI::SQL_BINARY,
  d_blib     => DBI::SQL_BINARY,
  d_fulltext => DBI::SQL_BINARY,
);

sub prepare_papp_dbh {
  my $dbh = shift;

  for (@sqlcol) {
    $fetch_sqlcol{$_} =
      $dbh->prepare ("select data from $_ where id = ? and type = ?");

    my $st = $storefetch_sqlcol{$_} =
      $dbh->prepare ("select data <=> ? from $_ where id = ? and type = ?");

    $st->bind_param (1, undef, { TYPE => $Agni::sqlcol_dbi_type{$_} });

    my $st = $storeupdate_sqlcol{$_} =
      $dbh->prepare ("update $_ set data = ? where (not (data <=> ?)) and id = ? and type = ?");

    $st->bind_param (1, undef, { TYPE => $Agni::sqlcol_dbi_type{$_} });
    $st->bind_param (2, undef, { TYPE => $Agni::sqlcol_dbi_type{$_} });
  }
};

$PApp::Config::prepare_papp_dbh{"Agni::sqlcol"} = \&prepare_papp_dbh;
prepare_papp_dbh $PApp::Config::DBH;

sub lock_all_tables {
   "lock tables obj_gidseq write, obj write, ". join ", ", map "$_ write", @sqlcol, @_;
}

sub new_objectid() {
   sql_exec "lock tables obj_gidseq write";
   my $gid = sql_fetch "select seq from obj_gidseq";
   sql_exec "update obj_gidseq set seq = seq + 1";
   sql_exec "unlock tables";
   $gid;
}

sub insert_obj($$$) {
   sql_insertid sql_exec "insert into obj (id, gid, paths) values (?, ?, ?)",
                         $_[0], $_[1], $_[2];
}

sub newpath($) {
   unless (defined $pathid{$_[0]}) {
      my $path = "";
      sql_exec "lock tables obj_path write, obj write";
      for (split /\//, $_[0]) {
         my $parent = $path;
         $path .= "$_/";
         unless (sql_uexists "obj_path where path = ?", $path) {
            my $pathid = 0;
            $pathid++ while sql_exists "obj_path where id = ?", $pathid;
            $pathid < 64 or die "no space for new path $path, current limit is 64 paths\n";

            sql_uexec "insert into obj_path (id, path) values (?, ?)", $pathid, $path;

            sql_exec "update obj set paths = paths | (1 << ?) where paths & (1 << ?) <> 0", $pathid, $pathid{$parent};
            $pathid{$path} = $pathid;
         }
      }
      PApp::Event::broadcast agni_update => [&UPDATE_PATHS];
      sql_exec "unlock tables";
   }
}

# return the pathid of the staging path corresponding to the given path
sub staging_path($) {
   defined $_[0] and defined $pathname[$_[0]]
      or die "staging_path called without a pathid\n";
   (my $path = $pathname[$_[0]]) =~ s{/(staging/)?$}{/staging/};
   newpath $path unless exists $pathid{$path};
   defined $pathid{$path}
      or die "FATAL 101: unable to create staging path for $_[0] ($path)\n";
   $pathid{$path};
}

# the reverse to staging_path
sub commit_path($) {
   defined $_[0] and defined $pathname[$_[0]]
      or die "staging_path called without a pathid\n";
   (my $path = $pathname[$_[0]]) =~ s{/staging/$}{/};
   newpath $path unless exists $pathid{$path};
   defined $pathid{$path}
      or die "FATAL 101: unable to create commit path for $_[0] ($path)\n";
   $pathid{$path};
}

sub staging_path_p($) {
   $pathname[$_[0]] =~ m{/staging/$};
}

#############################################################################

our $hold_updates;
our @held_updates;

sub hold_updates(&;@) {
   local $hold_updates = $hold_updates + 1;
   eval { &{+shift} };

   # ALWAYS broadcast updates, even if we are deeply nested
   if (@held_updates) {
      local $@;
      PApp::Event::broadcast agni_update => @held_updates;
      @held_updates = ();
   }

   die if $@;
}

sub update(@) {
   if ($hold_updates) {
      push @held_updates, @_;
   } else {
      PApp::Event::broadcast agni_update => @_;
   }
}

#############################################################################

sub gid($) {
   ref $_[0] ? $_[0]{_gid} : $_[0];
}

=item path_obj_by_gid $path, $gid

Returns a object by gid in a specified path.

=cut

sub path_obj_by_gid($$) {
   $obj_cache{$_[1]}[$_[0]]
      or do {
         local $PApp::SQL::DBH = $DBH;
         update_class({ _path => $_[0], _gid => $_[1], _loading => 1 })
      };
}

# like path_obj_by_gid, but is called by PApp::Storable
*storable_path_obj_by_gid = \&path_obj_by_gid;
#sub storable_path_obj_by_gid {
#   warn "SPOBID @_\n";
#   my $gid = $_[1];
#   my $ob = &path_obj_by_gid;
#   use PApp::Util; warn PApp::Util::sv_dump $ob if $gid eq "64424509652";#d#
#   $ob
#}#d#

=item obj_by_name $spec

Loads on object by name. The C<$spec> string consists of an agni I<path>
followed by an object name, separated by a slash (C</>). An additional
leading slash will be ignored. Object names are either a numeric GID, or a
namespace name and an object name separated by a slash.

A few examples should make it clear:

   root/agni/2         # the attr object, numeric object name
   root/agni/GID/2     # same object, with namespace syntax
   /root/agni/GID/2    # same object, extra slash at the beginning
   root/agni/agni/attr # same object, different namespace

=cut

sub obj_by_name($) {
   my ($spec) = @_;

   my ($path, $nsname, $name);

   if ($spec =~ s%/(\d+)$%/%) {
      ($path, $nsname, $name) = ($spec, GID => $1);
      $path =~ s%/GID/$%/%;
   } else {
      $spec =~ s%/([^/]+)/([^/]+)$%/%
         or croak "$spec: unable to split into path/GID or path/namespace/name parts\n";
      ($path, $nsname, $name) = ($spec, $1, $2);
   }

   $path =~ s%^/%%;

   my $pathid = $Agni::pathid{$path}
      or croak "$path: path does not exist\n";

   my $ns = (Agni::path_obj_by_gid $pathid, $Agni::OID_NAMESPACES)->lookup ($nsname)
      or croak "$nsname: no such namespace\n";

   $ns->lookup ($name)
      or croak "$name: no such object in namespace $nsname\n"
}

# stolen & modified from Symbol::delete_package: doesn't remove the stash itself
sub empty_package ($) {
   my $pkg = shift;

   unless ($pkg =~ /^main::.*::$/) {
      $pkg = "main$pkg"       if      $pkg =~ /^::/;
      $pkg = "main::$pkg"     unless  $pkg =~ /^main::/;
      $pkg .= '::'            unless  $pkg =~ /::$/;
   }

   my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
   my $stem_symtab = *{$stem}{HASH};
   return unless defined $stem_symtab and exists $stem_symtab->{$leaf};

   # free all the symbols in the package

   my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
   foreach my $name (keys %$leaf_symtab) {
      undef *{$pkg . $name};
   }

   # delete the symbol table

   %$leaf_symtab = ();
}

our $bootstrap; # bootstrapping?
our %bootstrap; # contains postponed methods/objects
our %bootstrap_cache;
our $update_level;

# for bootstrapping and used in object::attr::named::method

# a single callback that preloads the object containing the real callback
my $agni_cb =
   PApp::Callback::register_callback
      \&agni_exec_cb,
      name => "agni_cb";

# load the object and call the corresponding callback
sub agni_exec_cb {
   my ($obj, $name) = splice @_, 0, 2;

   goto &{
      $obj->{_cb}{$name}
         or croak "cannot execute callback $obj->{_path}/$obj->{_gid}/$name for $_[0]{_path}/$_[0]{_gid}: callback doesn't exist";
   };
}

# substitute for PApp::Callback::register, used in perl/pxml2pcode
sub register_callback {
   my ($path, $gid, $cb, undef, $name) = @_;
   my $obj = path_obj_by_gid $path, $gid
      or Carp::confess "Unable to load object belonging to callback ($path/$gid)";

   $obj->{_cb}{$name} = $cb;

   $agni_cb->new (args => [$obj, $name]);
}

sub register_callback_info {
   my $self = shift;
   +{
      register_function => "Agni::register_callback $self->{_path}, '$self->{_gid}',",
      callback_preamble => "my \$self = shift;",
      argument_preamble => "\$self",
   }
}

use vars '$PACKAGE'; # the current compilation package (NOT our because that's visible inside eval's!!!)

sub get_package {
   my ($path, $gid) = @_;

   $ns_cache{$path, $gid} || do {
      my $package;

      # during bootstrap, everything is put into the default package. oh yes!!
      if ($bootstrap) {
         return $agni_bootns[$path] if $agni_bootns[$path];
         $package = $agni_bootns[$path] = bless {
            _path  => $path,
            _gid   => $gid,
         }, Agni::BootPackage::;
      } else {
         $package = path_obj_by_gid $path, $gid;
      }

      $package->{_package_name} = "ns::$package->{_path}::$package->{_gid}";

      my $init_code = q~
         use strict qw(vars subs);#TODO: common::sense

         use Carp;
         use Convert::Scalar ':utf8';
         use List::Util qw(min max);

         use PApp;
         use PApp::Config ();
         use PApp::SQL;
         use PApp::HTML;
         use PApp::Exception;
         use PApp::Callback;
         use PApp::Env;
         use PApp::Util qw(dumpval);

         use PApp::Application ();

         use Agni qw(*env *app path_obj_by_gid gid obj_of);

         use vars qw($PATH $PACKAGE $papp_translator);

         sub obj($) {
            ref $_[0] ? $_[0] : path_obj_by_gid PATH, $_[0];
         }

         # HACK BEGIN
         use PApp::XSLT;
         use PApp::ECMAScript;
         use PApp::XML qw(xml_quote);
         use PApp::UserObs;
         use PApp::PCode qw(pxml2pcode perl2pcode pcode2perl);
         use PApp::XPCSE;
         use PApp::EditForm;

         sub __      ($){ PApp::I18n::Table::gettext (PApp::I18n::get_table ($papp_translator, $PApp::langs), $_[0]) }
         sub gettext ($){ PApp::I18n::Table::gettext (PApp::I18n::get_table ($papp_translator, $PApp::langs), $_[0]) }
         # HACK END
      ~;

      ${"$package->{_package_name}::PATH"}    = $path;
      ${"$package->{_package_name}::PACKAGE"} = $package;
      ${"$package->{_package_name}::papp_translator"}
         = PApp::I18n::open_translator ("$PApp::i18ndir/" . eval { $package->domain }, $package->{lang});

      $package->eval (qq~
            sub PATH() { $path }
            $init_code;
         ~);
      die if $@;

      $package->initialize;

      $ns_cache{$path, $gid} = $package
         unless Agni::BootPackage:: eq ref $package; # don't cache the bootpackage

      $package
   }
}

BEGIN {
   no strict;

   $objtag_start    = "\x{10f101}";
   $objtag_type_lo  = "\x{10f102}";
   $objtag_obj      = "\x{10f102}"; # inline object
   $objtag_obj_gid  = "\x{10f103}"; # inline object gid
   $objtag_obj_show = "\x{10f104}"; # call show, used by content::dynamic::xml
   $objtag_type_hi  = "\x{10f1ed}";
   $objtag_end      = "\x{10f1fe}";
}

# compile code into the current package... also expands the special method gids

sub compile {
   no strict;

   my $code = $_[0];

   $code =~ s{
      $objtag_start([$objtag_type_lo-$objtag_type_hi])([^$objtag_end]*)$objtag_end
   }{
      my ($type, $content) = ($1, $2);
      if ($type eq $objtag_obj) {
         # we have to load delayed to be able to bootstrap, currently
         #"+(\$Agni::obj_cache{'$content'}[$PACKAGE->{_path}] || obj '$content')"
         "+(state \$__ = obj '$content')"
      } elsif ($type eq $objtag_obj_gid) {
         "'$content'";
      } else {
         warn "unknown method tag " . ((ord $type) - (ord $objtag_type_lo) + 2) . " with content '$content', maybe you need a newer version of agni?\n";
         "";
      }
   }ogex; # " vim fix

   use 5.010;
   use strict qw(vars subs);
   local $SIG{__DIE__};

   eval "package $PACKAGE->{_package_name}; $code";
}

sub compile_method_perl {
   my ($self, $name, $args, $code) = @_;

   my $args = join ",", '$self', split /[ \t,]+/, $args;

   my $class     = ref $self;
   my $isa_class = ref $self->{_isa};

   $code =~ s/->SUPER::/->$isa_class\::/g;
   $code =~ s/->SUPER(?!\w)/->$isa_class\::$name/g;

   compile "sub $class\::$name { my ($args) = \@_; ();\n"
         . "#line 3 \"{$pathname[$self->{_path}]$self->{_gid}::$name}\"\n"
         . "$code\n"
         . "}";

   if (my $err = $@) {
      *{"$class\::$name"} = sub {
         fancydie "can't call method $name because of compilation errors", $err, abridged => 1;
      };

      $last_compile_status = $err;
      warn "error while compiling $self->{_path}/$self->{_gid}->$name: $err";
   }
}

sub compile_method_environment {
   my ($self, $cb) = @_;

   $self->{_package}
      or croak "unable to compile method: no package in object $self->{_path}/$self->{_gid}";

   local $PACKAGE = get_package $self->{_path}, $self->{_package};
   local $PApp::PCode::register_callback = register_callback_info $self;

   if ((ref $self) eq (ref $self->{_isa})) {
      my $class = "agni::$self->{_path}::$self->{_gid}";

      @{"$class\::ISA"} = ref $self;

      update_isa_class ($self, $class);
   }

   &$cb;
}

# the toplevel object, can't be edited etc.. but it exists ;)
our $toplevel_object = Agni::agnibless { }, agni::object::;

exists $toplevel_object->{_type} or die; # magic?

sub Agni::BootPackage::eval {
   local $PACKAGE = $_[0];

   compile $_[1];
}

sub Agni::BootPackage::initialize {
   my $self = shift;
   # might be called multiple times
   $self->{_initialized} ||= do {
      # nop, for now
      1;
   };
}

sub Agni::BootPackage::domain {
   "agni"
}

# a very complicated thing happens here: the initial loading of the
# objects necessary to work properly - during bootstrap, only string
# datatypes and perl methods are compiled, the rest is fixed later.
sub agni_bootstrap($) {
   my $path = $_[0];

   $path =~ /^\d+$/
      or fancydie "bootstrapping error", "tried to bootstrap path '$path', which is not a valid path";

   local $bootstrap = 1;
   local %bootstrap;
   local %bootstrap_cache;

   # Load the absolute minimum set of objects that allows
   # loading of arbitrary other objects. These objects
   # will only load partially(!)
   for my $gid ($OID_OBJECT, $OID_PACKAGE_DEFAULT,
                $OID_ROOTSET, $OID_ISA_DATA, $OID_ISA_METHOD,
                $OID_META_PARCEL, $OID_NAMESPACES) {
      path_obj_by_gid $path, $gid;
      $BOOTSTRAP_LEVEL{$gid} ||= $bootstrap;
   }

   ####################

   # the default package must be loaded now... or is it not?
   my $package = $obj_cache{$OID_PACKAGE_DEFAULT}[$path]
      or die "FATAL 20: boot package for path $path not loaded after bootstrapping";

   $ns_cache{$package->{_path}, $package->{_gid}} = $package;
   delete $agni_bootns[$path]
      or die "FATAL 21: no bootpackage for path $path after bootstrapping";

   $package->{_package_name} = "ns::$package->{_path}::$package->{_gid}";
   $package->initialize;

   ####################

   # fix types of bootstrap objects (still in bootstrap mode, so iterate)
   while (%bootstrap) {
      $bootstrap++;
      my @bs = values %bootstrap; %bootstrap = ();
      for (@bs) {
         my ($self, $postponed) = @$_;

         $self->{_path} == $path
            or die "FATAL 23: path mismatch, path $path needs object $self->{_path}/$self->{_gid}??";

         $BOOTSTRAP_LEVEL{$self->{_gid}} ||= $bootstrap;

         # fixing datatypes
         while (my ($type, $data) = each %$postponed) {
            my $tobj = path_obj_by_gid $self->{_path}, $type
               or die "FATAL 24: unable to handle bootstrap datatype $type for object $self->{_path}/$self->{_gid}\n";
            eval {
               $tobj->populate ($self, $data);
            };
            warn "(bootstrap) unable to populate agni::$self->{_path}::$self->{_gid} with attribute $type: $@" if $@;
         }
      }
   }
}

# update the in-memory class of an object to $new
sub update_isa_class($$) {
   my ($self, $new) = @_;

   # when loading an object we never care for (nonexistant) instances
   if ($self->{_loading}) {
      agnibless $self, $new;
   } else {
      my $obj;
      my $old = ref $self;

      if ($old eq ref $self->{_isa}) {
         # has no own methods or similar, so inherits package

         if ($old ne $new) {
            for (values %obj_cache) {
               agnibless $obj, $new
                  if ($obj = $_->[$self->{_path}])
                      && ($old eq ref $obj)
                      && $obj->isa($self);
            }
         }
      }

      # "try" to nuke perl's ISA caches. simply
      # assigning to ISA does not necessarily work.
      eval "sub Agni::nukeme { }";
      my $stash = *{main::Agni::}{HASH};
      my $sub = delete $stash->{nukeme};
   }
}

# update the isa of an in-memory object
sub update_isa_mem($$) {
   my ($self, $gid) = @_;

   my $isa = path_obj_by_gid $self->{_path}, $gid;

   if (!$isa) {
      $self->{_gid} eq "1"
         or Carp::cluck "ISA class ($gid) of object $self->{_path}/$self->{_gid} doesn't exist or couldn't be loaded";

      $isa = $toplevel_object;
   }

   update_isa_class $self, ref $isa;

   $self->{_isa} = $isa;
}

#############################################################################
# support functions for _cache and _type management

my %type_hash_cache;
my %name_hash_cache;

sub _obj_member_add($$$) {
   my ($obj, $name, $tobj) = @_;

   my %type = %{ $obj->{_type} };

   $type{$name} = $tobj;

   my $key = join ",", sort %type;
   Scalar::Util::weaken ($name_hash_cache{$key} ||= \%type);
   $obj->{_type} = $name_hash_cache{$key};
}

sub _obj_member_del($$) {
   my ($obj, $name) = @_;

   my %type = %{ $obj->{_type} };

   delete $type{$name};

   my $key = join ",", sort %type;
   Scalar::Util::weaken ($name_hash_cache{$key} ||= \%type);
   $obj->{_type} = $name_hash_cache{$key};
}

sub _obj_cache_set($$$) {
#   my ($obj, $gid, $value) = @_;
   $_[0]{_cache}{$_[1]} = $_[2];
}

sub _obj_cache_del($$) {
   my ($obj, $gid) = @_;

   delete $obj->{_cache}{$gid};
}

sub _obj_cache_exists($$) {
   my ($obj, $gid) = @_;

   exists $obj->{_cache}{$gid};
}

#############################################################################

sub update_class($) {
   my $self = $_[0];

   rmagical_off $self;

   # sanity check since mysql compares 45 and '45"' as equal..
   "$self->{_path},$self->{_gid}" =~ /^[0-9]+,[0-9]+$/ or return undef;

   # is the root object available or do we need to bootstrap?
   unless ($obj_cache{1}[$self->{_path}] or $bootstrap) {
      isobject $self
         and die "FATAL 3: bootstrapping caused by already loaded object";
      agni_bootstrap $self->{_path};

      # can't reuse $self (could already be loaded!), so just return sth. else
      return path_obj_by_gid $self->{_path}, $self->{_gid};
   }

   sql_fetch \my($id, $paths),
             "select id, paths
              from obj
              where gid = ? and paths & (1 << ?) <> 0",
             "$self->{_gid}", $self->{_path};

   $id or return undef;

   ::trace_update_class_enter ($self) if DEVEL_TRACE;

   # to avoid endless recursion, set the object before loading the isa object
   # (not a problem under normal circumstances)
   $obj_cache{$self->{_gid}}[$self->{_path}] = $self;

   $self->{_id}    = $id;
   $self->{_paths} = $paths;

   local $update_level = $update_level + 1;

   $update_level < 100 or croak "deep recursion in object loader (check for circular isa?)";

   my (%data, $types, @types);

   for (@sqlcol) {
      my $st = sql_exec \my($type, $data),
                        "select type, data
                         from $_
                         where id = ?
                         order by type",
                        $id;

      while ($st->fetch) {
         $data{$type} = $data;
         push @types, $type;
      }
   }

   $types = $type_hash_cache{join ",", @types}
            ||= {
               map { $_ => undef } @types
            };

   # use populate for these, too! #d# #FIXME#
   update_isa_mem $self, delete $data{$OID_ISA};

   if (exists $data{$OID_META_PACKAGE}) {
      $self->{_package} = delete $data{$OID_META_PACKAGE};
   }

   if ($bootstrap) {
      $bootstrap{$self} = [$self, my $postponed = {}];

      # now load some data and method types
      while (my ($type, $data) = each %data) {
         my ($ismethod, $isnamed, $name, $args, $superclass) = @{$bootstrap_cache{$self->{_path},$type} ||=  [
            # classes directly descending from method::perl and having a name are considered simple perl methods
            sql_ufetch
                "select args.id is not null, 1, name.data, args.data, isa.data
                 from obj
                     inner join d_int    isa  on (obj.id = isa.id  and isa.type  = $OID_ISA)
                     inner join d_string name on (obj.id = name.id and name.type = $OID_ATTR_NAME)
                     left  join d_string args on (obj.id = args.id and args.type = $OID_METHOD_ARGS)
                 where gid = ?
                   and paths & (1 << ?) <> 0",
                $type,
                $self->{_path},
            ]};

         if ($ismethod) { # if it has an args attribute...
            $self->{_package} eq $OID_PACKAGE_DEFAULT
               or die "FATAL 31: bootstrapping object $self->{_path}/$self->{_gid} needs non-agni package $self->{_package}";

            compile_method_environment $self, sub {
               if ($superclass eq $OID_METHOD_PERL) {
                  compile_method_perl $self, $name, $args, pcode2perl perl2pcode utf8_on $data;
               } else {
                  # non-perl-method, store for later use

                  # plant a bomb
                  my $class = ref $self;
                  *{"$class\::$name"} = sub { die "non-bootstrap method $class->$name ($args) called during bootstrap" };

                  $postponed->{$type} = $data;
               }
            };

         } elsif ($isnamed) { # no args attribute but named, must be data
            # pretend to be able to handle descendents of OID_DATA_STRING and nothing else.
            _obj_cache_set $self, $type, $data if $superclass eq $OID_DATA_STRING;

            # plant a bomb, so other accesses than fetch die
            _obj_member_add $self, $name, bless { _gid => $type },
                                           "non-bootstrap data access during bootstrap ($self->{_path}/$self->{_gid}\{$type=$name}";

            $postponed->{$type} = $data;
         } else {
            $postponed->{$type} = $data;
         }
      }
   } else {
      while (my ($type, $data) = each %data) {
         # undef data must be populated, too...
         my $tobj = path_obj_by_gid ($self->{_path}, $type)
            or warn "object agni::$self->{_path}::$self->{_gid} refers to nonloadable type $type";
         eval {
            $tobj->populate ($self, $data);
         };
         warn "unable to populate agni::$self->{_path}::$self->{_gid} with attribute $type: $@" if $@;
      }

      # cannot happen during bootstrap
      for (keys %{$self->{_attr}}) {
         unless (exists $types->{$_}) {
            my $tobj = path_obj_by_gid ($self->{_path}, $_)
               or croak "agni::$self->{_path}::$self->{_gid}: unable to load type object $_, unable to depopulate\n";
            $tobj->depopulate ($self);
         }
      }
   }

   # if we were loading this object, then it's loaded now...
   # this is just used to avoid expensive loops in
   # update_isa_class in the common case, but may be used
   # for other purposes, too.
   delete $self->{_loading};

   $self->{_attr} = $types;

   rmagical_on $self;

   ::trace_update_class_leave ($self) if DEVEL_TRACE;

   $self
}

#############################################################################

sub update_commitinfo($$) {
   sql_exec "replace into d_string (id, type, data) values (?, ?, ?)",
            $_[1], $OID_COMMITINFO, "$PApp::NOW $PApp::stateid $_[0] {$PApp::Config{SYSID}}";
}

# make sure the object described by $paths|$gid|$id is copied into the
# target layer. returns the new id on copy or undef otherwise.
# another way to view this operation is that the object is split
# at the path $target and the id of the copy is returned (if one was created)

sub split_obj {
   my ($paths, $gid, $id, $target) = @_;

   sql_exec lock_all_tables ();

   my $newid = eval {
      local $SIG{__DIE__};
      insert_obj undef, $gid, and64 $paths, $subpathmask[$target];
   };
   if ($newid) {
      sql_exec "update obj set paths = paths &~ ? where id = ?", $subpathmask[$target], $id;

      for my $table (@sqlcol) {
         my $st = sql_exec \my($type, $data),
                           "select type, data from $table where id = ?",
                           $id;
         sql_exec "insert into $table (id, type, data) values (?, ?, ?)",
                  $newid, $type, $data
            while $st->fetch;
      }
      update_commitinfo split => $newid;

      sql_exec "unlock tables";

      Agni::update [UPDATE_PATHID, $paths, $gid];
   } else {
      sql_exec "unlock tables";
   }

   $newid
}

sub agni::object::copy_to_path {
   my ($self, $target) = @_;

   defined $target or $target = $self->{_path};

   if (and64 $self->{_paths}, $pathmask[$target]) {
      # object is from the target path
      if (and64 $self->{_paths}, $parpathmask[$target]) {
         split_obj $self->{_paths}, $self->{_gid}, $self->{_id}, $target
            || sql_fetch "select id from obj where gid = ? and paths & (1 << ?) <> 0", $self->{_gid}, $target;
      } else {
         $self->{_id};
      }
   } else {
      # object is outside the target path, fetch the id of the correct object
      sql_fetch "select id from obj where gid = ? and paths & (1 << ?) <> 0", $self->{_gid}, $target;
   }
}

# these are rarely shown and only defined for completeness
sub agni::object::name     { "\x{4e0a}" }
sub agni::object::fullname { "\x{4e0a}" }

sub agni::object::isa_obj {
   $_[0]{_isa}
}

sub agni::object::STORABLE_freeze {
   Carp::croak "cannot serialise agni objects via Storable - use PApp::Storable instead, at";
}

sub update_isa {
   my ($self) = @_;

   sql_exec "replace into d_int (id, type, data) values (?, ?, ?)", $self->{_id}, $OID_ISA, $self->{_isa}{_gid};
}

=item path_gid2name $path, $gid

Tries to return the name of the object, or some other descriptive string, in
case the object lacks a name. Does not load the object into memory, but
might load other objects in memory.

=cut

sub path_gid2name($$) {
   my ($path, $gid) = @_;
   if (my $obj = $obj_cache{$gid}[$path]) {
      return $obj->name;
   } else {
      my $st = sql_exec \my ($nsname, $oname),
                        "select ns_name.data, attr_ns.data
                         from obj
                            inner join d_string attr_ns on (obj.id = attr_ns.id)
                            inner join obj obj_ns on (obj_ns.gid = attr_ns.type)
                            inner join d_int isa_ns on (isa_ns.id = obj_ns.id and isa_ns.type = $OID_ISA_NAMESPACE)
                            inner join d_string ns_name on (ns_name.id = obj_ns.id and ns_name.type = $OID_NAMESPACES)

                         where
                            obj.gid = ?
                            and obj.paths & (1 << ?) <> 0
                            and obj_ns.paths & (1 << ?) <> 0
                         limit 1",
                        $gid, $path, $path;

      if ($st->fetch) {
         utf8_on $nsname;
         utf8_on $oname;
         return "$nsname/$oname";
      } elsif (my $isa = sql_fetch "select isa.data
                                    from obj inner join d_int isa on (isa.id = obj.id and isa.type = $OID_ISA)
                                    where gid = ? and paths & (1 << ?) <> 0",
                                   $gid, $path) {
         my $aname = sql_fetch
                        "select attr_name.data
                         from obj
                            inner join d_string attr_name on (attr_name.id = obj.id and attr_name.type = $OID_ATTR_NAME)
                         where
                            obj.gid = ?
                            and obj.paths & (1 << ?) <> 0
                            and attr_name.data is not null",
                       $gid, $path;
         utf8_on $aname;

         (path_gid2name ($path, $isa)) . ">" . ($aname ? "#$aname" : $gid);
      } else {
         "#$gid";
      }
   }
}

=item obj2name $obj

Same as path_gid2name, but works on an existing object.

=cut

sub obj2name($) {
   path_gid2name $_[0]{_path}, $_[0]{_gid};
}

=item commit_objs [$gid, $src_path, $dst_path], ...

Commit (copy) objects from one path to another. If C<$dst_path> is
undefined or missing, deletes the instance (making higher-path instances
visible again).

Currently, C<$src_path> must be the "topmost" path of one object
instance. Object instances that are also visible in parent paths are
skipped.

It returns a html fragment describing it's operations.

 # delete the root object (gid 1) from the staging path
 Agni::commit_objs [1, $Agni::pathid{"root/staging/"}, undef];

 # kind of read-modify-write for an object
 # 1. get an object into the staging path
 my $sobj = $obj->to_staging_path;
 # 2. modify it
 $sobj->{...} = ...;
 # 3a. either commit it ("save changes"):
 Agni::commit_objs [$sobj->{_gid}, $sobj->{_path}, $obj->{_path}];
 # 3b. or delete it ("cancel"):
 Agni::commit_objs [$sobj->{_gid}, $sobj->{_path}, undef];

=cut

sub commit_objs {
   my $args = \@_;
   my $wantlog = defined wantarray;
   PApp::capture {
      my @event;

      sql_exec lock_all_tables "d_string name1", "d_string name2";

      :><p><:
      eval {
         for (@$args) {
            my ($obj_gid, $src, $dst) = @$_;

            :>gid <?$obj_gid:>...<:

            my ($obj_paths, $obj_id);

            if (my $obj = $obj_cache{$obj_gid}[$src]) {
               ($obj_paths, $obj_id) = ($obj->{_paths}, $obj->{_id});
            } else {
               ($obj_paths, $obj_id)
                  = sql_fetch "select paths, id from obj where paths & (1 << ?) <> 0 and gid = ?",
                              $src, $obj_gid;
            }

            if ($wantlog && 0) {#d#
               my $name = sql_fetch "select coalesce(name1.data, concat('#', name2.data), concat('#', gid))
                                     from obj
                                        left join d_string name1 on (obj.id = name1.id and name1.type = $OID_META_NAME)
                                        left join d_string name2 on (obj.id = name2.id and name2.type = $OID_ATTR_NAME)
                                     where paths & (1 << ?) <> 0 and gid = ?",
                                    $src, $obj_gid;
               :><b><?escape_html Convert::Scalar::utf8_on $name:></b>...<:
            }

            if (and64 $parpathmask[$src], $obj_paths) {
               :><?"already committed ...":><:
               # croak "commit_objs: src_path $src not the highest path of object $obj_gid";
            } else {
               # first unlink the object from the src layer.
               sql_exec "update obj set paths = paths | ? where gid = ? and paths & (1 << ?) <> 0",
                        $obj_paths, $obj_gid, $parpath[$src];

               if (defined $dst) {
                  my $dst_paths;

                  # then find the object that currently is visible in the target layer
                  sql_fetch \my($id, $paths),
                            "select id, paths from obj where gid = ? and paths & (1 << ?) <> 0",
                            $obj_gid, $dst;

                  # can't happen anymore?
                  $id != $obj_id or croak "FATAL, pls report! commit_objs: src_path $src not the highest path of object $obj_gid";

                  if ($id) {
                     # remove it from the target path
                     if (andnot64 $paths, $subpathmask[$dst]) {
                        :><?"splitting $id...":><:
                        sql_exec "update obj set paths = paths &~ ? where id = ?",
                                  $subpathmask[$dst], $id;
                     } else {
                        :><?"replacing $id...":><:
                        sql_exec "delete from $_ where id = ?", $id for ("obj", @sqlcol);
                     }
                     push @event, [UPDATE_PATHID, $paths, $obj_gid];

                     # move the commit object into the target path
                     $dst_paths = and64 $paths, $subpathmask[$dst];
                  } else {
                     :><?"created ...":><:
                     # calculcate all mask bits sans the obj_paths, use sum
                     $dst_paths = sql_fetch "select sum(paths) from obj where id != ? and gid = ?", $obj_id, $obj_gid;

                     # now move the object into the target path
                     $dst_paths = andnot64 $subpathmask[$dst], $dst_paths;
                  }

                  sql_exec "update obj set paths = ? where id = ?", $dst_paths, $obj_id;
                  update_commitinfo commit => $obj_id;
                  push @event, [UPDATE_CLASS, (or64 $dst_paths, $obj_paths), $obj_gid];
               } else {
                  :><?"removing $obj_id...":><:

                  sql_exec "delete from $_ where id = ?", $obj_id for ("obj", @sqlcol);

                  push @event, [UPDATE_CLASS, $obj_paths, $obj_gid];
               }
            }
            :><br /><:
         }
      }
      :></p><:

      my $err = $@;

      sql_exec "unlock tables";

      PApp::Event::broadcast agni_update => @event if @event;

      if ($err) {
         if ($wantlog) {
            :><error><?escape_html $err:></error><:
         } else  {
            die $err;
         }
      }

   };
}

sub check_gidseq($) {
   my ($force) = @_;

   my $seq = sql_fetch "select seq from obj_gidseq";
   my $max = sql_fetch "select max(gid) from obj where gid < (? | 0xffffffff)", $seq;

   $seq > $max
      or $force ? warn "WARNING: obj_gidseq points to allocated objects. Duplicate SYSID?\n"
                : die "FATAL, DATABASE OR IMAGE CORRUPTION: obj_gidseq points to allocated objects. Duplicate SYSID?\n";
}

sub import_objs {
   my ($objs, $pathid, $delete_layer, $force) = @_;

   defined $pathid or croak "import_objs: undefined pathid\n";

   my $pathmask = $pathmask[$pathid];
   my $submask  = $subpathmask[$pathid];

   my %type_cache;
   my %obj;

   $obj{1} = { }; # object one doesn't have an isa

   for (@$objs) {
      $_->{gid} or croak "import_objs: object without gid";

      $type_cache{$_->{gid}} = $_->{attr}{$OID_ATTR_SQLCOL};

      $obj{$_->{gid}} = $_;
   }

   sql_exec lock_all_tables();

   eval {
      for (@$objs) {
         my $gid = $_->{gid};

         # generate isa array first
         my @isa;
         do {
            unshift @isa, $gid;
            $obj{$gid} ||= do {
               my $id = sql_fetch "select id from obj where gid = ? and paths & (1 << ?) <> 0", $gid, $pathid;
               my $isa = sql_fetch "select data from d_int where type = $OID_ISA and id = ?", $id;
               $isa or croak "import_objs: can't resolve isa of object $gid";
               { attr => { $OID_ISA => $isa } };
            };
            $gid = $obj{$gid}{attr}{$OID_ISA};
         } while $gid;

         $_->{isa_array} = \@isa;

         # check types next
         while (my ($type, $data) = each %{$_->{attr}}) {
            exists $type_cache{$type} or $type_cache{$type} = do {
               my $id = sql_fetch "select id from obj where gid = ? and paths & (1 << ?) <> 0", $type, $pathid
                  or croak "import_objs: can't resolve type $type (used in object $_->{gid})";
               sql_ufetch "select data from d_string where id = ? and type = ?", $id, $OID_ATTR_SQLCOL;
            };
            defined $type_cache{$type}
               or die "import_objs: no sqlcol found for type $type";
         }
      }

      my @event;

      if ($delete_layer) {
         my $st = sql_exec \my($id),
                           "select id from obj where paths & ? <> 0 and paths & ? = 0",
                           $pathmask, $parpathmask[$pathid];
         while ($st->fetch) {
            sql_exec "delete from d_int where id = ? and type = $Agni::OID_ROOTSET", $id;
         }
      }

      for my $o (@$objs) {
         sql_exec "update obj set paths = paths & ~? where gid = ? and paths & ~? <> 0", $submask, $o->{gid}, $submask;

         my $st = sql_exec \my($id), "select id from obj where gid = ? and paths & ? <> 0", $o->{gid}, $pathmask;
         while ($st->fetch) {
            for ("obj", @sqlcol) {
               sql_exec "delete from $_ where id = ?", $id;
            }
         }

         my $obj_mask = sql_fetch "select ? - coalesce(sum(paths),0) from obj where gid = ? and paths & ~? = 0",
                                  $submask, $o->{gid}, $submask;

         my $id = insert_obj undef, $o->{gid}, $obj_mask;

         #print "importing $o->{gid} (@{$o->{isa_array}}) ($pathmask,$submask,objmask $obj_mask) as $id\n";

         while (my ($type, $data) = each %{$o->{attr}}) {
            sql_exec "insert into $type_cache{$type} (id, type, data) values (?, ?, ?)",
                     $id, $type, $data;
         }

         push @event, [Agni::UPDATE_CLASS, $obj_mask, $o->{gid}];
      }

      Agni::update @event;
   };

   check_gidseq $force;

   sql_exec "unlock tables";

   die if $@;
}

sub gc_find_instances_by_id(&@) {
   my ($cb, @seed) = @_;

   while (@seed) {
      $cb->(@seed);

      @seed = sql_fetchall
                 "select distinct obj.id
                  from obj
                     inner join d_int on (obj.id = d_int.id and d_int.type = $OID_ISA)
                     inner join obj iobj on (iobj.gid = d_int.data and obj.paths & iobj.paths <> 0)
                  where iobj.id in (" . join(",", @seed) . ")";
   }
}

sub find_dead_objects {
   my %dead; # all dead gids
   my %isai; # all ids implementing the attr_container interface
   my %isac; # all objects id's that are attr::container's

   my ($seed, $next); # set of seed (newly alive) object ids, objects alive in next round

   my $lock_tables = lock_all_tables "obj iobj", "obj type";
   sql_exec $lock_tables;

   eval {
      # first mark all objects as dead. the gc will have to find the live ones
      my $st = sql_exec \my($id), "select id from obj";
      $dead{$id} = 1 while $st->fetch;

      # find all types implementing $OID_IFACE_CONTAINER
      {
         my @seed = sql_fetchall
                           "select obj.id
                            from obj
                               inner join d_int on (d_int.id = obj.id and d_int.type = $OID_IFACE_CONTAINER)
                           ";
         gc_find_instances_by_id { $isai{$_} = 1 for @_ } @seed;
      }

      # find all types that are attr::container's and special-case them (fast)
      {
         my @seed = sql_fetchall
                        "select id from obj
                         where gid = $OID_ATTR_CONTAINER";

         gc_find_instances_by_id { $isac{$_} = delete $isai{$_} or die "isac $_ is not isai!" for @_ } @seed;
      }

      grep !defined $_, values %isac and croak "isac not a subset of isai, check type tree!";

      # the root-set of alive objects (currently only the rootset)
      $seed = [ sql_fetchall "select id from obj where gid = $OID_ROOTSET" ];

      while (@$seed) {
         $next = [];
         #print "GC " . (scalar @$seed) . "\n";

         for my $id (@$seed) {
            # check wether this object is a container type
            # (this is an important optimization)
            if ($isac{$id}) {
               for (@sqlcol) {
                  push @$next, grep delete $dead{$_},
                     sql_fetchall "select distinct obj.id
                                   from obj
                                      inner join $_ using (id)
                                      inner join obj type on (type.gid = $_.type)
                                   where type.id = ? and obj.paths & type.paths <> 0",
                                  $id;
               }
            }
         }

         my $in = join ",", @$seed;

         # mark the isa objects as alive
         push @$next, grep delete $dead{$_},
            sql_fetchall "select distinct iobj.id
                          from obj iobj
                             inner join d_int on (d_int.type = $OID_ISA and d_int.data = iobj.gid)
                             inner join obj on (obj.id = d_int.id)
                          where obj.id in ($in) and obj.paths & iobj.paths <> 0";

         for my $sqlcol (@sqlcol) {
            # now fetch all attrs of the objects, mark them alive and resolve forward references
            my $st = sql_exec \my($id, $tgid, $tid, $paths),
                              "select obj.id, $sqlcol.type, type.id, type.paths
                               from obj
                                  inner join $sqlcol on ($sqlcol.id = obj.id)
                                  inner join obj type on ($sqlcol.type = type.gid)
                               where obj.id in ($in)";

            sql_exec "unlock tables";

            while ($st->fetch) {
               # mark the types alive
               push @$next, $tid if !$isac{$tid} && delete $dead{$tid};

               # forward-resolve types implementing the attr_container interface
               if ($isai{$tid}) {

                  # do it for every single path. this is not very efficient, but very correct
                  for my $path (values %pathid) {
                     next unless and64 $paths, $pathmask[$path];

                     my $tobj = path_obj_by_gid $path, $tgid
                        or croak "FATAL: garbage_collect cannot load type object ({$paths}/$tgid)";

                     if  ($sqlcol{$tobj->{sqlcol}}) {
                        my $data =
                           sql_fetch "select data
                                      from $tobj->{sqlcol} as attr where id = ? and type = ?",
                                     $id, $tgid;

                        my $gids = $tobj->attr_enum_gid ($data);

                        if (@$gids) {
                           my $st = sql_exec \my($id), "select id from obj
                                                        where gid in (".(join ",", @$gids).") and paths & (1 << ?) <> 0",
                                                       $path;
                           while ($st->fetch) {
                              push @$next, $id if delete $dead{$id};
                           }
                        }
                     } else {
                        warn "WARNING: type object $path/$tgid in use but has invalid sqlcol\n";
                     }
                  }
               }
            }
         }

         sql_exec $lock_tables;

         $seed = $next;
      }
   };

   sql_exec "unlock tables";
   die if $@;

   [keys %dead];
}

sub mass_delete_objects {
   my ($ids) = @_;

   sql_exec lock_all_tables("obj typ");

   # adjust paths... should instead call an object method instead
   for my $id (@$ids) {
      my ($gid, $paths) = sql_fetch "select gid, paths from obj where id = ?", $id;

      $paths or
         die "$gid is not in any path\n";

      sql_exec "update obj set paths = paths | ? where gid = ? and paths & ? <> 0",
               $paths, $gid, $parpathmask[top_path ($paths)];

      for my $table (@sqlcol) {
         # find all attributes in this table that are not referencable in other paths
         my $st = sql_exec \my($did),
                           "select obj.id from obj
                               inner join $table on ($table.id = obj.id and $table.type = ?)
                               left join obj typ on (obj.paths & typ.paths & ? <> 0 and typ.gid = ? and typ.id <> ?)
                            where typ.gid is null",
                           $gid,
                           $paths, $gid, $id;

         sql_exec "delete from $table where id = ? and type = ?", $did, $gid
            while $st->fetch;
      }
   }

   my $in = join ",", @$ids;

   for my $table ("obj", @sqlcol) {
      sql_exec "delete from $table where id in ($in)";
   }

   sql_exec "unlock tables";
}

#############################################################################

local $PApp::SQL::Database = $Database;
local $PApp::SQL::DBH      = $DBH;

init_paths;

sub flush_all_objects {
   for (values %obj_cache) {
      for (grep $_, @$_) {
         if (1 >= Convert::Scalar::refcnt_rv $_ and !$BOOTSTRAP_LEVEL{$_->{_gid}}) {
            $_ = undef;
         } else {
            update_class $_;
         }
      }
   }
}

PApp::Event::on agni_update => sub {
   shift;

   my %todo;
   my $todo;

   # this bundling does slightly more than necessary, i.e. if one object
   # gets a PATHID update in one path and an CLASS update in another
   # it will class-update all
   for (@_) {
      my ($type, $paths, $gid, $attr) = @$_;

      if ($type & (UPDATE_PATHS | UPDATE_ALL)) {
         $todo |= $type;
      } else {
         $todo{$gid}[0] |= $type;
         $todo{$gid}[1] = or64 $todo{$gid}[1], $paths;
         $todo{$gid}[2]{$attr}++ if $attr;
      }
   }

   if ($todo & UPDATE_PATHS) {
      init_paths;
      for (values %obj_cache) {
         for (@$_) {
            $_
               and $_->{_paths} =
                  sql_fetch "select paths from obj where gid = ? and paths & (1 << ?) <> 0",
                            $_->{_gid}, $_->{_path};
         }
      }
   }

   if ($todo & UPDATE_ALL) {
      flush_all_objects;
      return;
   }

   while (my ($gid, $v) = each %todo) {
      my ($type, $paths) = @$v;
      if ($type & UPDATE_CLASS) {
         for (grep $_, @{$obj_cache{$gid}}) {
            my $refcnt = Convert::Scalar::refcnt_rv $_; # we use a temporary value since ->{_paths} incs the refcnt
            if (and64 $paths, $_->{_paths}) {
               if (1 >= $refcnt and !$BOOTSTRAP_LEVEL{$gid} && 0) {
                  $_ = undef;
               } else {
                  update_class $_;
               }
            }
         }
      } else {
         if ($type & UPDATE_PATHID) {
            for (grep { $_ and and64 $paths, $_->{_paths} } @{$obj_cache{$gid}}) {
               ($_->{_paths}, $_->{_id}) =
                  sql_fetch "select paths, id from obj
                             where paths & (1 << ?) <> 0 and gid = ?",
                             $_->{_path}, $_->{_gid};
            }
         }

         if ($type & UPDATE_ATTR) {
            for my $obj (grep { $_ and and64 $paths, $_->{_paths} } @{$obj_cache{$gid}}) {
               for (map { path_obj_by_gid $obj->{_path}, $_ } keys %{$v->[2]}) {
                  if ($_) {
                     $_->update ($obj, $_->fetch ($obj));
                  } else {
                     warn "unable to update some types for object $obj->{_path}/$obj->{_gid}";
                  }
               }
            }
         }
      }
   }
};

=item agni_exec { BLOCK };

Execute the given perl block in an agni-environment (i.e. database set up
correctly etc.).

=item agni_refresh

Refresh the database connection and the $PApp::NOW timestamp, and also
checks for events (e.g. write accesses) done by other agni processes.
Usually called within C<agni_exec> after some time has progressed.

Might do other things in the future.

=cut

sub agni_refresh {
   $PApp::NOW = time;
   $PApp::SQL::DBH = PApp::Config::DBH;

   %PApp::temporary = ();

   PApp::Event::check;
}

sub agni_exec(&) {
   my $cb = shift;

   local $PApp::SQL::Database = $PApp::Config::Database;
   local $PApp::SQL::DBH;
   local %PApp::state;
   local %PApp::temporary;

   agni_refresh;

   &$cb;
}

#############################################################################

package Agni::Callback;

use overload
   fallback => 1,
   #'""'  => \&asString,
   '&{}' => sub {
      my ($self, $method, $args) = @{$_[0]};
      my $method = ($self->can ($method)
         or die "can't call method $method of $self, method does not exist");
      sub {
         local $PApp::SQL::DBH = $PApp::Config::DBH;
         $method->($self, @$args, @_);
      };
   };

sub new {
   my $class = shift;

   bless [ @_ ], $class;
}


1;

=back

=head1 SEE ALSO

The C<bin/agni> commandline tool, the agni online documentation.

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut


