XAO::DO::FS::Glue - glue that connects database with classes in XAO::FS

 my $odb=XAO::Objects->new(objname => 'FS::Glue',
                           dbh => $dbh);
 my $global=$odb->fetch('/');

###############################################################################
package XAO::DO::FS::Glue;
use strict;
use XAO::Utils;
use XAO::Objects;

use base XAO::Objects->load(objname => 'Atom');

use vars qw($VERSION);
$VERSION=(0+sprintf('%u.%03u',(q$Id: Glue.pm,v 2.1 2005/01/14 00:23:54 am Exp $ =~ /\s(\d+)\.(\d+)\s/))) || die "Bad VERSION";

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

sub new ($%) {
    my $proto=shift;
    my $args=get_args(\@_);
    my $class=ref($proto) || $proto;

    ##
    # If we've got Glue reference in $proto then pass that to
    # XAO::Objects to load.
    #
    if(ref($proto) &&
       $proto->isa('XAO::DO::FS::Glue') &&
       $$proto->{objname} eq 'FS::Glue') {
        my %a=%{$args};
        $a{glue}=$proto;
        return XAO::Objects->new(\%a);
    }

    ##
    # Our object
    #
    my $hash={ class => $class };
    my $self=bless \$hash, $class;

    ##
    # We must always have objname
    #
    my $objname=$args->{objname};
    $objname || $self->throw("new - must be loaded by XAO::Objects");
    $$self->{objname}=$objname;

    ##
    # When new object is created by get()'ing it we will have 'uri'
    # parameter passed.
    #
    $$self->{uri}=$args->{uri};

    ##
    # Checking if this is System::Glue or something else that is based
    # on it.
    #
    if($objname eq 'FS::Glue') {

        my $user=$args->{user};
        my $password=$args->{password};

        my $dsn=$args->{dsn};
        $dsn || $self->throw("new - required parameter missed 'dsn'");
        $dsn=~/^OS:(\w+):\w+(;.*)?$/ || $self->throw("new - bad format of 'dsn' ($dsn)");
        my $drvname='FS::Glue::' . $1;

        my $driver=XAO::Objects->new(objname  => $drvname,
                                     dsn      => $dsn,
                                     user     => $user,
                                     password => $password);
        $$self->{driver}=$driver;

        ##
        # Checking if this is a request to trash everything and produce a
        # squeky clean new database.
        #
        if($args->{empty_database}) {
            $args->{empty_database} eq 'confirm' ||
                throw $self "new - request for 'empty_database' is not 'confirm'ed";

            $driver->initialize_database;
        }

        ##
        # Loading data layout
        #
        $$self->{classes}=$driver->load_structure;
    }

    else {
        ##
        # We must have glue object somewhere - either explicitly given
        # or from an object being cloned..
        #
        my $glue=ref($proto) ? $proto : $args->{glue};
        $glue || throw $self "new - required parameter missed 'glue'";
        $$self->{glue}=$glue;
    }

    ##
    # Returning resulting object
    #
    $self;
}

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

sub DESTROY () {
    my $self=shift;
    if($$self->{driver}) {
        $self->disconnect();
    }
}

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

sub collection ($%) {
    my $self=shift;
    my $args=merge_refs(get_args(\@_), {
                            objname => 'FS::Collection',
                            glue => $self,
                        });
    XAO::Objects->new($args);
}

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

sub container_key ($) {
    my $self=shift;
    $$self->{key_value};
}

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

sub contents ($) {
    shift->values();
}

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

sub destroy ($;$) {
    my ($self,$lists_only)=@_;
    foreach my $key ($self->keys) {
        my $type=$self->describe($key)->{type};
        next if $type eq 'key';
        next if $lists_only && $type ne 'list';
        $self->delete($key);
    }
}

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

sub disconnect () {
    my $self=shift;
    $$self->{glue} &&
        throw $self "disconnect - only makes sense on database handler (did you mean 'detach'?)";
    if($$self->{driver}) {
        $$self->{driver}->disconnect();
        delete $$self->{driver};
    }
}

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

sub fetch ($$) {
    my $self=shift;
    my $path=shift;

    $path =~ /^(xaofs:\/\/(.*?))?(\/.*)$/;
    my $type;
    my $full_path;
    if($1) {
        $type=$2;
        $full_path=$path;
        $path=$3;
    }

    if(!defined $type || $type eq 'uri') {

        ##
        # Normalizing and checking path
        #
        $path=$self->normalize_path($path);
        substr($path,0,1) eq '/' || throw $self "fetch - bad path ($path)";

        ##
        # Going through the path and retrieving every element. Could be a
        # little bit more optimal, but not much..
        #
        my $node=XAO::Objects->new(objname => 'FS::Global',
                                   glue => $self,
                                   uri => '/');
        foreach my $nodename (split(/\/+/,$path)) {
            next unless length($nodename);
            if(ref($node)) {
                $node=$node->get($nodename);
            } else {
                return undef;
            }
        }

        return $node;
    }
    elsif($type eq 'collection') {
        $path =~ qr|^/class/(\w+(::\w+)*)(/.*)?$| ||
            throw $self "fetch - wrong collection uri ($full_path)";

        my $class=$1;
        $path=$3;

        my $node=$self->collection(class => $class);
        if($path && $path ne '/') {
            foreach my $nodename (split(/\/+/,$path)) {
                next unless length($nodename);
                if(ref($node)) {
                    $node=$node->get($nodename);
                } else {
                    return undef;
                }
            }
        }

        return $node;
    }
}

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

sub glue ($) {
    my $self=shift;
    return $self->_glue;
}

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

sub objname ($) {
    my $self=shift;
    $$self->{objname} || throw $self "objname - must have an objname";
}

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

sub objtype ($) {
    'Glue';
}

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

sub reset ($) {
    my $self=shift;

    if($self->transact_active) {
        $self->transact_rollback;
    }

    $self->_driver->reset;
}

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

sub transact_active ($) {
    my $self=shift;
    return $self->_driver->tr_ext_active;
}

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

sub transact_begin ($) {
    my $self=shift;
    return $self->_driver->tr_ext_begin;
}

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

sub transact_can ($) {
    my $self=shift;
    return $self->_driver->tr_ext_can;
}

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

