package Agni;

=head1 NAME

Agni - persistent data and objects

=head1 SYNOPSIS

 * This module requires the PApp module to be installed and working     *
 * Please read the LICENSE file (Agni is neither GPL nor BSD licensed). *

=head1 DESCRIPTION

Agni is a germanic god of 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 utf8;

use Carp;

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

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 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 {
   # I was lazy, all the util xs functions are in PApp.xs
   require XSLoader;
   XSLoader::load PApp, $VERSION unless defined &PApp::bootstrap;
}

@EXPORT = qw(
      require_path new_objectid

      %obj_cache

      path_obj_by_gid gid obj_of

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

@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 namespace objects
my %ns_cache;    # the namespace 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

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

$OID_METHOD_PXML	= 20;
$OID_META		= 21;
$OID_META_DESC		= 22;
$OID_META_NAME		= 23;
$OID_ATTR_NAME		= 24;
$OID_ATTR_CONTAINER     = 25;
$OID_DATA_REF           = 26;
$OID_IFACE_CONTAINER	= 27; # object has a gc_enum, + obj_enum methods (NYI)
$OID_META_NOTE		= 28; # notes/flags for objects
$OID_ATTR_TAG		= 29; # objects used as tags for containers
$OID_META_PACKAGE	= 30; # perl package name
$OID_INTERFACE		= 31; # class interface
$OID_ROOTSET		= 32; # a container containing all objects that are alive "by default"
$OID_ISA		= 33; # the data/method parent for lookups
$OID_ISA_METHOD		= 5100001742;
$OID_ISA_DATA		= 5100001741;
$OID_CMDLINE_HANDLER    = 21474836484; # util::cmdline
$OID_META_NAMESPACE	= 4295048763;
$OID_NAMESPACE_AGNI     = 4295049779; # lots of special-casing for that one
$OID_META_PARCEL	= 5100000280;

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";
}

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

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

sub lock_all_tables {
   "lock tables 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";#d#

            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];
}

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;

# 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;

   $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",
   }
}

# $NAMESPACE; # the current compilation namespace (NOT our because that's visible inside eval's!!!)

BEGIN {
   $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}"; # inline show call on obj
   $objtag_type_hi  = "\x{10f1ed}";
   $objtag_end      = "\x{10f1fe}";
}

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

sub compile {
   #local $SIG{__DIE__}; local $SIG{__WARN__}; # speed, among others
   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) {
         "+(obj\"$content\")";
      } elsif ($type eq $objtag_obj_gid) {
         "'$content'";
      #} elsif ($type eq $objtag_obj_show) {
      #   "<\:(obj '$1')->show:\>";
      } else {
         warn "unknown method tag " . ((ord $type) - (ord $objtag_type_lo) + 2) . ", maybe you need a newer version of agni?\n";
         "";
      }
   }ogex;

   eval "package $NAMESPACE->{_package}; $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\::"/ge;
   $code =~ s/->SUPER(?!\w)/"->$isa_class\::$name"/ge;

   my $err = eval {
      compile "sub $class\::$name { my ($args) = \@_;\n"
            . "#line 1 \"$class\::$name\"\n"
            . "$code\n"
            . "}";
      $@;
   } || $@;

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

      $last_compile_status = $err;
      warn $err;
   }
}

sub Agni::BootNamespace::eval {
   local $NAMESPACE = $_[0];
   compile $_[1];
}

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

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

   $ns_cache{$path, $gid} ||= do {
      my $namespace;

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

      $namespace->{_package} = "ns::$namespace->{_path}::$namespace->{_gid}";

      my $init_code = q~
         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);

         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);

         $papp_translator = PApp::I18n::open_translator(
                               "$PApp::i18ndir/mercury", "eng",
                            );
         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]) }

         for my $src (qw(macro/editform macro/xpcse)) {
            my $imp = PApp::Application::find_import PApp::Util::find_file $src, ["papp"]
               or die "$src: not found";
            $imp->load_code;
            $imp->{root}{package}->import;
         }

         # HACK END
      ~;

      ${"$namespace->{_package}::PATH"}      = $path;
      ${"$namespace->{_package}::NAMESPACE"} = $namespace;

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

      $namespace->initialize;

      # don't cache the bootnamespace
      return $namespace if Agni::BootNamespace:: eq ref $namespace;
      $namespace;
  }
}

# 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?