sub transact_commit ($) {
    my $self=shift;
    return $self->_driver->tr_ext_commit;
}

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

sub transact_rollback ($) {
    my $self=shift;
    return $self->_driver->tr_ext_rollback;
}

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

sub unlink ($$) {
    my $self=shift;
    $self->delete(shift);
}

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

sub upper_class ($$) {
    my $self=shift;
    my $class_name=shift || 'FS::Global';

    return undef if $class_name eq 'FS::Global';

    my $cdesc=$$self->{classes}->{$class_name} ||
        $self->throw("upper_class - nothing known about '$class_name'");

    foreach my $fd (values %{$cdesc->{fields}}) {
        return $fd->{refers} if $fd->{type} eq 'connector';
    }
    return 'FS::Global';
}

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

sub values ($) {
    my $self=shift;
    my @k=$self->keys;
    my $num=scalar(@k);
    eprint ref($self)."::values - more then 100 keys ($num), consider scanning instead"
        if $num > 100;
    return $self->get(@k);
}

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

sub uri ($;$) {
    my $self=shift;
    my $name=shift;

    my $uri=$$self->{uri};
    return undef unless $uri;

    return $uri unless defined($name);

    return $uri eq '/' ? $uri . $name : $uri . '/' . $name;
}

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

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

sub _class_description ($) {
    my $self=shift;
    my $class_name=shift;

    if($class_name) {
        return ${$self->_glue}->{classes}->{$class_name} ||
            $self->throw("_class_description - no description for class $class_name");
    }
    else {
        return $$self->{description} if $$self->{description};

        my $objname=$$self->{objname};
        my $desc=${$self->_glue}->{classes}->{$objname} ||
            $self->throw("_class_description - object ($objname) is not configured in the database");
        $$self->{description}=$desc;

        return $desc;
    }
}

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

# Returns a reference to an array containing complete set of keys for
# the given list.
#
sub _collection_keys ($) {
    my $self=shift;
    my $desc=$$self->{class_description};
    $self->_driver->list_keys($desc->{table},'unique_id');
}

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

sub _collection_setup ($) {
    my $self=shift;

    my $glue=$self->_glue;
    $glue || $self->throw("_collection_setup - meaningless on Glue object");

    my $class_name=$$self->{class_name} || $self->throw("_collection_setup - no class name given");
    $$self->{class_description}=$self->_class_description($class_name);

    my $base_name=$$self->{base_name};
    if(!$base_name) {
        $base_name=$$self->{base_name}=$glue->upper_class($class_name) ||
                  $self->throw("_collection_setup - $class_name does not belong to the database");
    }

    $$self->{key_name}=$glue->_list_key_name($class_name,$base_name);
    $$self->{class_description}=$self->_class_description($class_name);
}

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

sub _driver ($) {
    my $self=shift;
    ($$self->{glue} ? ${$$self->{glue}}->{driver} : $$self->{driver}) ||
        $self->throw("_driver - no low level driver found");
}

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

sub _field_description ($$) {
    my $self=shift;
    my $field=shift;
    $self->_class_description->{fields}->{$field};
}

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

sub _field_default ($$) {
    my $self=shift;
    my $field=shift;

    my $desc=shift || $self->_field_description($field);

    return $desc->{default} if defined($desc->{default});

    my $type=$desc->{type};
    my $default;
    if($type eq 'text') {
        $default='';
    }
    elsif($type eq 'integer' || $type eq 'real') {
        if(!defined $desc->{minvalue}) {
            $default=0;
        }
        elsif($desc->{minvalue} <= 0 &&
              (!defined($desc->{maxvalue}) || $desc->{maxvalue} >= 0)) {
            $default=0;
        }
        else {
            $default=$desc->{minvalue};
        }
    }
    else {
        eprint "Wrong type for trying to get default (name=$field, type=$type)";
        $default='';
    }

    $desc->{default}=$default;

    return $default;
}

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

sub _glue ($) {
    my $self=shift;
    $$self->{glue} || $self->throw("_glue - meaningless on Glue object");
}

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

sub _hash_list_base_id () {
    my $self=shift;

    ##
    # Most of the time that will work fine, except for objects retrieved
    # from a Collection of some sort.
    #
    return $$self->{list_base_id} if $$self->{list_base_id};

    ##
    # Global is a special case
    #
    my $base_name=$$self->{list_base_name};
    return $$self->{list_base_id}=1 if $base_name eq 'FS::Global';

    ##
    # Collection skips over hierarchy and we have to be more elaborate.
    #
    my $connector=$self->_glue->_connector_name($self->objname,$base_name);
    $$self->{list_base_id}=$self->_retrieve_data_fields($connector);
}

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

sub _hash_list_key_value () {
    my $self=shift;

    ##
    # Returning cached value if available
    #
    return $$self->{list_key_value} if $$self->{list_key_value};

    ##
    # Finding that out.
    #
    my $cdesc=${$self->_glue}->{classes}->{$$self->{list_base_name}} ||
        $self->throw("_hash_list_key_value - no 'list_base_name' available");
    my $class_name=$self->objname;
    foreach my $fn (keys %{$cdesc->{fields}}) {
        my $fd=$cdesc->{fields}->{$fn};
        next unless $fd->{type} eq 'list' && $fd->{class} eq $class_name;
        return $$self->{list_key_value}=$fn;
    }

    $self->throw("_hash_list_key_value - no reference to the list in upper class, weird");
}

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

##
# Retrieves content of arbitrary number of data fields. Works only for
# Hash object.
#
sub _retrieve_data_fields ($@) {
    my $self=shift;

    @_ || $self->throw("_retrieve_data_field - at least one name must present");

    my $desc=$self->_class_description();

    my $data=$self->_driver->retrieve_fields($desc->{table},
                                             $$self->{unique_id},
                                             @_);

    $data ? (@_ == 1 ? $data->[0] : @$data)
          : (@_ == 1 ? undef : ());
}

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

##
# Stores multiple pre-checked for validity key/value pairs into hash
# object. Works only on Hash objects.
#
sub _store_data_fields ($$) {
    my ($self,$data)=@_;
    my $table=$self->_class_description->{table};
    $self->_driver->update_fields($table,$$self->{unique_id},$data);
}

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

##
# Returns and caches connector name between two given classes. Works
# only for Glue object.
#
sub _connector_name ($$$) {
    my $self=shift;
    my $class_name=shift;
    my $base_name=shift;
    if(exists($$self->{connectors_cache}->{$class_name}->{$base_name})) {
        return $$self->{connectors_cache}->{$class_name}->{$base_name};
    }
    my $class_desc=$$self->{classes}->{$class_name};
    $class_desc || $self->throw("_connector_name - no data for class $class_name (called on derived object?)");
    foreach my $field (keys %{$class_desc->{fields}}) {
        my $fdesc=$class_desc->{fields}->{$field};
        next unless $fdesc->{type} eq 'connector' && $fdesc->{refers} eq $base_name;
        $$self->{connectors_cache}->{$class_name}->{$base_name}=$field;
        return $field;
    }
    undef;
}

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

##
# Checks if list contains an object with the given name
#
sub _list_exists ($$) {
    my $self=shift;
    my $name=shift;
    $self->_find_unique_id($name) ? 1 : 0;
}

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

##
# Returns list key name that uniquely identify specific list objects
# along that list.
#
sub _list_key_name ($$$) {
    my $self=shift;
    my $class_name=shift;
    my $base_name=shift || '';
    if(exists($$self->{list_keys_cache}->{$class_name}->{$base_name})) {
        return $$self->{list_keys_cache}->{$class_name}->{$base_name};
    }
    my $class_desc=$$self->{classes}->{$class_name};
    $class_desc || $self->throw("_list_key_name - no data for class $class_name (called on derived object?)");
    foreach my $field (keys %{$class_desc->{fields}}) {
        my $fdesc=$class_desc->{fields}->{$field};
        next unless $fdesc->{type} eq 'key' && $fdesc->{refers} eq $base_name;
        $$self->{list_keys_cache}->{$class_name}->{$base_name}=$field;
        return $field;
    }
    $self->throw("_list_key_name - no key defines $class_name in $base_name");
}

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

##
# Returns a reference to an array containing complete set of keys for
# the given list.
#
sub _list_keys ($) {
    my $self=shift;
    my $desc=$$self->{class_description};
    $self->_driver->list_keys($desc->{table},
                              $$self->{key_name},
                              $$self->{connector_name},
                              $$self->{base_id});
}

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

sub _list_search ($%) {
    my $self=shift;

    my $options;
    $options=pop(@_) if ref($_[$#_]) eq 'HASH';

    my $conditions;
    if(scalar(@_) == 3) {
        $conditions=[ @_ ];
    }
    elsif(scalar(@_) == 1 && ref($_[0]) eq 'ARRAY') {
        $conditions=$_[0];
    }
    elsif(! @_) {
        $conditions=undef;
    }
    else {
        $self->throw('_list_search - bad arguments');
    }

    if($$self->{connector_name} && $$self->{base_id}) {
        my $special=[ $$self->{connector_name}, 'eq', $$self->{base_id} ];
        if($conditions) {
            $conditions=[ $special, 'and', $conditions ];
        }
        else {
            $conditions=$special;
        }
    }

    my $key;
    if($self->objname eq 'FS::Collection') {
        $key='unique_id';
    }
    else {
        $key=$$self->{key_name};
    }

    my $query=$self->_build_search_query(options => $options,
                                         conditions => $conditions,
                                         key => $key);

    ##
    # Performing the search
    #
    my $list=$self->_driver->search($query);

    ##
    # Post-processing results if required. The only way to get here
    # currently is if database driver does not support regex'es and
    # ws/wq search was performed.
    #
    if($query->{post_process}) {
        $self->throw('TODO; post-processing not supported yet, mail am@xao.com');
    }

    ##
    # Done.
    #
    if(@{$query->{fields_list}} > 1) {
        return [ map { $_->[0] } @$list ];
    }
    else {
        return $list;
    }
}

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

sub _build_search_query ($%) {
    my $self=shift;
    my $args=get_args(\@_);

    ##
    # Building the list of classes used and WHERE clause for the
    # conditions list.
    #
    # In case where we do not have conditions we just put current class
    # name into classes.
    #
    my $condition=$args->{conditions};
    ### dprint "CONDITION: ",Dumper($condition);
    my %classes;
    my @values;
    my %fields_map;
    my $post_process=0;
    my $clause;
    if($condition && (ref($condition) ne 'ARRAY' || @$condition)) {
        $clause=$self->_build_search_clause(\%classes,
                                            \@values,
                                            \%fields_map,
                                            \$post_process,
                                            $condition);
    }
    else {
        $clause='';
        my $class_name=$$self->{class_name} ||
            $self->throw("_build_search_query - no 'class_name', not a List or Collection?");
        $self->_build_search_field_class(\%classes,$class_name,1,"",1);
    }

    ##
    # Analyzing options
    #
    my %return_fields;
    my @distinct;
    my @orderby;
    my $options=$args->{options};
    my $debug;
    if($options) {
        foreach my $option (keys %$options) {
            if(lc($option) eq 'distinct') {
                my $list=$options->{$option};
                $list=[ $list ] unless ref($list);
                foreach my $fn (@$list) {
                    my ($sqlfn,$fdesc)=$self->_build_search_field(\%classes,$fn);
                    $fdesc->{type} eq 'list' &&
                        $self->throw("_build_search_query - can't use 'list' fields in DISTINCT");
                    $return_fields{$sqlfn}=1;
                    push(@distinct,$sqlfn);
                }
            }
            elsif(lc($option) eq 'orderby') {

                my $list=$options->{$option};

                if(ref($list)) {
                    ref($list) eq 'ARRAY' ||
                        $self->throw("_list_search - 'orderby' orderby argument must be an array reference");
                }
                else {
                    $list=[ ascend => $list ];
                }

                scalar(@$list)%2 &&
                    $self->throw("_list_search - odd number of values in 'orderby' list");

                for(my $i=0; $i<@$list; $i+=2) {
                    my $fn=$list->[$i+1];
                    my ($sqlfn,$fdesc)=$self->_build_search_field(\%classes,$fn);
                    $fdesc->{type} eq 'list' &&
                        $self->throw("_build_search_query - can't use 'list' fields in ORDERBY");
                    my $o=lc($list->[$i]);
                    $o='ascend' if $o eq 'asc';
                    $o='descend' if $o eq 'desc';
                    push(@orderby,$o,$sqlfn);
                }
            }
            elsif(lc($option) eq 'limit') {
                # pass through, handled in the driver
            }
            elsif(lc($option) eq 'index') {
                my $fn=$options->{$option};
                my ($sqlfn,$fdesc,$class_name,$class_tag)=
                    $self->_build_search_field(\%classes,$fn);
                $classes{center_class}=$class_name;
                $classes{center_tag}=$class_tag;
                $classes{center_weight}=1000;
            }
            elsif(lc($option) eq 'debug') {
                $debug=$options->{$option};
            }
            else {
                $self->throw("_build_search_query - unknown option '$option'");
            }
        }
    }

    ##
    # If post processing is required then adding everything to the list
    # of fields to return.
    #
    if($post_process) {
        @return_fields{CORE::values %fields_map}=CORE::values %fields_map;
    }

    ##
    # Adding key name into fields we need.
    #
    my $key=$args->{key} ||
        $self->throw("_build_search_query - no 'key' given");
    my ($key_field)=$self->_build_search_field(\%classes,$key);

    ##
    # Removing unused top of the tree
    #
    my $top_class=$classes{top_class};
    my $top_tag=$classes{top_tag};
    my $up=$classes{up};
    while(1) {
        last if $up->{$top_class}->{$top_tag}->{name};
        my $count=0;
        my $ntc;
        my $ntt;
        foreach my $cin (keys %$up) {
            foreach my $tin (keys %{$up->{$cin}}) {
                if($up->{$cin}->{$tin}->{class} eq $top_class) {
                    if(!$count) {
                        $ntc=$cin;
                        $ntt=$tin;
                    }
                    $count++;
                }
            }
            last if $count>1;
        }
        last if $count>1;
        delete $up->{$top_class};
        $top_class=$classes{top_class}=$ntc;
        $top_tag=$classes{top_tag}=$ntt;
        $up->{$top_class}->{$top_tag}->{class}='';
    }

    ##
    # Adding names to tables that are left in the tree but are not
    # referred by any fields and therefore did not yet get their names.
    #
    foreach my $cin (keys %$up) {
        foreach my $tin (keys %{$up->{$cin}}) {
            if(!$up->{$cin}->{$tin}->{name}) {
                my $ci=$classes{index}++;
                $up->{$cin}->{$tin}->{name}=$ci;
                $classes{names}->{$ci}={
                    class       => $cin,
                    tag         => $tin,
                    weight      => 0,
                    table       => $self->_class_description($cin)->{table},
                };
            }
        }
    }

    ##
    # Translating classes into table names and adding glue to join
    # tables together into the clause.
    #
    # We link up tables that are above our center point and then link
    # down the rest. This takes care of all tables in correct order. SQL
    # engine can of course reverse or alter the order, but generally
    # this should be pretty optimal way of joining.
    #
    my ($cc,$ct)=@classes{'center_class','center_tag'};
    my $wrapped=$clause && substr($clause,0,1) eq '(';
    my $glue=$self->_glue;
    while(1) {
        my ($uc,$ut,$cn)=@{$up->{$cc}->{$ct}}{'class','tag','name'};
        last unless $uc;
        if(!$wrapped) {
            $clause="($clause)" if $clause;
            $wrapped=1;
        }
        my $conn=$glue->_connector_name($cc,$uc);
        if($conn) {
            $conn=$self->_driver->mangle_field_name($conn);
            my $un=$up->{$uc}->{$ut}->{name};
            $clause.=" AND " if $clause;
            $clause.="$un.unique_id=$cn.$conn";
        }
        $up->{$cc}->{$ct}->{done}=1;
        $cc=$uc;
        $ct=$ut;
    }
    foreach my $cc (keys %$up) {
        foreach my $ct (keys %{$up->{$cc}}) {
            my ($uc,$ut,$cn,$d)=@{$up->{$cc}->{$ct}}{'class','tag','name','done'};
            next unless $uc && !$d;
            if(!$wrapped) {
                $clause="($clause)" if $clause;
                $wrapped=1;
            }


            my $conn=$glue->_connector_name($cc,$uc);
            if($conn) {
                $conn=$self->_driver->mangle_field_name($conn);
                my $un=$up->{$uc}->{$ut}->{name};
                $clause.=" AND " if $clause;
                $clause.="$cn.$conn=$un.unique_id";
            }
        }
    }

    ##
    # Moving key to the first position in the list of fields
    #
    delete $return_fields{$key_field};
    my @fields_list=($key_field, keys %return_fields);
    undef %return_fields;

    ##
    # Composing SQL query out of data we have.
    #
    my $c_names=$classes{names};
    my $sql='SELECT ';
    $sql.=join(',',@fields_list) .
          ' FROM ' .
          join(',',map { $c_names->{$_}->{table} . ' AS ' . $_ } keys %{$c_names});
    $sql.=' WHERE ' . $clause if $clause;

    ##
    # If we're asked to produce distinct on something then we only group
    # on that, because if we include key into group by we will not
    # eliminate rows that have non-unique values in the parameter.
    # 
    # The drawback of that is that if we were asked to have distinct
    # values in some inner class then we can have repeating keys.
    #
    if(@distinct) {
        $sql.=' GROUP BY ' . join(',',@distinct);
    }
    elsif(@fields_list>1 || scalar(keys %$c_names)>1) {
        $sql.=' GROUP BY ' . join(',',$fields_list[0]);
    }

    ##
    # Ordering goes after GROUP BY
    #
    if(@orderby) {
        $sql.=' ORDER BY ';
        for(my $i=0; $i<@orderby; $i+=2) {
            $sql.=$orderby[$i+1];
            $sql.=' DESC' if $orderby[$i] eq 'descend';
            $sql.=',' unless $i+2 == @orderby;
        }
    }

    ##
    # To aid in debugging..
    #
    print STDERR "SEARCH SQL: $sql\n" if $debug;

    ##
    # Returning resulting hash
    #
    return {
        sql => $sql,
        where => $clause,
        values => \@values,
        classes => \%classes,
        fields_list => \@fields_list,
        fields_map => \%fields_map,
        distinct => \@distinct,
        order_by => \@orderby,
        post_process => $post_process,
        options => $options,
    };
}

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

sub _build_search_field ($$$) {
    my $self=shift;
    my $classes=shift;
    my $lha=shift;
    my $glue=$self->_glue;

    my $up=$classes->{up};
    $up=$classes->{up}={} unless $up;

    ##
    # Optimizing stupid things like 'D/../E' into 'E'
    #
    while($lha=~/^(.*\/)?\w.*?\/\.\.\/(.*)$/) {
        $lha=(defined($1) ? $1 : '') . $2;
    }

    ##
    # Splitting field name into parts if it looks like path either
    # absolute or relative. Real field name is the last element, popping
    # it back into $lha.
    #
    my @path=split(/\/+/,$lha);
    $lha=pop @path;

    my $class_name;
    my $class_tag=1;
    if(@path && $path[0] eq '') {
        $class_name='FS::Global';
        shift @path;
    }
    else {
        $class_name=$$self->{class_name} ||
            $self->throw("_build_search_field - no 'class_name', not a List or Collection?");
        while(@path && $path[0] eq '..') {
            $class_name=$glue->upper_class($class_name) ||
                throw $self "_build_search_field - no upper class for $class_name";
            shift @path;
        }
    }

    $self->_build_search_field_class($classes,$class_name,$class_tag,"",1);

    my $class_desc=$self->_class_description($class_name);

    for(my $i=0; $i!=@path; $i++) {
        my $n=$path[$i];

        my $fd=$class_desc->{fields}->{$n} ||
            $self->throw("_build_search_field - unknown field '$n' in $lha");
        $fd->{type} eq 'list' ||
            $self->throw("_build_search_field - '$n' is not a list in $lha");
        my $n_class=$fd->{class};

        my $n_tag=$i+1==@path ? '' : $path[$i+1];
        if($n_tag eq '*') {
            $i++;
            $classes->{tag_index}||='ta';
            $n_tag=$classes->{tag_index}++;
        }
        elsif($n_tag=~/^\d+$/) {
            $i++;
        }
        else {
            $n_tag=1;
        }

        $self->_build_search_field_class($classes,$n_class,$n_tag,
                                                  $class_name,$class_tag);
        $class_name=$n_class;
        $class_tag=$n_tag;
        $class_desc=$self->_class_description($class_name);
    }

    my $class_index=$up->{$class_name}->{$class_tag}->{name};
    if(!$class_index) {
        $classes->{index}||='a';
        $class_index=$classes->{index}++;
        $up->{$class_name}->{$class_tag}->{name}=$class_index;
        $classes->{names}->{$class_index}={
            class       => $class_name,
            tag         => $class_tag,
            weight      => 0,
            table       => $class_desc->{table},
        };
    }

    ##
    # Special condition for 'unique_id' field names
    #
    my $field_desc=$lha eq 'unique_id' ? {} : $class_desc->{fields}->{$lha};
    $field_desc || $self->throw("_build_search_field - unknown field '$lha'");

    ##
    # Counting number of fields using that table, index have more weight
    # and unique index even more. If not overriden in options that is
    # going to be out center table.
    #
    my $inc=$field_desc->{unique} ? 20 : ($field_desc->{index} ? 10 : 1);
    my $weight=$classes->{names}->{$class_index}->{weight}+=$inc;
    if(!$classes->{center_weight} || $classes->{center_weight}<$weight) {
        $classes->{center_weight}=$weight;
        $classes->{center_class}=$class_name;
        $classes->{center_tag}=$class_tag;
    }

    ##
    # We don't need to mangle field name if it's a unique_id field
    #
    if($lha eq 'unique_id') {
        $lha=$class_index . '.' . $lha;
    }
    else {
        $lha=$class_index . '.' . $self->_driver->mangle_field_name($lha);
    }

    return ($lha,$field_desc,$class_name,$class_tag);
}

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

sub _build_search_field_class ($$$$$$) {
    my ($self,$classes,$n_class,$n_tag,$p_class,$p_tag)=@_;

    my $up=$classes->{up};

    if(!$p_class && (!$up->{$n_class} || !$up->{$n_class}->{$n_tag})) {
        if(!$classes->{top_class}) {
            $classes->{top_class}=$n_class;
            $classes->{top_tag}=$n_tag;
        }
        elsif($classes->{top_class} ne $n_class) {
            my $uc=$classes->{top_class};
            while($uc ne $n_class) {
                $uc=$self->_glue->upper_class($uc);
                last unless $uc;
                $up->{$uc}->{1}={
                    class   => '',
                    tag     => 1,
                };
                my ($ctc,$ctt)=@{$classes}{'top_class','top_tag'};
                @{$up->{$ctc}->{$ctt}}{'class','tag'}=($uc,1);
                @{$classes}{'top_class','top_tag'}=($uc,$uc eq $n_class ? $n_tag : 1);
            }
            if(!$uc) {
                $uc=$n_class;
                my $ut=$n_tag;
                while(1) {
                    if(!$up->{$uc} || !$up->{$uc}->{$ut}) {
                        $up->{$uc}->{$ut}={
                            class   => $self->_glue->upper_class($uc),
                            tag     => 1,
                        };
                        $uc=$up->{$uc}->{$ut}->{class};
                        $ut=1;
                    }
                    last if $up->{$uc}->{$ut};
                }
            }
        }
        elsif($classes->{top_tag} ne $n_tag) {
            my $uc=$classes->{top_class};
            $uc=$self->_glue->upper_class($uc) ||
                throw $self "_build_search_field_class - no upper class for $uc";
            $up->{$uc}->{1}={
                class   => '',
                tag     => 1,
            };
        }
    }

    return if $up->{$n_class} && $up->{$n_class}->{$n_tag};

    $up->{$n_class}->{$n_tag}={
        class => $p_class,
        tag   => $p_tag,
    };
}

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

sub _build_search_clause ($$$$$$) {
    my $self=shift;
    my $classes=shift;
    my $values=shift;
    my $fields_map=shift;
    my $post_process=shift;
    my $condition=shift;

    ##
    # Checking if the condition has exactly three elements
    #
    ref($condition) eq 'ARRAY' && @$condition == 3 ||
        $self->throw("_build_search_query - bad syntax of 'conditions'");
    my ($lha,$op,$rha)=@$condition;
    $op=lc($op);

    ##
    # Handling search('comment', 'wq', [ 'big', 'ugly' ]);
    #
    # Translated to search([ 'comment', 'wq', 'big' ],
    #                      'or',
    #                      [ 'comment', 'wq', 'ugly' ]);
    #
    if(!ref($lha) && ref($rha) eq 'ARRAY') {
        my @args=($lha,$op,$rha->[0]);
        for(my $i=1; $i!=@$rha; $i++) {
            @args=( [ @args ], 'or', [ $lha, $op, $rha->[$i] ] );
        }
        ($lha,$op,$rha)=@args;
    }

    ##
    # First checking if we have OR/AND stuff
    #
    if(ref($lha)) {
        ref($rha) eq 'ARRAY' ||
            $self->throw("_build_search_clause - expected an array reference in RHA '$rha'");

        my $lhv=$self->_build_search_clause($classes,
                                            $values,
                                            $fields_map,
                                            $post_process,
                                            $lha);

        my $rhv=$self->_build_search_clause($classes,
                                            $values,
                                            $fields_map,
                                            $post_process,
                                            $rha);

        my $clause;
        if($op eq 'or' || $op eq '||') {
            $clause="($lhv OR $rhv)";
        }
        elsif($op eq 'and' || $op eq '&&') {
            $clause="($lhv AND $rhv)";
        }
        else {
            $self->throw("_build_search_clause - unknown operation '$op'");
        }

        return $clause;
    }

    ##
    # Now building SQL field name and class aliases to support it.
    #
    my ($field,$field_desc)=$self->_build_search_field($classes,$lha);
    $fields_map->{$lha}=$field;

    ##
    # And finally making the part of clause we were asked for
    #
    $field_desc->{type} ne 'list' ||
        $self->throw("_build_search_clause - can't search on 'list' field '$lha'");
    ref($rha) &&
        $self->throw("_build_search_clause - expected constant right hand side argument ['$lha', '$op', $rha]");

    my $rha_escaped=$rha;
    $rha_escaped=~s/([%_\\'"])/\\$1/g;

    my $clause;
    if($op eq 'eq') {
        $clause="$field=?";
        push(@$values,$rha);
    }
    elsif($op eq 'ne') {
        $clause="$field<>?";
        push(@$values,$rha);
    }
    elsif($op eq 'lt') {
        $clause="$field<?";
        push(@$values,$rha);
    }
    elsif($op eq 'le') {
        $clause="$field<=?";
        push(@$values,$rha);
    }
    elsif($op eq 'gt') {
        $clause="$field>?";
        push(@$values,$rha);
    }
    elsif($op eq 'ge') {
        $clause="$field>=?";
        push(@$values,$rha);
    }
    elsif($op eq 'cs') {
        $clause="$field LIKE '" . '%' . $rha_escaped . '%' . "'";
    }
    elsif($op eq 'sw') {
        $clause="$field LIKE '" . $rha_escaped . '%' . "'";
    }
    elsif($op eq 'ws') {
        my $tf;
        ($clause,$tf)=$self->_driver->search_clause_ws($field,$rha,$rha_escaped);
        if(!$clause) {
            $clause="$field LIKE '" . '%' . $rha_escaped . '%' . "'";
            $$post_process=1;
        }
        elsif(defined($tf)) {
            push(@$values,$tf);
        }
    }
    elsif($op eq 'wq') {
        my $tf;
        ($clause,$tf)=$self->_driver->search_clause_wq($field,$rha,$rha_escaped);
        if(!$clause) {
            $clause="$field LIKE '" . '%' . $rha_escaped . '%' . "'";
            $$post_process=1;
        }
        elsif(defined($tf)) {
            push(@$values,$tf);
        }
    }
    else {
        throw $self "_build_search_clause - unknown operator '$op'";
    }

    return $clause;
}

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

sub _list_setup ($) {
    my $self=shift;
    my $glue=$$self->{glue};
    $glue || $self->throw("_setup_list - meaningless on Glue object");
    my $class_name=$$self->{class_name} || $self->throw("_setup_list - no class name given");
    my $base_name=$$self->{base_name} || $self->throw("_setup_list - no base class name given");
    $$self->{connector_name}=$glue->_connector_name($class_name,$base_name);
    $$self->{class_description}=$$glue->{classes}->{$class_name};
    $$self->{key_name}=$glue->_list_key_name($class_name,$base_name);

    my $kdesc=$$self->{class_description}->{fields}->{$$self->{key_name}};
    $$self->{key_format}=$kdesc->{key_format};
    $$self->{key_length}=$kdesc->{key_length} || 30;
    $$self->{key_unique_id}=$kdesc->{key_unique_id};
}

##
# Finds specific value unique ID for list object. Works only in derived
# objects.
#
sub _find_unique_id ($$) {
    my $self=shift;
    my $name=shift;
    my $key_name=$$self->{key_name} || $self->throw("_find_unique_id - no key name");
    my $connector_name=$$self->{connector_name};
    my $table=$$self->{class_description}->{table};
    $self->_driver->unique_id($table,
                              $key_name,$name,
                              $connector_name,$$self->{base_id});
}

##
# Unlinks object from list. If object is not linked anywhere else calls
# destroy() on the object first.
#
sub _list_unlink_object ($$$) {
    my $self=shift;
    my $name=shift;

    my $object=$self->get($name) || $self->throw("_list_unlink_object - no object exists (name=$name)");
    my $class_desc=$object->_class_description();

    ##
    # Asking destroy to delete lists only, otherwise it will delete each
    # and every field separately thus being very very slow.
    #
    $object->destroy(1);

    ##
    # And now dropping the row itself.
    #
    $self->_driver->delete_row($class_desc->{table},
                               $$object->{unique_id});
}

##
# Stores data object into list. Must be called on List object.
#
sub _list_store_object ($$$) {
    my $self=shift;
    my ($key_value,$value)=@_;

    ref($value) ||
        $self->throw("_list_store_object - value must be an object reference");
    $value->objname eq $$self->{class_name} ||
        $self->throw("_list_store_object - wrong objname ".$value->objname.", should be $self->{class_name}");

    my $desc=$value->_class_description;
    my @flist;
    foreach my $fn (keys %{$desc->{fields}}) {
        my $type=$desc->{fields}->{$fn}->{type};
        next if $type eq 'list';
        next if $type eq 'key';
        next if $type eq 'connector';
        push @flist, $fn;
    }
    my %fields;
    @fields{@flist}=$value->get(@flist) if @flist;

    my $table=$desc->{table};
    $table || $self->throw("_list_store_object - no table");

    ##
    # If there is no name for the object then it needs to be generated
    # according to key_format.
    #
    my $driver=$self->_driver;
    my $key_name=$$self->{key_name};
    if(!$key_value) {
        my $format=$$self->{key_format} || '<$RANDOM$>';
        my $uid=$$self->{key_unique_id};
        my $translate=sub {
            my ($kw,$opt)=@_;
            my $text='';
            if($kw eq 'RANDOM') {
                $text=XAO::Utils::generate_key();
            }
            elsif($kw eq 'AUTOINC') {
                $uid || throw $self "_list_store_object - no key_unique_id known, internal bug";
                my $seq=$driver->increment_key_seq($uid);
                $text=$opt ? sprintf('%0'.$opt.'u',$seq)
                           : sprintf('%u',$seq);
            }
            elsif($kw eq 'GMTIME') {
                $text=time;
            }
            elsif($kw eq 'DATE') {
                my @t=localtime;
                $text=sprintf('%04u%02u%02u%02u%02u%02u',
                              $t[5]+1900,$t[4]+1,$t[3],
                              $t[2],$t[1],$t[0]);
            }
            else {
                throw $self "_list_store_object - unsupported key format '$format'";
            }
            return $text;
        };
        $key_value=sub {
            my $key=$format;
            $key=~s{<\$(\w+)(/(\w+))?\$>}
                                      {&$translate($1,$3)}ge;
            return $key;
        };
    }

    ##
    # Storing...
    #
    $key_value=$driver->store_row($table,
                                  $key_name,$key_value,
                                  $$self->{connector_name},$$self->{base_id},
                                  \%fields);

    return $key_value;
}

##
# Adds new data field to the hash object.
#
sub _add_data_placeholder ($%) {
    my $self=shift;
    my $args=get_args(\@_);

    my $name=$args->{name};
    my $type=$args->{type};

    my $desc=$self->_class_description;
    my $table=$self->_class_description->{table};
    my $driver=$self->_driver;

    ##
    # Copying args to avoid destroying external hash
    #
    my %fdesc;
    @fdesc{keys %{$args}}=CORE::values %{$args};
    undef $args;

    ##
    # Checking if this is a hash in a list stored in some other hash
    # other then Global.
    #
    my $upper_class=$self->upper_class;
    my $connected=(!$upper_class || $upper_class eq 'FS::Global') ? 0 : 1;

    ##
    # Checking or setting the default value.
    #
    $fdesc{default}=$self->_field_default($name,\%fdesc);

    ##
    # Adding...
    #
    if($type eq 'words') {
        throw $self "_add_data_placeholder - 'words' not supported any more";
    }
    elsif ($type eq 'text') {
        $fdesc{maxlength}=100 unless $fdesc{maxlength};

        my $dl=length($fdesc{default});
        $dl <= 30 ||
            throw $self "_add_data_placeholder - default text is longer then 30 characters";
        $dl <= $fdesc{maxlength} ||
            throw $self "_add_data_placeholder - default text is longer then maxlength ($fdesc{maxlength})";

        $driver->add_field_text($table,$name,$fdesc{index},$fdesc{unique},
                                $fdesc{maxlength},$fdesc{default},$connected);
    }
    elsif ($type eq 'integer') {
        $fdesc{minvalue}=-0x80000000 unless defined($fdesc{minvalue});
        if(!defined($fdesc{maxvalue})) {
            $fdesc{maxvalue}=$fdesc{minvalue}<0 ? 0x7FFFFFFF : 0xFFFFFFFF;
        }
        $driver->add_field_integer($table,$name,$fdesc{index},$fdesc{unique},
                                   $fdesc{minvalue},$fdesc{maxvalue},$fdesc{default},$connected);
    }
    elsif ($type eq 'real') {
        $fdesc{minvalue}+=0 if defined($fdesc{minvalue});
        $fdesc{maxvalue}+=0 if defined($fdesc{maxvalue});
        $driver->add_field_real($table,$name,$fdesc{index},$fdesc{unique},
                                $fdesc{minvalue},$fdesc{maxvalue},$fdesc{default},$connected);
    }
    else {
        $self->throw("_add_data_placeholder - unknown type ($type)");
    }

    ##
    # Updating in-memory data with our new field.
    #
    $desc->{fields}->{$name}=\%fdesc;

    ##
    # Updating Global_Fields
    #
    $driver->store_row('Global_Fields',
                       'field_name',$name,
                       'table_name',$table,
                       { type => $fdesc{type},
                         index => $fdesc{unique} ? 2 : ($fdesc{index} ? 1 : 0),
                         default => $fdesc{default},
                         maxlength => $fdesc{maxlength},
                         maxvalue => $fdesc{maxvalue},
                         minvalue => $fdesc{minvalue},
                       });
}

##
# Adds list placeholder to the Hash object.
#
# It gets here when name was already checked for being correct and
# unique.
#
sub _add_list_placeholder ($%) {
    my $self=shift;
    my $args=get_args(\@_);

    my $desc=$self->_class_description;

    my $name=$args->{name} || $self->throw("_add_list_placeholder - no 'name' argument");
    my $class=$args->{class} || $self->throw("_add_list_placeholder - no 'class' argument");
    my $key=$args->{key} || $self->throw("_add_list_placeholder - no 'key' argument");
    $self->check_name($key) || $self->throw("_add_list_placeholder - bad key name ($key)");
    my $connector;
    if($self->objname ne 'FS::Global') {  
        $connector=$args->{connector} || 'parent_unique_id';
        $self->check_name($connector) ||
            $self->throw("_add_list_placeholder - bad connector name ($key)");
    }

    my $key_format=$args->{key_format} || '<$RANDOM$>';
    if($key_format !~ /<\$RANDOM\$>/ && $key_format !~ /<\$AUTOINC(\/\d+)?\$>/) {
        throw $self "_add_list_placeholder - key_format must include either <\$RANDOM\$> or <\$AUTOINC\$> ($key_format)";
    }

    my $key_length=$args->{key_length} || 30;
    $key_length < 255 ||
        throw $self "_add_list_placeholder - key_length ($key_length) must be less then 255";

    XAO::Objects->load(objname => $class);

    my $table=$args->{table};
    if(!$table) {
        $table=$class;
        $table =~ s/^Data:://;
        $table =~ s/::/_/g;
        $table =~ s/_{2,}/_/g;
        $table='fs' . $table;
    }

    my $driver=$self->_driver;
    my $glue=$self->_glue;
    if($$glue->{classes}->{$class}) {
        throw $self "_add_list_placeholder - multiple lists for the same class are not allowed";
    }
    else {
        foreach my $c (keys %{$$self->{classes}}) {
            $c->{table} ne $table ||
                throw $self "_add_list_placeholder - such table ($table) is already used";
        }

        $driver->add_table($table,$key,$key_length,$connector);

        $$glue->{classes}->{$class}={
            table => $table,
            fields => {
                $key => {
                    type        => 'key',
                    refers      => $self->objname,
                    key_format  => $key_format,
                    key_length  => $key_length,
                }
            }
        };
        if(defined($connector)) {
            $$glue->{classes}->{$class}->{fields}->{$connector}={
                type        => 'connector',
                refers      => $self->objname,
            }
        }

        $driver->store_row('Global_Classes',
                           'class_name',$class,
                           'table_name',$table);
    }

    ##
    # Updating Global_Fields
    #
    $driver->store_row('Global_Fields',
                       'field_name',$key,
                       'table_name',$table,
                       { type       => 'key',
                         refers     => $self->objname,
                         key_format => $key_format,
                         key_seq    => 1,
                         maxlength  => $key_length,
                       });
    $driver->store_row('Global_Fields',
                       'field_name',$connector,
                       'table_name',$table,
                       { type       => 'connector',
                         refers     => $self->objname
                       }) if defined($connector);
    $desc->{fields}->{$name}=$args;
    $driver->store_row('Global_Fields',
                       'field_name',$name,
                       'table_name',$desc->{table},
                       { type       => 'list',
                         refers     => $class
                       });

    ##
    # Setting unique_id of the row where key sequence is stored. This is
    # used later in storing auto-keyed objects.
    #
    my $key_uid=$driver->unique_id('Global_Fields',
                                   'field_name',$key,
                                   'table_name',$table);
    $$glue->{classes}->{$class}->{fields}->{$key}->{key_unique_id}=$key_uid;
}

##
# Drops data field from table.
#
sub _drop_data_placeholder ($$) {
    my $self=shift;
    my $name=shift;

    my $desc=$self->_class_description;
    my $table=$self->_class_description->{table};
    my $driver=$self->_driver;

    my $uid=$driver->unique_id('Global_Fields',
                               'field_name',$name,
                               'table_name',$table);
    $uid || $self->throw("_drop_data_placeholder - no description for $table.$name in the Global_Fields");
    $driver->delete_row('Global_Fields',$uid);

    ##
    # If that field was marked as 'unique' or 'index' then we need to
    # drop index as well.
    #
    my $connected=$self->upper_class eq 'FS::Global' ? 0 : 1;
    my $index=$desc->{fields}->{$name}->{index};
    my $unique=$desc->{fields}->{$name}->{unique};

    $driver->drop_field($table,$name,$index,$unique,$connected);

    delete $desc->{fields}->{$name};
}

##
# Drops list placeholder. This is recursive - when you drop a list you
# also drop all objects in that list and if these objects had any lists
# on them - these lists too.
#
# Instead of dropping each object individually we just drop entire
# tables here. Potentially very dangerous.
#
sub _drop_list_placeholder ($$;$$) {
    my ($self,$name,$recursive,$upper_class)=@_;

    my $desc=$recursive || $self->_field_description($name);
    my $class=$desc->{class};
    my $glue=$self->_glue;
    my $cdesc=$$glue->{classes}->{$class};
    my $cf=$cdesc->{fields};

    foreach my $fname (keys %{$cf}) {
        if($cf->{$fname}->{type} eq 'list') {
            $self->_drop_list_placeholder($fname,$cf->{$fname},$class);
        }
    }

    my $driver=$self->_driver;
    my $table=$cdesc->{table};

    my $uid=$driver->unique_id('Global_Classes',
                               'class_name',$class,
                               'table_name',$table);
    $uid || $self->throw("_drop_list_placeholder - no description for $table in the Global_Classes");
    $driver->delete_row('Global_Classes',$uid);

    my $ul=$driver->list_keys('Global_Fields','unique_id','table_name',$table);
    foreach $uid (@{$ul}) {
        $driver->delete_row('Global_Fields',$uid);
    }

    if(! $recursive) {
        my $selftable=$$glue->{classes}->{$self->objname}->{table};
        $uid=$driver->unique_id('Global_Fields',
                            'field_name',$name,
                            'table_name',$selftable);
        $uid || $self->throw("_drop_list_placeholder - no description for $selftable.$name in the Global_Fields");
        $driver->delete_row('Global_Fields',$uid);
    }

    delete $$glue->{classes}->{$class};
    delete $$glue->{list_keys_cache}->{$class};
    delete $$glue->{connectors_cache}->{$class};

    if($recursive) {
        delete $$glue->{classes}->{$upper_class}->{fields}->{$name};
    }
    else {
        delete $$glue->{classes}->{$self->objname}->{fields}->{$name};
    }

    $self->_driver->drop_table($table);
}

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

sub check_name ($$) {
    my $self=shift;
    my $name=shift;
    defined($name) && $name =~ /^[a-z][a-z0-9_]*$/i && length($name)<=30;
}

sub _check_name ($$) {
    my $self=shift;
    dprint ref($self) . "_check_name - obsolete, please change to 'check_name'";
    $self->check_name(@_);
}

sub normalize_path ($$) {
    my $self=shift;
    my $path=shift;
    $path=~s/\s//g;
    $path=~s/\/{2,}/\//g;
    $path;
}

###############################################################################
1;
__END__