# 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_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_NAMESPACE_AGNI,
                $OID_ROOTSET, $OID_ISA_DATA, $OID_ISA_METHOD,
                $OID_META_PARCEL) {
      path_obj_by_gid $path, $gid;
      $BOOTSTRAP_LEVEL{$gid} ||= $bootstrap;
   }

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

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

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

   $namespace->{_package} = "ns::$namespace->{_path}::$namespace->{_gid}";
   $namespace->initialize;

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

   # fix types of bootstrap objects (still in bootstrap mode, so iterate)
   while (%bootstrap) {
      $bootstrap++;
      my @bs = values %bootstrap; %bootstrap = ();
      for my $self (@bs) {
         my $postponed = delete $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 $@ 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);
            }
         }
      }
   }
}

# 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;
}

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;

   # 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, %type);

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

      while ($st->fetch) {
         $data{$type} = $data;
         undef $type{$type};
      }
   }

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

   if (exists $data{$OID_META_NAMESPACE}) {
      $self->{_namespace} = delete $data{$OID_META_NAMESPACE};
   }

   if ($bootstrap) {
      $bootstrap{$self} = $self;

      # 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->{_namespace} eq $OID_NAMESPACE_AGNI
               or die "FATAL 31: bootstrapping object $self->{_path}/$self->{_gid} needs non-agni namespace $self->{_namespace}";

            $self->_compile_method_environment (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" };

                  $self->{_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.
            $self->{_cache}{$type} = $data if $superclass eq $OID_DATA_STRING;

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

            $self->{_postponed}{$type} = $data;
         } else {
            $self->{_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);
         eval {
            $tobj->populate ($self, $data);
         };
         warn $@ if $@;
      }

      # cannot happen during bootstrap
      for (keys %{$self->{_attr}}) {
         unless (exists $type{$_}) {
            my $tobj = path_obj_by_gid($self->{_path}, $_)
               or croak "$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.
   delete $self->{_loading};

   rmagical_on $self;

   $self->{_attr} = \%type;

   $self;
}

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

# 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;
      }

      sql_exec "unlock tables";

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

sub agni::object::_compile_method_environment {
   my ($self, $cb) = @_;

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

   local $NAMESPACE = get_namespace $self->{_path}, $self->{_namespace};
   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;
}

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;
   }
}

sub agni::object::name     { "\x{4e0a}" }
sub agni::object::fullname { "\x{4e0a}" }

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

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

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

sub agni::object::obj {
   my ($self, $gid_or_obj) = @_;

   die "self->obj is obsolete, use 'obj gid' instead";
}

=item path_gid2name $path, $gid

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

=cut

sub path_gid2name($$) {
   my ($path, $gid) = @_;
   if (my $obj = $obj_cache[$path]{$gid}) {
      return $obj->name;
   } else {
      sql_fetch \my($parcel, $namespace, $name, $name2, $isa),
                "select p.data, s.data, n.data, o.data, i.data
                 from obj
                    left join d_int    p on obj.id = p.id and p.type = $OID_META_PARCEL
                    left join d_int    s on obj.id = s.id and s.type = $OID_META_NAMESPACE
                    left join d_string n on obj.id = n.id and n.type = $OID_META_NAME
                    left join d_string o on obj.id = o.id and o.type = $OID_ATTR_NAME
                    left join d_int    i on obj.id = i.id and i.type = $OID_ISA
                 where obj.paths & (1 << ?) <> 0 and obj.gid = ?",
                $path, $gid;
      $namespace &&= (path_obj_by_gid $path, $namespace)->name . "/";
      $parcel and $namespace = "(" . (path_obj_by_gid $path, $parcel)->name . ")$namespace";
      $name2 and $name ||= "#$name2";
      if ($name) {
         return $namespace . Convert::Scalar::utf8_on $name;
      } elsif ($isa) {
         $namespace . (path_obj_by_gid $path, $isa)->name . "(#$gid)";
      } else {
         "$namespace#$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 object.

Currently, C<$src_path> must be the "topmost" path of one object instace,
undefined behaviour will result if the instance exists in a path higher
than C<$src_path>.

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:>...<:

            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) {
               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_path 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;
                  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 import_objs {
   my ($objs, $pathid, $delete_layer) = @_;

   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, $value) = 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 !defined $value;
         }
      }

      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;
   };

   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)
      push @$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)";

                     my $data =
                        sql_fetch "select data
                                   from $tobj->{sqlcol} 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};
                        }
                     }
                  }
               }
            }
         }

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

      for my $table (@sqlcol) {
         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, $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}";
                  }
               }
            }
         }
      }
   }
};

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

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 <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut


